Commit d53bdc40 authored by Nicolas Lenz's avatar Nicolas Lenz

Clean tests

parent 0bbd19d0
......@@ -87,18 +87,6 @@ executables:
- condition: flag(library-only)
buildable: false
# Test suite
tests:
wms-server-test:
main: Spec.hs
source-dirs: test
ghc-options: -Wall
dependencies:
- wms-server
- hspec >=2.0.0
- yesod-test
- microlens
# Define flags used by "yesod devel" to make compilation faster
flags:
library-only:
......
{-# 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
comments <- runDB $ selectList [CommentMessage ==. message] []
Entity _id comment <-
case comments of
[ent] -> pure ent
_ -> error "needed 1 entity"
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
module Handler.CommonSpec (spec) where
import TestImport
spec :: Spec
spec = withApp $ do
describe "robots.txt" $ do
it "gives a 200" $ do
get RobotsR
statusIs 200
it "has correct User-agent" $ do
get RobotsR
bodyContains "User-agent: *"
describe "favicon.ico" $ do
it "gives a 200" $ do
get FaviconR
statusIs 200
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module Handler.HomeSpec (spec) where
import TestImport
spec :: Spec
spec = withApp $ do
describe "Homepage" $ do
it "loads the index and checks it looks right" $ do
get HomeR
statusIs 200
htmlAnyContain "h1" "a modern framework for blazing fast websites"
request $ do
setMethod "POST"
setUrl HomeR
addToken
fileByLabelExact "Choose a file" "test/Spec.hs" "text/plain" -- talk about self-reference
byLabelExact "What's on the file?" "Some Content"
statusIs 200
-- more debugging printBody
htmlAllContain ".upload-response" "text/plain"
htmlAllContain ".upload-response" "Some Content"
-- This is a simple example of using a database access in a test. The
-- test will succeed for a fresh scaffolded site with an empty database,
-- but will fail on an existing database with a non-empty user table.
it "leaves the user table empty" $ do
get HomeR
statusIs 200
users <- runDB $ selectList ([] :: [Filter User]) []
assertEq "user table empty" 0 $ length users
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module Handler.ProfileSpec (spec) where
import TestImport
spec :: Spec
spec = withApp $ do
describe "Profile page" $ do
it "asserts no access to my-account for anonymous users" $ do
get ProfileR
statusIs 403
it "asserts access to my-account for authenticated users" $ do
userEntity <- createUser "foo"
authenticateAs userEntity
get ProfileR
statusIs 200
it "asserts user's information is shown" $ do
userEntity <- createUser "bar"
authenticateAs userEntity
get ProfileR
let (Entity _ user) = userEntity
htmlAnyContain ".username" . unpack $ userIdent user
{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module TestImport
( module TestImport
, module X
) where
import Application (makeFoundation, makeLogWare)
import ClassyPrelude as X hiding (delete, deleteBy, Handler)
import Database.Persist as X hiding (get)
import Database.Persist.Sql (SqlPersistM, runSqlPersistMPool, rawExecute, rawSql, unSingle, connEscapeName)
import Foundation as X
import Model as X
import Test.Hspec as X
import Yesod.Default.Config2 (useEnv, loadYamlSettings)
import Yesod.Auth as X
import Yesod.Test as X
import Yesod.Core.Unsafe (fakeHandlerGetLogger)
-- Wiping the database
import Database.Persist.Sqlite (sqlDatabase, mkSqliteConnectionInfo, fkEnabled, createSqlitePoolFromInfo)
import Control.Monad.Logger (runLoggingT)
import Lens.Micro (set)
import Settings (appDatabaseConf)
import Yesod.Core (messageLoggerSource)
runDB :: SqlPersistM a -> YesodExample App a
runDB query = do
pool <- fmap appConnPool getTestYesod
liftIO $ runSqlPersistMPool query pool
runHandler :: Handler a -> YesodExample App a
runHandler handler = do
app <- getTestYesod
fakeHandlerGetLogger appLogger app handler
withApp :: SpecWith (TestApp App) -> Spec
withApp = before $ do
settings <- loadYamlSettings
["config/test-settings.yml", "config/settings.yml"]
[]
useEnv
foundation <- makeFoundation settings
wipeDB foundation
logWare <- liftIO $ makeLogWare foundation
return (foundation, logWare)
-- This function will truncate all of the tables in your database.
-- 'withApp' calls it before each test, creating a clean environment for each
-- spec to run in.
wipeDB :: App -> IO ()
wipeDB app = do
-- In order to wipe the database, we need to use a connection which has
-- foreign key checks disabled. Foreign key checks are enabled or disabled
-- per connection, so this won't effect queries outside this function.
--
-- Aside: foreign key checks are enabled by persistent-sqlite, as of
-- version 2.6.2, unless they are explicitly disabled in the
-- SqliteConnectionInfo.
let logFunc = messageLoggerSource app (appLogger app)
let dbName = sqlDatabase $ appDatabaseConf $ appSettings app
connInfo = set fkEnabled False $ mkSqliteConnectionInfo dbName
pool <- runLoggingT (createSqlitePoolFromInfo connInfo 1) logFunc
flip runSqlPersistMPool pool $ do
tables <- getTables
sqlBackend <- ask
let queries = map (\t -> "DELETE FROM " ++ (connEscapeName sqlBackend $ DBName t)) tables
forM_ queries (\q -> rawExecute q [])
getTables :: DB [Text]
getTables = do
tables <- rawSql "SELECT name FROM sqlite_master WHERE type = 'table';" []
return (fmap unSingle tables)
-- | Authenticate as a user. This relies on the `auth-dummy-login: true` flag
-- being set in test-settings.yaml, which enables dummy authentication in
-- Foundation.hs
authenticateAs :: Entity User -> YesodExample App ()
authenticateAs (Entity _ u) = do
request $ do
setMethod "POST"
addPostParam "ident" $ userIdent u
setUrl $ AuthR $ PluginR "dummy" []
-- | 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.
createUser :: Text -> YesodExample App (Entity User)
createUser ident = runDB $ do
user <- insertEntity User
{ userIdent = ident
, userPassword = Nothing
}
_ <- insert Email
{ emailEmail = ident
, emailUserId = Just $ entityKey user
, emailVerkey = Nothing
}
return user
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment