qfpl/applied-fp-course
1
1
Fork 0
mirror of https://github.com/qfpl/applied-fp-course.git synced 2024-11-23 03:44:45 +03:00
Code Issues Projects Releases Wiki Activity

Remove the need to explain lawless (and weird) typeclass usage from tests (#64)

Browse Source 
* Started replacing hspec-wai silliness
* Start replacing the more interesting tests
* Refactor the remaining test files
* Add transformers dependency to test-suite
* Added transformers to test-suite dependency but forgot to add it to the doctests dependency list as well
* Cache the stack build directory to speed up travis builds
* Bump upper bound for doctest to permit GHC 8.6
* Fix up import indentation
This commit is contained in:
Sean Chalmers 2018-11-07 16:33:06 +10:00 committed by GitHub
parent 14ebd0f803
commit f1e89235f0
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
9 changed files with 360 additions and 203 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.travis.yml
View File

@ -16,6 +16,7 @@ cache:
- $HOME/.cabal/store - $HOME/.cabal/store
- $HOME/.ghc - $HOME/.ghc
- $HOME/.stack - $HOME/.stack
- $TRAVIS_BUILD_DIR/.stack-work
before_cache: before_cache:
- rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log

18
applied-fp-course.cabal
View File

@ -145,15 +145,23 @@ test-suite app-fp-tests
, Level06Tests , Level06Tests
, Level07Tests , Level07Tests
, Helpers
build-depends: base >= 4.8 && <4.13 build-depends: base >= 4.8 && <4.13
, applied-fp-course , applied-fp-course
, wai == 3.2.* , wai == 3.2.*
, wai-extra == 3.0.* , wai-extra == 3.0.*
, http-types >= 0.9 && < 0.13
, tasty >= 0.8 && < 1.2
, tasty-hunit >= 0.9 && < 0.11
, hspec >= 2.2 && < 3.0 , hspec >= 2.2 && < 3.0
, hspec-wai >= 0.6 && < 0.10 , hspec-wai >= 0.6 && < 0.10
, bytestring == 0.10.* , bytestring == 0.10.*
, text == 1.2.* , text == 1.2.*
, mtl == 2.2.* , mtl == 2.2.*
, semigroups == 0.18.*
, transformers >= 0.4 && < 0.6
, mmorph
test-suite doctests test-suite doctests
-- Base language which the package is written in. -- Base language which the package is written in.
@ -164,6 +172,7 @@ test-suite doctests
, Level05Tests , Level05Tests
, Level06Tests , Level06Tests
, Level07Tests , Level07Tests
, Helpers
ghc-options: -threaded ghc-options: -threaded
main-is: doctests.hs main-is: doctests.hs
@ -174,6 +183,15 @@ test-suite doctests
, hspec >= 2.2 && < 3.0 , hspec >= 2.2 && < 3.0
, hspec-wai >= 0.6 && < 0.10 , hspec-wai >= 0.6 && < 0.10
, doctest >= 0.11 && < 0.17 , doctest >= 0.11 && < 0.17
, semigroups == 0.18.*
, tasty >= 0.8 && < 1.2
, tasty-hunit >= 0.9 && < 0.11
, bytestring == 0.10.*
, wai == 3.2.*
, wai-extra == 3.0.*
, http-types >= 0.9 && < 0.13
, transformers >= 0.4 && < 0.6
, mmorph
-- Level Executables -- Level Executables
executable level01-exe executable level01-exe

7
applied-fp-course.nix
View File

@ -1,7 +1,7 @@
{ mkDerivation, aeson, base, bytestring, doctest, hspec, hspec-wai { mkDerivation, aeson, base, bytestring, doctest, hspec, hspec-wai
, http-types, mtl, optparse-applicative, semigroups, sqlite-simple , http-types, mtl, optparse-applicative, semigroups, sqlite-simple
, sqlite-simple-errors, stdenv, text, time, transformers, wai , sqlite-simple-errors, stdenv, tasty, tasty-hunit, text, time
, wai-extra, warp , transformers, wai, wai-extra, warp, mmorph
}: }:
mkDerivation { mkDerivation {
pname = "applied-fp-course"; pname = "applied-fp-course";
@ -16,7 +16,8 @@ mkDerivation {
]; ];
executableHaskellDepends = [ base ]; executableHaskellDepends = [ base ];
testHaskellDepends = [ testHaskellDepends = [
base bytestring doctest hspec hspec-wai mtl text wai wai-extra base bytestring doctest hspec hspec-wai http-types mtl tasty
tasty-hunit text wai wai-extra mmorph
]; ];
description = "Simplest of web apps for educational purposes"; description = "Simplest of web apps for educational purposes";
license = stdenv.lib.licenses.bsd3; license = stdenv.lib.licenses.bsd3;

118
tests/Helpers.hs Normal file
View File

@ -0,0 +1,118 @@
module Helpers
( -- * Test Monad
TestM
-- * Test Runner
, runTestsFor
-- * Request Builders
, get
, post
, put
-- * Response Assertions
, assertBody
, assertStatus
, assertContentType
-- * Internals
, RequestPath (..)
, rq
, rqWithBody
) where
import qualified System.Exit as Exit
import qualified Control.Exception as E
import Control.Monad.Except (ExceptT (..), runExceptT)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader (ReaderT (..), ask, runReaderT)
import Control.Monad.State (StateT (..), evalStateT, lift,
runStateT)
import qualified Control.Monad.State as State
import Data.Semigroup ((<>))
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import Network.HTTP.Types as HTTP
import Network.Wai (Application, Request (..))
import Network.Wai.Test (Session, WaiTestFailure (..))
import qualified Network.Wai.Test as WT
import Network.Wai.Test.Internal (ClientState, initState)
import Control.Concurrent.MVar (MVar)
import qualified Control.Concurrent.MVar as MVar
import Control.Monad.Morph (hoist)
-- | This terrifying beast is the combination of the 'Session' transformer stack
-- from Wai.Test and the transformer stack required to keep track of the test
-- name, along with catching the exceptions so we don't just die with an awful
-- failure and no information.
type TestM = ReaderT Application (StateT ClientState (ExceptT WaiTestFailure (StateT String IO)))
-- | By leaning on some monad morphisms, we're able to insert a transformer
-- stack at an arbitrary point in a different transformer stack that we do not
-- control. This lets us extend it with new functionality that it may not have been
-- designed for.
manipulateTransStack :: WT.Session a -> TestM a
manipulateTransStack = hoist (hoist (hoist lift . ExceptT . E.try))
-- | Although not exported, this newtype helps us keep our strings in line.
newtype RequestPath = RequestPath
{ unRequestPath :: BS.ByteString
}
-- | Create an empty 'Request' using the given HTTP Method and route.
rq :: StdMethod -> RequestPath -> Request
rq mth rpath = flip WT.setPath (unRequestPath rpath) $ WT.defaultRequest
{ requestMethod = HTTP.renderStdMethod mth
}
-- | Create a 'Request' with a body.
rqWithBody
:: StdMethod
-> RequestPath
-> LBS.ByteString
-> WT.SRequest
rqWithBody mth rpath =
WT.SRequest (rq mth rpath)
-- | Run a single instance of the 'Application' for all of the tests given in the 'TestM'.
runTestsFor :: Application -> String -> TestM a -> IO a
runTestsFor app nm m = do
(e, testName) <- runStateT (runExceptT (evalStateT (runReaderT m app) initState)) nm
either (sad testName) pure e
where
sad test (WT.WaiTestFailure msg) = do
putStrLn $ "\tTest Failure For: " <> "[" <> test <> "]"
putStrLn $ "\t" <> msg
Exit.exitFailure
testRequest :: String -> WT.Session a -> TestM a
testRequest test r = do
lift . lift . State.put $ test
manipulateTransStack r
get :: String -> BS.ByteString -> TestM WT.SResponse
get test = testRequest test . WT.request . rq HTTP.GET . RequestPath
post :: String -> BS.ByteString -> LBS.ByteString -> TestM WT.SResponse
post test r = testRequest test . WT.srequest . rqWithBody HTTP.POST (RequestPath r)
put :: String -> BS.ByteString -> LBS.ByteString -> TestM WT.SResponse
put test r = testRequest test . WT.srequest . rqWithBody HTTP.PUT (RequestPath r)
assertBody :: LBS.ByteString -> WT.SResponse -> TestM ()
assertBody b = manipulateTransStack . WT.assertBody b
assertStatus :: HTTP.Status -> WT.SResponse -> TestM ()
assertStatus c = manipulateTransStack . WT.assertStatus (HTTP.statusCode c)
assertContentType :: BS.ByteString -> WT.SResponse -> TestM ()
assertContentType b = manipulateTransStack . WT.assertContentType b

57
tests/Level03Tests.hs
View File

@ -3,49 +3,32 @@ module Level03Tests
( unitTests ( unitTests
) where ) where
import Test.Hspec import Test.Tasty (defaultMain, testGroup)
import Test.Hspec.Wai import Test.Tasty.HUnit (testCase)
import Data.String (fromString) import Network.HTTP.Types as HTTP
import qualified System.Exit as Exit import Helpers (assertBody, assertStatus, get, runTestsFor)
import qualified Data.ByteString.Lazy.Char8 as LBS8 import qualified Level03.Core as Core
import qualified Level03.Core as Core
unitTests :: IO () unitTests :: IO ()
unitTests = do unitTests = runTestsFor Core.app "Level 03 Tests" $ do
-- We need to setup our Application. -- Using the functions from ``Helpers`` this actions a GET request on the
let app' = pure Core.app -- "/list" route and compares the response body and status code to our
-- expectations
get "GET list route" "/list" >>= \resp -> do
assertBody "List Request not implemented" resp
assertStatus HTTP.status200 resp
-- This sets up HSpec to use our application as the thing it executes before the tests are run -- Write some more tests, below are some ideas to get you started:
hspec . with app' $ do
-- Here is an example test for the 'ListRq' route.
-- Start with a general description of what we're going to test.
describe "List Route" $ do
-- Individual test cases provide more precise information regarding
-- what they are going to test.
it "Should return a 'not implemented' message and 200 status" $
-- Using the functions from ``Test.Hspec.Wai`` this actions a GET request
-- on the "/list" route, and using an infix function, compares the result of
-- that request to our expected result.
-- There String literal here is being converted by the use of the -- Don't worry if you don't get all of these done. :)
-- ``IsString`` typeclass into a response type that Hspec.Wai can
-- use. Check the documentation for more examples, but when given
-- a string literal, it will assume that is the expected body of
-- the request and also check for a 200 response code.
get "/list" `shouldRespondWith` "List Request not implemented"
-- Write some more tests, below are some ideas to get you started: -- 1) The '<topic>/add' route will respond with an error when given an empty comment
-- 2) The '<topic>/view' route will respond correctly when given a topic
-- 3) The '<topic>/view' route will respond with an error when given an empty topic
-- 4) A gibberish route will return a 404
-- Don't worry if you don't get all of these done. :) -- After you're done here, you'll need to uncomment the use of these functions
-- in the `test/Test.hs` otherwise the tests won't run!
-- 1) The '<topic>/add' route will respond with an error when given an empty comment
-- 2) The '<topic>/view' route will respond correctly when given a topic
-- 3) The '<topic>/view' route will respond with an error when given an empty topic
-- 4) A gibberish route will return a 404
-- After you're done here, you'll need to uncomment the use of these functions
-- in the `test/Test.hs` otherwise the tests won't run!

89
tests/Level04Tests.hs
View File

@ -4,16 +4,22 @@ module Level04Tests
, doctests , doctests
) where ) where
import Control.Monad (join) import Control.Monad (join)
import Control.Monad.IO.Class (liftIO)
import Test.Hspec import qualified System.Exit as Exit
import Test.Hspec.Wai
import qualified System.Exit as Exit import Data.Foldable (traverse_)
import Data.Semigroup ((<>))
import qualified Level04.Core as Core import Network.HTTP.Types as HTTP
import qualified Level04.DB as DB
import qualified Level04.Types as Types import Helpers (TestM, assertBody, assertStatus, get,
post, runTestsFor)
import qualified Level04.Core as Core
import qualified Level04.DB as DB
import qualified Level04.Types as Types
-- Don't forget to uncomment these functions in @tests/Test.hs@ otherwise your -- Don't forget to uncomment these functions in @tests/Test.hs@ otherwise your
-- tests won't be run. -- tests won't be run.
@ -26,47 +32,50 @@ doctests =
, "src/Level04/Types.hs" , "src/Level04/Types.hs"
] ]
dieWith :: Show a => a -> IO ()
dieWith err = print err >> Exit.exitFailure
unitTests :: IO () unitTests :: IO ()
unitTests = do unitTests = do
let dieWith m = print m >> Exit.exitFailure reqE <- Core.prepareAppReqs
case reqE of
reqsE <- Core.prepareAppReqs
case reqsE of
Left err -> dieWith err Left err -> dieWith err
Right db -> runTestsFor (Core.app db) "Level 04 Tests" $ do
Right db -> do let
let app' = pure ( Core.app db ) flushTopic :: TestM ()
flushTopic = liftIO .
-- Clean up and yell about our errors
(traverse_ (either dieWith pure) =<<) .
-- Purge all of the comments for this topic for our tests
traverse ( DB.deleteTopic db )
-- We don't export the constructor so even for known values we have
-- to play by the rules. There is no - "Oh just this one time.", do it right.
$ Types.mkTopic "fudge"
flushTopic = -- Run a test and then flush the db
-- Clean up and yell about our errors test t = t >> flushTopic
fmap ( either dieWith pure . join ) .
-- Purge all of the comments for this topic for our tests
traverse ( DB.deleteTopic db )
-- We don't export the constructor so even for known values we have
-- to play by the rules. There is no - "Oh just this one time.", do it right.
$ Types.mkTopic "fudge"
-- Run the tests with a DB topic flush between each spec topicR = "/fudge/"
hspec . with ( flushTopic >> app' ) $ do
-- AddRq Spec addToTopic =
describe "POST /topic/add" $ do post "Add Topic" (topicR <> "add") "Fred"
it "Should return 200 with well formed request" $ do -- AddRq Spec
post "/fudge/add" "Fred" `shouldRespondWith` "Success" -- it should return 200 with well formed request
test $ addToTopic >>= assertBody "Success"
it "Should 400 on empty input" $ -- it should 400 on empty input
post "/fudge/add" "" `shouldRespondWith` 400 test $ post "Empty Input" (topicR <> "add") ""
>>= assertStatus HTTP.status400
-- ViewRq Spec -- ViewRq Spec
describe "GET /topic/view" $ do -- it should return 200 with
it "Should return 200 with content" $ do test $ addToTopic
post "/fudge/add" "Is super tasty." >> get "View topic" (topicR <> "view")
get "/fudge/view" `shouldRespondWith` 200 >>= assertStatus HTTP.status200
-- ListRq Spec -- ListRq Spec
describe "GET /list" $ do test $ addToTopic
it "Should return 200 with content" $ do >> get "List topics" "/list"
post "/fudge/add" "Is super tasty." >>= assertBody "[\"fudge\"]"
get "/list" `shouldRespondWith` "[\"fudge\"]"

90
tests/Level05Tests.hs
View File

@ -4,22 +4,28 @@ module Level05Tests
, doctests , doctests
) where ) where
import Control.Monad.Reader (ask, reader) import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader (ask, reader)
import Data.Monoid ((<>)) import Data.Foldable (traverse_)
import Data.Monoid ((<>))
import Data.String (IsString) import Data.String (IsString)
import Network.HTTP.Types as HTTP
import Test.Hspec import Test.Hspec
import Test.Hspec.Wai
import qualified System.Exit as Exit import Helpers (TestM, assertBody, assertStatus, get,
post, runTestsFor)
import qualified Level05.AppM as AppM import qualified System.Exit as Exit
import qualified Level05.Core as Core import qualified Level05.AppM as AppM
import qualified Level05.DB as DB
import qualified Level05.Types as Types import qualified Level05.Core as Core
import qualified Level05.DB as DB
import qualified Level05.Types as Types
doctests :: [FilePath] doctests :: [FilePath]
doctests = doctests =
@ -43,43 +49,45 @@ unitTests = do
reqsE <- Core.prepareAppReqs reqsE <- Core.prepareAppReqs
case reqsE of case reqsE of
Left err -> dieWith err Left err -> dieWith err
Right db -> runTestsFor (Core.app db) "Level 05 Tests" $ do
Right db -> do let
let app' = pure (Core.app db) flushTopic :: TestM ()
flushTopic = liftIO .
-- Clean up and yell about our errors
(traverse_ (either dieWith pure) =<<) .
-- Include the runner to handle our new 'AppM'
AppM.runAppM .
-- Purge all of the comments for this topic for our tests
traverse ( DB.deleteTopic db )
-- We don't export the constructor so even for known values we have
-- to play by the rules. There is no - "Oh just this one time.", do it right.
$ Types.mkTopic "fudge"
flushTopic = -- Run a test and then flush the db
-- Clean up and yell about our errors test t = t >> flushTopic
either dieWith pure =<< AppM.runAppM (
-- We don't export the constructor so even for known values we have
-- to play by the rules. There is no - "Oh just this one time.", do it right.
AppM.liftEither (Types.mkTopic testTopic)
-- Purge all of the comments for this topic for our tests
>>= DB.deleteTopic db
)
-- Run the tests with a DB topic flush between each spec topicR = "/fudge/"
hspec . with ( flushTopic >> app' ) $ do
-- Save us a bit of repetition
let pOST = post ( "/" <> testTopic <> "/add" )
-- AddRq Spec addToTopic =
describe "POST /topic/add" $ do post "Add Topic" (topicR <> "add") "Fred"
it "Should return 200 with well formed request" $
pOST "Is super tasty." `shouldRespondWith` "Success"
it "Should 400 on empty input" $ -- AddRq Spec
pOST "" `shouldRespondWith` 400 -- it should return 200 with well formed request
test $ addToTopic >>= assertBody "Success"
-- ViewRq Spec -- it should 400 on empty input
describe "GET /topic/view" $ test $ post "Empty Input" (topicR <> "add") ""
it "Should return 200 with content" $ do >>= assertStatus HTTP.status400
_ <- pOST "Is super tasty."
get ( "/" <> testTopic <> "/view" ) `shouldRespondWith` 200
-- ListRq Spec -- ViewRq Spec
describe "GET /list" $ -- it should return 200 with
it "Should return 200 with content" $ do test $ addToTopic
_ <- pOST "Is super tasty." >> get "View topic" (topicR <> "view")
get "/list" `shouldRespondWith` "[\"fudge\"]" >>= assertStatus HTTP.status200
-- ListRq Spec
test $ addToTopic
>> get "List topics" "/list"
>>= assertBody "[\"fudge\"]"

84
tests/Level06Tests.hs
View File

@ -4,20 +4,26 @@ module Level06Tests
, unitTests , unitTests
) where ) where
import Control.Monad (join) import Control.Monad (join)
import Control.Monad.IO.Class (liftIO)
import Data.Monoid ((<>)) import Data.Foldable (traverse_)
import Data.String (IsString) import Data.Monoid ((<>))
import Data.String (IsString)
import Network.HTTP.Types as HTTP
import Test.Hspec import Test.Hspec
import Test.Hspec.Wai
import qualified System.Exit as Exit import Helpers (TestM, assertBody, assertStatus, get,
post, runTestsFor)
import qualified Level06.AppM as AppM import qualified System.Exit as Exit
import qualified Level06.Core as Core
import qualified Level06.DB as DB import qualified Level06.AppM as AppM
import qualified Level06.Types as Types import qualified Level06.Core as Core
import qualified Level06.DB as DB
import qualified Level06.Types as Types
doctests :: [FilePath] doctests :: [FilePath]
doctests = doctests =
@ -38,37 +44,45 @@ unitTests = do
reqsE <- Core.prepareAppReqs reqsE <- Core.prepareAppReqs
case reqsE of case reqsE of
Left err -> dieWith err Left err -> dieWith err
Right (cfg, db) -> runTestsFor (Core.app cfg db) "Level 06 Tests" $ do
Right ( cfg, db ) -> do let
let app' = pure (Core.app cfg db) flushTopic :: TestM ()
flushTopic = liftIO .
-- Clean up and yell about our errors
(traverse_ (either dieWith pure) =<<) .
-- Include the runner to handle our new 'AppM'
AppM.runAppM .
-- Purge all of the comments for this topic for our tests
traverse ( DB.deleteTopic db )
-- We don't export the constructor so even for known values we have
-- to play by the rules. There is no - "Oh just this one time.", do it right.
$ Types.mkTopic "fudge"
flushTopic :: IO () -- Run a test and then flush the db
flushTopic = either dieWith pure =<< AppM.runAppM test t = t >> flushTopic
(AppM.liftEither (Types.mkTopic testTopic) >>= DB.deleteTopic db)
-- Run the tests with a DB topic flush between each spec topicR = "/fudge/"
hspec . with ( flushTopic >> app' ) $ do
-- Save us a bit of repetition
let pOST = post ( "/" <> testTopic <> "/add" )
-- AddRq Spec addToTopic =
describe "POST /topic/add" $ do post "Add Topic" (topicR <> "add") "Fred"
it "Should return 200 with well formed request" $
pOST "Is super tasty." `shouldRespondWith` "Success"
it "Should 400 on empty input" $ -- AddRq Spec
pOST "" `shouldRespondWith` 400 -- it should return 200 with well formed request
test $ addToTopic >>= assertBody "Success"
-- ViewRq Spec -- it should 400 on empty input
describe "GET /topic/view" $ test $ post "Empty Input" (topicR <> "add") ""
it "Should return 200 with content" $ do >>= assertStatus HTTP.status400
_ <- pOST "Is super tasty."
get ( "/" <> testTopic <> "/view" ) `shouldRespondWith` 200
-- ListRq Spec -- ViewRq Spec
describe "GET /list" $ -- it should return 200 with
it "Should return 200 with content" $ do test $ addToTopic
_ <- pOST "Is super tasty." >> get "View topic" (topicR <> "view")
get "/list" `shouldRespondWith` "[\"fudge\"]" >>= assertStatus HTTP.status200
-- ListRq Spec
test $ addToTopic
>> get "List topics" "/list"
>>= assertBody "[\"fudge\"]"

99
tests/Level07Tests.hs
View File

@ -4,24 +4,30 @@ module Level07Tests
, doctests , doctests
) where ) where
import Control.Monad.Reader (ask, reader) import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader (ask, reader)
import Control.Monad (join) import Control.Monad (join)
import Data.Monoid ((<>)) import Data.Foldable (traverse_)
import Data.String (IsString) import Data.Monoid ((<>))
import Data.String (IsString)
import Test.Hspec import Test.Hspec
import Test.Hspec.Wai
import qualified System.Exit as Exit import Network.HTTP.Types as HTTP
import Level07.AppM (Env) import Helpers (TestM, assertBody, assertStatus, get,
import qualified Level07.AppM as AppM post, runTestsFor)
import qualified Level07.Core as Core import qualified System.Exit as Exit
import qualified Level07.DB as DB
import qualified Level07.Types as Types import Level07.AppM (Env)
import qualified Level07.AppM as AppM
import qualified Level07.Core as Core
import qualified Level07.DB as DB
import qualified Level07.Types as Types
doctests :: [FilePath] doctests :: [FilePath]
doctests = doctests =
@ -40,51 +46,50 @@ unitTests = do
testTopic :: IsString s => s testTopic :: IsString s => s
testTopic = "fudge" testTopic = "fudge"
-- Keeping everything in sync with out larger application changes.
reqsE <- Core.prepareAppReqs reqsE <- Core.prepareAppReqs
case reqsE of case reqsE of
Left err -> dieWith err Left err -> dieWith err
Right e -> runTestsFor (Core.app e) "Level 07 API Tests" $ do
Right env -> do let
let app' = pure ( Core.app env ) flushTopic :: TestM ()
flushTopic = liftIO .
-- Clean up and yell about our errors
(traverse_ (either dieWith pure) =<<) .
-- Include the runner to handle our new 'AppM'
flip AppM.runAppM e .
-- Purge all of the comments for this topic for our tests
traverse DB.deleteTopic
-- We don't export the constructor so even for known values we have
-- to play by the rules. There is no - "Oh just this one time.", do it right.
$ Types.mkTopic "fudge"
flushTopic :: IO () -- Run a test and then flush the db
flushTopic = either dieWith pure =<< AppM.runAppM test t = t >> flushTopic
(AppM.liftEither =<< traverse DB.deleteTopic ( Types.mkTopic testTopic ))
env
-- We can't run the tests for our AppM in the same stage as our topicR = "/fudge/"
-- application, because of the use of the 'with' function. As it expects
-- to be able to execute our tests by applying it to our 'Application'.
hspec $ appMTests env
-- Run the tests with a DB topic flush between each spec addToTopic =
hspec . with ( flushTopic >> app' ) $ do post "Add Topic" (topicR <> "add") "Fred"
-- Save us a bit of repetition -- AddRq Spec
let pOST = post ( "/" <> testTopic <> "/add" ) -- it should return 200 with well formed request
test $ addToTopic >>= assertBody "Success"
-- AddRq Spec -- it should 400 on empty input
describe "POST /topic/add" $ do test $ post "Empty Input" (topicR <> "add") ""
it "Should return 200 with well formed request" $ >>= assertStatus HTTP.status400
pOST "Is super tasty." `shouldRespondWith` "Success"
it "Should 400 on empty input" $ -- ViewRq Spec
pOST "" `shouldRespondWith` 400 -- it should return 200 with
test $ addToTopic
-- ViewRq Spec >> get "View topic" (topicR <> "view")
describe "GET /topic/view" $ >>= assertStatus HTTP.status200
it "Should return 200 with content" $ do
_ <- pOST "Is super tasty."
get ( "/" <> testTopic <> "/view" ) `shouldRespondWith` 200
-- ListRq Spec
describe "GET /list" $
it "Should return 200 with content" $ do
_ <- pOST "Is super tasty."
get "/list" `shouldRespondWith` "[\"fudge\"]"
-- ListRq Spec
test $ addToTopic
>> get "List topics" "/list"
>>= assertBody "[\"fudge\"]"
-- These tests ensure that our AppM will do we want it to, with respect to the -- These tests ensure that our AppM will do we want it to, with respect to the
-- behaviour of 'ask', 'reader', and use in a Monad. -- behaviour of 'ask', 'reader', and use in a Monad.
@ -93,13 +98,13 @@ appMTests env = describe "AppM Tests" $ do
it "ask should retrieve the Env" $ do it "ask should retrieve the Env" $ do
r <- AppM.runAppM ask env r <- AppM.runAppM ask env
( (AppM.envConfig <$> r) == (Right $ AppM.envConfig env) ) `shouldBe` True ( (AppM.envConfig <$> r) == Right (AppM.envConfig env) ) `shouldBe` True
it "reader should run a function on the Env" $ do it "reader should run a function on the Env" $ do
let getDBfilepath = Types.dbFilePath . AppM.envConfig let getDBfilepath = Types.dbFilePath . AppM.envConfig
r <- AppM.runAppM ( reader getDBfilepath ) env r <- AppM.runAppM ( reader getDBfilepath ) env
r `shouldBe` (Right $ getDBfilepath env) r `shouldBe` Right (getDBfilepath env)
it "should let us run IO functions" $ do it "should let us run IO functions" $ do
let fn = do let fn = do