Fix test suite

This commit is contained in:
Gregor Kleen 2017-10-04 14:48:23 +02:00
parent b86e60843f
commit fbc1ee52ca
2 changed files with 8 additions and 51 deletions

View File

@ -1,43 +0,0 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module Handler.CommentSpec (spec) where
import TestImport
import Data.Aeson
spec :: Spec
spec = withApp $ do
describe "valid request" $ do
it "gives a 200" $ do
get HomeR
statusIs 200
let message = "My message" :: Text
body = object [ "message" .= message ]
encoded = encode body
request $ do
setMethod "POST"
setUrl CommentR
setRequestBody encoded
addRequestHeader ("Content-Type", "application/json")
statusIs 200
[Entity _id comment] <- runDB $ selectList [CommentMessage ==. message] []
assertEq "Should have " comment (Comment message Nothing)
describe "invalid requests" $ do
it "400s when the JSON body is invalid" $ do
get HomeR
let body = object [ "foo" .= ("My message" :: Value) ]
request $ do
setMethod "POST"
setUrl CommentR
setRequestBody $ encode body
addRequestHeader ("Content-Type", "application/json")
statusIs 400

View File

@ -19,24 +19,24 @@ import Yesod.Auth as X
import Yesod.Test as X import Yesod.Test as X
import Yesod.Core.Unsafe (fakeHandlerGetLogger) import Yesod.Core.Unsafe (fakeHandlerGetLogger)
runDB :: SqlPersistM a -> YesodExample App a runDB :: SqlPersistM a -> YesodExample UniWorX a
runDB query = do runDB query = do
app <- getTestYesod app <- getTestYesod
liftIO $ runDBWithApp app query liftIO $ runDBWithApp app query
runDBWithApp :: App -> SqlPersistM a -> IO a runDBWithApp :: UniWorX -> SqlPersistM a -> IO a
runDBWithApp app query = runSqlPersistMPool query (appConnPool app) runDBWithApp app query = runSqlPersistMPool query (appConnPool app)
runHandler :: Handler a -> YesodExample App a runHandler :: Handler a -> YesodExample UniWorX a
runHandler handler = do runHandler handler = do
app <- getTestYesod app <- getTestYesod
fakeHandlerGetLogger appLogger app handler fakeHandlerGetLogger appLogger app handler
withApp :: SpecWith (TestApp App) -> Spec withApp :: SpecWith (TestApp UniWorX) -> Spec
withApp = before $ do withApp = before $ do
settings <- loadYamlSettings settings <- loadYamlSettings
["config/test-settings.yml", "config/settings.yml"] [".dbsettings.yml", "config/test-settings.yml", "config/settings.yml"]
[] []
useEnv useEnv
foundation <- makeFoundation settings foundation <- makeFoundation settings
@ -47,7 +47,7 @@ withApp = before $ do
-- This function will truncate all of the tables in your database. -- This function will truncate all of the tables in your database.
-- 'withApp' calls it before each test, creating a clean environment for each -- 'withApp' calls it before each test, creating a clean environment for each
-- spec to run in. -- spec to run in.
wipeDB :: App -> IO () wipeDB :: UniWorX -> IO ()
wipeDB app = runDBWithApp app $ do wipeDB app = runDBWithApp app $ do
tables <- getTables tables <- getTables
sqlBackend <- ask sqlBackend <- ask
@ -69,7 +69,7 @@ getTables = do
-- | Authenticate as a user. This relies on the `auth-dummy-login: true` flag -- | Authenticate as a user. This relies on the `auth-dummy-login: true` flag
-- being set in test-settings.yaml, which enables dummy authentication in -- being set in test-settings.yaml, which enables dummy authentication in
-- Foundation.hs -- Foundation.hs
authenticateAs :: Entity User -> YesodExample App () authenticateAs :: Entity User -> YesodExample UniWorX ()
authenticateAs (Entity _ u) = do authenticateAs (Entity _ u) = do
request $ do request $ do
setMethod "POST" setMethod "POST"
@ -78,7 +78,7 @@ authenticateAs (Entity _ u) = do
-- | Create a user. The dummy email entry helps to confirm that foreign-key -- | Create a user. The dummy email entry helps to confirm that foreign-key
-- checking is switched off in wipeDB for those database backends which need it. -- checking is switched off in wipeDB for those database backends which need it.
createUser :: Text -> YesodExample App (Entity User) createUser :: Text -> YesodExample UniWorX (Entity User)
createUser ident = runDB $ do createUser ident = runDB $ do
user <- insertEntity User user <- insertEntity User
{ userIdent = ident { userIdent = ident