Bring Yesod scaffolding

test/Handler/CommentSpec.hs

@@ -0,0 +1,41 @@
+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")
+                addTokenFromCookie
+            
+            statusIs 200
+
+            [Entity _id comment] <- runDB $ selectList [CommentMessage ==. message] []
+            assertEqual "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")
+                addTokenFromCookie
+            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,32 @@
+module Handler.HomeSpec (spec) where
+
+import TestImport
+
+spec :: Spec
+spec = withApp $ do
+    it "loads the index and checks it looks right" $ do
+        get HomeR
+        statusIs 200
+        htmlAllContain "h1" "Welcome to Yesod"
+
+        request $ do
+            setMethod "POST"
+            setUrl HomeR
+            addToken
+            fileByLabel "Choose a file" "test/Spec.hs" "text/plain" -- talk about self-reference
+            byLabel "What's on the file?" "Some Content"
+
+        statusIs 200
+        -- more debugging printBody
+        htmlCount ".message" 1
+        htmlAllContain ".message" "Some Content"
+        htmlAllContain ".message" "text/plain"
+
+    -- 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]) []
+        assertEqual "user table empty" 0 $ length users

test/Spec.hs

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

test/TestImport.hs

@@ -0,0 +1,57 @@
+module TestImport
+    ( module TestImport
+    , module X
+    ) where
+
+import Application           (makeFoundation, makeLogWare)
+import ClassyPrelude         as X
+import Database.Persist      as X hiding (get)
+import Database.Persist.Sql  (SqlPersistM, SqlBackend, runSqlPersistMPool, rawExecute, rawSql, unSingle, connEscapeName)
+import Foundation            as X
+import Model                 as X
+import Test.Hspec            as X
+import Text.Shakespeare.Text (st)
+import Yesod.Default.Config2 (ignoreEnv, loadAppSettings)
+import Yesod.Test            as X
+
+runDB :: SqlPersistM a -> YesodExample App a
+runDB query = do
+    app <- getTestYesod
+    liftIO $ runDBWithApp app query
+
+runDBWithApp :: App -> SqlPersistM a -> IO a
+runDBWithApp app query = runSqlPersistMPool query (appConnPool app)
+
+
+withApp :: SpecWith (TestApp App) -> Spec
+withApp = before $ do
+    settings <- loadAppSettings
+        ["config/test-settings.yml", "config/settings.yml"]
+        []
+        ignoreEnv
+    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 = runDBWithApp app $ do
+    tables <- getTables
+    sqlBackend <- ask
+
+    let escapedTables = map (connEscapeName sqlBackend . DBName) tables
+        query = "TRUNCATE TABLE " ++ intercalate ", " escapedTables
+    rawExecute query []
+
+getTables :: MonadIO m => ReaderT SqlBackend m [Text]
+getTables = do
+    tables <- rawSql [st|
+        SELECT table_name
+        FROM information_schema.tables
+        WHERE table_schema = 'public';
+    |] []
+
+    return $ map unSingle tables