mirror of
https://github.com/qfpl/applied-fp-course.git
synced 2024-11-22 19:34:33 +03:00
Remove the need to explain lawless (and weird) typeclass usage from tests (#64)
* 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
GitHub
parent
14ebd0f803
commit
f1e89235f0
@ -16,6 +16,7 @@ cache:
|
||||
- $HOME/.cabal/store
|
||||
- $HOME/.ghc
|
||||
- $HOME/.stack
|
||||
- $TRAVIS_BUILD_DIR/.stack-work
|
||||
|
||||
before_cache:
|
||||
- rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log
|
||||
|
||||
@ -145,15 +145,23 @@ test-suite app-fp-tests
|
||||
, Level06Tests
|
||||
, Level07Tests
|
||||
|
||||
, Helpers
|
||||
|
||||
build-depends: base >= 4.8 && <4.13
|
||||
, applied-fp-course
|
||||
, wai == 3.2.*
|
||||
, 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-wai >= 0.6 && < 0.10
|
||||
, bytestring == 0.10.*
|
||||
, text == 1.2.*
|
||||
, mtl == 2.2.*
|
||||
, semigroups == 0.18.*
|
||||
, transformers >= 0.4 && < 0.6
|
||||
, mmorph
|
||||
|
||||
test-suite doctests
|
||||
-- Base language which the package is written in.
|
||||
@ -164,6 +172,7 @@ test-suite doctests
|
||||
, Level05Tests
|
||||
, Level06Tests
|
||||
, Level07Tests
|
||||
, Helpers
|
||||
|
||||
ghc-options: -threaded
|
||||
main-is: doctests.hs
|
||||
@ -174,6 +183,15 @@ test-suite doctests
|
||||
, hspec >= 2.2 && < 3.0
|
||||
, hspec-wai >= 0.6 && < 0.10
|
||||
, 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
|
||||
executable level01-exe
|
||||
|
||||
@ -1,7 +1,7 @@
|
||||
{ mkDerivation, aeson, base, bytestring, doctest, hspec, hspec-wai
|
||||
, http-types, mtl, optparse-applicative, semigroups, sqlite-simple
|
||||
, sqlite-simple-errors, stdenv, text, time, transformers, wai
|
||||
, wai-extra, warp
|
||||
, sqlite-simple-errors, stdenv, tasty, tasty-hunit, text, time
|
||||
, transformers, wai, wai-extra, warp, mmorph
|
||||
}:
|
||||
mkDerivation {
|
||||
pname = "applied-fp-course";
|
||||
@ -16,7 +16,8 @@ mkDerivation {
|
||||
];
|
||||
executableHaskellDepends = [ base ];
|
||||
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";
|
||||
license = stdenv.lib.licenses.bsd3;
|
||||
|
||||
118
tests/Helpers.hs
Normal file
118
tests/Helpers.hs
Normal 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
|
||||
@ -3,49 +3,32 @@ module Level03Tests
|
||||
( unitTests
|
||||
) where
|
||||
|
||||
import Test.Hspec
|
||||
import Test.Hspec.Wai
|
||||
import Test.Tasty (defaultMain, testGroup)
|
||||
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 = do
|
||||
-- We need to setup our Application.
|
||||
let app' = pure Core.app
|
||||
unitTests = runTestsFor Core.app "Level 03 Tests" $ do
|
||||
-- Using the functions from ``Helpers`` this actions a GET request on the
|
||||
-- "/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
|
||||
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.
|
||||
-- Write some more tests, below are some ideas to get you started:
|
||||
|
||||
-- There String literal here is being converted by the use of the
|
||||
-- ``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"
|
||||
-- Don't worry if you don't get all of these done. :)
|
||||
|
||||
-- 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. :)
|
||||
|
||||
-- 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!
|
||||
-- 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!
|
||||
|
||||
@ -4,16 +4,22 @@ module Level04Tests
|
||||
, doctests
|
||||
) where
|
||||
|
||||
import Control.Monad (join)
|
||||
import Control.Monad (join)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
|
||||
import Test.Hspec
|
||||
import Test.Hspec.Wai
|
||||
import qualified System.Exit as Exit
|
||||
|
||||
import qualified System.Exit as Exit
|
||||
import Data.Foldable (traverse_)
|
||||
import Data.Semigroup ((<>))
|
||||
|
||||
import qualified Level04.Core as Core
|
||||
import qualified Level04.DB as DB
|
||||
import qualified Level04.Types as Types
|
||||
import Network.HTTP.Types as HTTP
|
||||
|
||||
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
|
||||
-- tests won't be run.
|
||||
@ -26,47 +32,50 @@ doctests =
|
||||
, "src/Level04/Types.hs"
|
||||
]
|
||||
|
||||
dieWith :: Show a => a -> IO ()
|
||||
dieWith err = print err >> Exit.exitFailure
|
||||
|
||||
unitTests :: IO ()
|
||||
unitTests = do
|
||||
let dieWith m = print m >> Exit.exitFailure
|
||||
|
||||
reqsE <- Core.prepareAppReqs
|
||||
case reqsE of
|
||||
|
||||
reqE <- Core.prepareAppReqs
|
||||
case reqE of
|
||||
Left err -> dieWith err
|
||||
Right db -> runTestsFor (Core.app db) "Level 04 Tests" $ do
|
||||
|
||||
Right db -> do
|
||||
let app' = pure ( Core.app db )
|
||||
let
|
||||
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 =
|
||||
-- Clean up and yell about our errors
|
||||
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 a test and then flush the db
|
||||
test t = t >> flushTopic
|
||||
|
||||
-- Run the tests with a DB topic flush between each spec
|
||||
hspec . with ( flushTopic >> app' ) $ do
|
||||
topicR = "/fudge/"
|
||||
|
||||
-- AddRq Spec
|
||||
describe "POST /topic/add" $ do
|
||||
addToTopic =
|
||||
post "Add Topic" (topicR <> "add") "Fred"
|
||||
|
||||
it "Should return 200 with well formed request" $ do
|
||||
post "/fudge/add" "Fred" `shouldRespondWith` "Success"
|
||||
-- AddRq Spec
|
||||
-- it should return 200 with well formed request
|
||||
test $ addToTopic >>= assertBody "Success"
|
||||
|
||||
it "Should 400 on empty input" $
|
||||
post "/fudge/add" "" `shouldRespondWith` 400
|
||||
-- it should 400 on empty input
|
||||
test $ post "Empty Input" (topicR <> "add") ""
|
||||
>>= assertStatus HTTP.status400
|
||||
|
||||
-- ViewRq Spec
|
||||
describe "GET /topic/view" $ do
|
||||
it "Should return 200 with content" $ do
|
||||
post "/fudge/add" "Is super tasty."
|
||||
get "/fudge/view" `shouldRespondWith` 200
|
||||
-- ViewRq Spec
|
||||
-- it should return 200 with
|
||||
test $ addToTopic
|
||||
>> get "View topic" (topicR <> "view")
|
||||
>>= assertStatus HTTP.status200
|
||||
|
||||
-- ListRq Spec
|
||||
describe "GET /list" $ do
|
||||
it "Should return 200 with content" $ do
|
||||
post "/fudge/add" "Is super tasty."
|
||||
get "/list" `shouldRespondWith` "[\"fudge\"]"
|
||||
-- ListRq Spec
|
||||
test $ addToTopic
|
||||
>> get "List topics" "/list"
|
||||
>>= assertBody "[\"fudge\"]"
|
||||
|
||||
@ -4,22 +4,28 @@ module Level05Tests
|
||||
, doctests
|
||||
) 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.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.DB as DB
|
||||
import qualified Level05.Types as Types
|
||||
import qualified Level05.AppM as AppM
|
||||
|
||||
import qualified Level05.Core as Core
|
||||
import qualified Level05.DB as DB
|
||||
import qualified Level05.Types as Types
|
||||
|
||||
doctests :: [FilePath]
|
||||
doctests =
|
||||
@ -43,43 +49,45 @@ unitTests = do
|
||||
|
||||
reqsE <- Core.prepareAppReqs
|
||||
case reqsE of
|
||||
|
||||
Left err -> dieWith err
|
||||
Right db -> runTestsFor (Core.app db) "Level 05 Tests" $ do
|
||||
|
||||
Right db -> do
|
||||
let app' = pure (Core.app db)
|
||||
let
|
||||
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 =
|
||||
-- Clean up and yell about our errors
|
||||
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 a test and then flush the db
|
||||
test t = t >> flushTopic
|
||||
|
||||
-- Run the tests with a DB topic flush between each spec
|
||||
hspec . with ( flushTopic >> app' ) $ do
|
||||
-- Save us a bit of repetition
|
||||
let pOST = post ( "/" <> testTopic <> "/add" )
|
||||
topicR = "/fudge/"
|
||||
|
||||
-- AddRq Spec
|
||||
describe "POST /topic/add" $ do
|
||||
it "Should return 200 with well formed request" $
|
||||
pOST "Is super tasty." `shouldRespondWith` "Success"
|
||||
addToTopic =
|
||||
post "Add Topic" (topicR <> "add") "Fred"
|
||||
|
||||
it "Should 400 on empty input" $
|
||||
pOST "" `shouldRespondWith` 400
|
||||
-- AddRq Spec
|
||||
-- it should return 200 with well formed request
|
||||
test $ addToTopic >>= assertBody "Success"
|
||||
|
||||
-- ViewRq Spec
|
||||
describe "GET /topic/view" $
|
||||
it "Should return 200 with content" $ do
|
||||
_ <- pOST "Is super tasty."
|
||||
get ( "/" <> testTopic <> "/view" ) `shouldRespondWith` 200
|
||||
-- it should 400 on empty input
|
||||
test $ post "Empty Input" (topicR <> "add") ""
|
||||
>>= assertStatus HTTP.status400
|
||||
|
||||
-- ListRq Spec
|
||||
describe "GET /list" $
|
||||
it "Should return 200 with content" $ do
|
||||
_ <- pOST "Is super tasty."
|
||||
get "/list" `shouldRespondWith` "[\"fudge\"]"
|
||||
-- ViewRq Spec
|
||||
-- it should return 200 with
|
||||
test $ addToTopic
|
||||
>> get "View topic" (topicR <> "view")
|
||||
>>= assertStatus HTTP.status200
|
||||
|
||||
-- ListRq Spec
|
||||
test $ addToTopic
|
||||
>> get "List topics" "/list"
|
||||
>>= assertBody "[\"fudge\"]"
|
||||
|
||||
@ -4,20 +4,26 @@ module Level06Tests
|
||||
, unitTests
|
||||
) where
|
||||
|
||||
import Control.Monad (join)
|
||||
import Control.Monad (join)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
|
||||
import Data.Monoid ((<>))
|
||||
import Data.String (IsString)
|
||||
import Data.Foldable (traverse_)
|
||||
import Data.Monoid ((<>))
|
||||
import Data.String (IsString)
|
||||
|
||||
import Network.HTTP.Types as HTTP
|
||||
|
||||
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 Level06.Core as Core
|
||||
import qualified Level06.DB as DB
|
||||
import qualified Level06.Types as Types
|
||||
import qualified System.Exit as Exit
|
||||
|
||||
import qualified Level06.AppM as AppM
|
||||
import qualified Level06.Core as Core
|
||||
import qualified Level06.DB as DB
|
||||
import qualified Level06.Types as Types
|
||||
|
||||
doctests :: [FilePath]
|
||||
doctests =
|
||||
@ -38,37 +44,45 @@ unitTests = do
|
||||
|
||||
reqsE <- Core.prepareAppReqs
|
||||
case reqsE of
|
||||
|
||||
Left err -> dieWith err
|
||||
Right (cfg, db) -> runTestsFor (Core.app cfg db) "Level 06 Tests" $ do
|
||||
|
||||
Right ( cfg, db ) -> do
|
||||
let app' = pure (Core.app cfg db)
|
||||
let
|
||||
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 ()
|
||||
flushTopic = either dieWith pure =<< AppM.runAppM
|
||||
(AppM.liftEither (Types.mkTopic testTopic) >>= DB.deleteTopic db)
|
||||
-- Run a test and then flush the db
|
||||
test t = t >> flushTopic
|
||||
|
||||
-- Run the tests with a DB topic flush between each spec
|
||||
hspec . with ( flushTopic >> app' ) $ do
|
||||
-- Save us a bit of repetition
|
||||
let pOST = post ( "/" <> testTopic <> "/add" )
|
||||
topicR = "/fudge/"
|
||||
|
||||
-- AddRq Spec
|
||||
describe "POST /topic/add" $ do
|
||||
it "Should return 200 with well formed request" $
|
||||
pOST "Is super tasty." `shouldRespondWith` "Success"
|
||||
addToTopic =
|
||||
post "Add Topic" (topicR <> "add") "Fred"
|
||||
|
||||
it "Should 400 on empty input" $
|
||||
pOST "" `shouldRespondWith` 400
|
||||
-- AddRq Spec
|
||||
-- it should return 200 with well formed request
|
||||
test $ addToTopic >>= assertBody "Success"
|
||||
|
||||
-- ViewRq Spec
|
||||
describe "GET /topic/view" $
|
||||
it "Should return 200 with content" $ do
|
||||
_ <- pOST "Is super tasty."
|
||||
get ( "/" <> testTopic <> "/view" ) `shouldRespondWith` 200
|
||||
-- it should 400 on empty input
|
||||
test $ post "Empty Input" (topicR <> "add") ""
|
||||
>>= assertStatus HTTP.status400
|
||||
|
||||
-- ListRq Spec
|
||||
describe "GET /list" $
|
||||
it "Should return 200 with content" $ do
|
||||
_ <- pOST "Is super tasty."
|
||||
get "/list" `shouldRespondWith` "[\"fudge\"]"
|
||||
-- ViewRq Spec
|
||||
-- it should return 200 with
|
||||
test $ addToTopic
|
||||
>> get "View topic" (topicR <> "view")
|
||||
>>= assertStatus HTTP.status200
|
||||
|
||||
-- ListRq Spec
|
||||
test $ addToTopic
|
||||
>> get "List topics" "/list"
|
||||
>>= assertBody "[\"fudge\"]"
|
||||
|
||||
@ -4,24 +4,30 @@ module Level07Tests
|
||||
, doctests
|
||||
) 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.String (IsString)
|
||||
import Data.Foldable (traverse_)
|
||||
import Data.Monoid ((<>))
|
||||
import Data.String (IsString)
|
||||
|
||||
import Test.Hspec
|
||||
import Test.Hspec.Wai
|
||||
|
||||
import qualified System.Exit as Exit
|
||||
import Network.HTTP.Types as HTTP
|
||||
|
||||
import Level07.AppM (Env)
|
||||
import qualified Level07.AppM as AppM
|
||||
import Helpers (TestM, assertBody, assertStatus, get,
|
||||
post, runTestsFor)
|
||||
|
||||
import qualified Level07.Core as Core
|
||||
import qualified Level07.DB as DB
|
||||
import qualified Level07.Types as Types
|
||||
import qualified System.Exit as Exit
|
||||
|
||||
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 =
|
||||
@ -40,51 +46,50 @@ unitTests = do
|
||||
testTopic :: IsString s => s
|
||||
testTopic = "fudge"
|
||||
|
||||
-- Keeping everything in sync with out larger application changes.
|
||||
reqsE <- Core.prepareAppReqs
|
||||
case reqsE of
|
||||
|
||||
Left err -> dieWith err
|
||||
Right e -> runTestsFor (Core.app e) "Level 07 API Tests" $ do
|
||||
|
||||
Right env -> do
|
||||
let app' = pure ( Core.app env )
|
||||
let
|
||||
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 ()
|
||||
flushTopic = either dieWith pure =<< AppM.runAppM
|
||||
(AppM.liftEither =<< traverse DB.deleteTopic ( Types.mkTopic testTopic ))
|
||||
env
|
||||
-- Run a test and then flush the db
|
||||
test t = t >> flushTopic
|
||||
|
||||
-- We can't run the tests for our AppM in the same stage as our
|
||||
-- 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
|
||||
topicR = "/fudge/"
|
||||
|
||||
-- Run the tests with a DB topic flush between each spec
|
||||
hspec . with ( flushTopic >> app' ) $ do
|
||||
addToTopic =
|
||||
post "Add Topic" (topicR <> "add") "Fred"
|
||||
|
||||
-- Save us a bit of repetition
|
||||
let pOST = post ( "/" <> testTopic <> "/add" )
|
||||
-- AddRq Spec
|
||||
-- it should return 200 with well formed request
|
||||
test $ addToTopic >>= assertBody "Success"
|
||||
|
||||
-- AddRq Spec
|
||||
describe "POST /topic/add" $ do
|
||||
it "Should return 200 with well formed request" $
|
||||
pOST "Is super tasty." `shouldRespondWith` "Success"
|
||||
-- it should 400 on empty input
|
||||
test $ post "Empty Input" (topicR <> "add") ""
|
||||
>>= assertStatus HTTP.status400
|
||||
|
||||
it "Should 400 on empty input" $
|
||||
pOST "" `shouldRespondWith` 400
|
||||
|
||||
-- ViewRq Spec
|
||||
describe "GET /topic/view" $
|
||||
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\"]"
|
||||
-- ViewRq Spec
|
||||
-- it should return 200 with
|
||||
test $ addToTopic
|
||||
>> get "View topic" (topicR <> "view")
|
||||
>>= assertStatus HTTP.status200
|
||||
|
||||
-- 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
|
||||
-- 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
|
||||
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
|
||||
let getDBfilepath = Types.dbFilePath . AppM.envConfig
|
||||
|
||||
r <- AppM.runAppM ( reader getDBfilepath ) env
|
||||
r `shouldBe` (Right $ getDBfilepath env)
|
||||
r `shouldBe` Right (getDBfilepath env)
|
||||
|
||||
it "should let us run IO functions" $ do
|
||||
let fn = do
|
||||
|
||||
Loading…
Reference in New Issue
Block a user