qfpl/applied-fp-course
1
1
Fork 0
mirror of https://github.com/qfpl/applied-fp-course.git synced 2024-11-22 19:34:33 +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/.ghc
- $HOME/.stack
- $TRAVIS_BUILD_DIR/.stack-work
before_cache:
- 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
, 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

7
applied-fp-course.nix
View File

@ -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
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

43
tests/Level03Tests.hs
View File

@ -3,40 +3,23 @@ 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 qualified Data.ByteString.Lazy.Char8 as LBS8
import Helpers (assertBody, assertStatus, get, runTestsFor)
import qualified Level03.Core as Core
unitTests :: IO ()
unitTests = do
-- We need to setup our Application.
let app' = pure Core.app
-- 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.
-- 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"
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
-- Write some more tests, below are some ideas to get you started:
@ -47,5 +30,5 @@ unitTests = do
-- 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!

67
tests/Level04Tests.hs
View File

@ -5,12 +5,18 @@ module Level04Tests
) where
import Control.Monad (join)
import Test.Hspec
import Test.Hspec.Wai
import Control.Monad.IO.Class (liftIO)
import qualified System.Exit as Exit
import Data.Foldable (traverse_)
import Data.Semigroup ((<>))
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
@ -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 )
flushTopic =
let
flushTopic :: TestM ()
flushTopic = liftIO .
-- Clean up and yell about our errors
fmap ( either dieWith pure . join ) .
(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"
-- Run the tests with a DB topic flush between each spec
hspec . with ( flushTopic >> app' ) $ do
-- Run a test and then flush the db
test t = t >> flushTopic
topicR = "/fudge/"
addToTopic =
post "Add Topic" (topicR <> "add") "Fred"
-- AddRq Spec
describe "POST /topic/add" $ do
-- it should return 200 with well formed request
test $ addToTopic >>= assertBody "Success"
it "Should return 200 with well formed request" $ do
post "/fudge/add" "Fred" `shouldRespondWith` "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
-- 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\"]"
test $ addToTopic
>> get "List topics" "/list"
>>= assertBody "[\"fudge\"]"

64
tests/Level05Tests.hs
View File

@ -4,14 +4,20 @@ module Level05Tests
, doctests
) where
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader (ask, reader)
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 Helpers (TestM, assertBody, assertStatus, get,
post, runTestsFor)
import qualified System.Exit as Exit
@ -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)
flushTopic =
let
flushTopic :: TestM ()
flushTopic = liftIO .
-- Clean up and yell about our errors
either dieWith pure =<< AppM.runAppM (
(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.
AppM.liftEither (Types.mkTopic testTopic)
-- Purge all of the comments for this topic for our tests
>>= DB.deleteTopic db
)
$ Types.mkTopic "fudge"
-- 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" )
-- Run a test and then flush the db
test t = t >> flushTopic
topicR = "/fudge/"
addToTopic =
post "Add Topic" (topicR <> "add") "Fred"
-- AddRq Spec
describe "POST /topic/add" $ do
it "Should return 200 with well formed request" $
pOST "Is super tasty." `shouldRespondWith` "Success"
-- it should return 200 with well formed request
test $ addToTopic >>= assertBody "Success"
it "Should 400 on empty input" $
pOST "" `shouldRespondWith` 400
-- it should 400 on empty input
test $ post "Empty Input" (topicR <> "add") ""
>>= assertStatus HTTP.status400
-- ViewRq Spec
describe "GET /topic/view" $
it "Should return 200 with content" $ do
_ <- pOST "Is super tasty."
get ( "/" <> testTopic <> "/view" ) `shouldRespondWith` 200
-- it should return 200 with
test $ addToTopic
>> get "View topic" (topicR <> "view")
>>= assertStatus HTTP.status200
-- ListRq Spec
describe "GET /list" $
it "Should return 200 with content" $ do
_ <- pOST "Is super tasty."
get "/list" `shouldRespondWith` "[\"fudge\"]"
test $ addToTopic
>> get "List topics" "/list"
>>= assertBody "[\"fudge\"]"

62
tests/Level06Tests.hs
View File

@ -5,12 +5,18 @@ module Level06Tests
) where
import Control.Monad (join)
import Control.Monad.IO.Class (liftIO)
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 Helpers (TestM, assertBody, assertStatus, get,
post, runTestsFor)
import qualified System.Exit as Exit
@ -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/"
addToTopic =
post "Add Topic" (topicR <> "add") "Fred"
-- AddRq Spec
describe "POST /topic/add" $ do
it "Should return 200 with well formed request" $
pOST "Is super tasty." `shouldRespondWith` "Success"
-- it should return 200 with well formed request
test $ addToTopic >>= assertBody "Success"
it "Should 400 on empty input" $
pOST "" `shouldRespondWith` 400
-- it should 400 on empty input
test $ post "Empty Input" (topicR <> "add") ""
>>= assertStatus HTTP.status400
-- ViewRq Spec
describe "GET /topic/view" $
it "Should return 200 with content" $ do
_ <- pOST "Is super tasty."
get ( "/" <> testTopic <> "/view" ) `shouldRespondWith` 200
-- it should return 200 with
test $ addToTopic
>> get "View topic" (topicR <> "view")
>>= assertStatus HTTP.status200
-- ListRq Spec
describe "GET /list" $
it "Should return 200 with content" $ do
_ <- pOST "Is super tasty."
get "/list" `shouldRespondWith` "[\"fudge\"]"
test $ addToTopic
>> get "List topics" "/list"
>>= assertBody "[\"fudge\"]"

73
tests/Level07Tests.hs
View File

@ -4,15 +4,21 @@ module Level07Tests
, doctests
) where
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader (ask, reader)
import Control.Monad (join)
import Data.Foldable (traverse_)
import Data.Monoid ((<>))
import Data.String (IsString)
import Test.Hspec
import Test.Hspec.Wai
import Network.HTTP.Types as HTTP
import Helpers (TestM, assertBody, assertStatus, get,
post, runTestsFor)
import qualified System.Exit as Exit
@ -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
-- Save us a bit of repetition
let pOST = post ( "/" <> testTopic <> "/add" )
addToTopic =
post "Add Topic" (topicR <> "add") "Fred"
-- AddRq Spec
describe "POST /topic/add" $ do
it "Should return 200 with well formed request" $
pOST "Is super tasty." `shouldRespondWith` "Success"
-- it should return 200 with well formed request
test $ addToTopic >>= assertBody "Success"
it "Should 400 on empty input" $
pOST "" `shouldRespondWith` 400
-- it should 400 on empty input
test $ post "Empty Input" (topicR <> "add") ""
>>= assertStatus HTTP.status400
-- ViewRq Spec
describe "GET /topic/view" $
it "Should return 200 with content" $ do
_ <- pOST "Is super tasty."
get ( "/" <> testTopic <> "/view" ) `shouldRespondWith` 200
-- it should return 200 with
test $ addToTopic
>> get "View topic" (topicR <> "view")
>>= assertStatus HTTP.status200
-- ListRq Spec
describe "GET /list" $
it "Should return 200 with content" $ do
_ <- pOST "Is super tasty."
get "/list" `shouldRespondWith` "[\"fudge\"]"
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