nix build, builds scaffolding succesfully

test/Handler/CommentSpec.hs

@@ -0,0 +1,47 @@
+{-# 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
+

test/Handler/CommonSpec.hs

@@ -0,0 +1,17 @@
+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

test/Handler/HomeSpec.hs

@@ -0,0 +1,35 @@
+{-# 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

test/Handler/ProfileSpec.hs

@@ -0,0 +1,28 @@
+{-# 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

test/Spec.hs

@@ -0,0 +1 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

test/TestImport.hs

@@ -0,0 +1,104 @@
+{-# 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)
+import Database.Persist.SqlBackend (getEscapedRawName)
+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 " ++ (getEscapedRawName t sqlBackend)) 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