snap-testing 0.4.1.1 → 0.6.0.0
raw patch · 4 files changed
+413/−225 lines, 4 filesdep +HandsomeSoupdep +hxtdep +lensdep ~basedep ~digestive-functorsdep ~process
Dependencies added: HandsomeSoup, hxt, lens, snap-testing
Dependency ranges changed: base, digestive-functors, process, snap, text
Files
- CHANGELOG +12/−0
- snap-testing.cabal +32/−8
- src/Snap/Test/BDD.hs +248/−217
- test/Main.hs +121/−0
CHANGELOG view
@@ -1,3 +1,15 @@+0.6.0.0 - 2014-7-8 - Add additional helpers, and use much faster method of running tests.+ * The biggest change is because of a patch to snap that allows us to only run the+ initializer once for an entire test suite, which can easily be an order of+ magnitude (or more) speedup.+ * Also add a test-suite to the library.++0.5.0.0 - Not released to hackage - Redesign library around richer types and Applicative.+ * Basic building block is should/shouldNot, which lift a pure test function+ into the SnapTesting monad.+ * get / post create rich response type.+ * Add html / css matcher predicates.+ 0.4.1.1 - 2014-3-20 - Add this changelog to hackage, grammar in comments. 0.4.1.0 - 2014-3-20 - Add form tests, assert.
snap-testing.cabal view
@@ -1,5 +1,5 @@ name: snap-testing-version: 0.4.1.1+version: 0.6.0.0 synopsis: A library for BDD-style testing with the Snap Web Framework homepage: https://github.com/dbp/snap-testing license: BSD3@@ -15,17 +15,41 @@ exposed-modules: Snap.Test.BDD hs-source-dirs: src- -- other-modules:- build-depends: base ==4.6.*,+ build-depends: base >= 4.6 && < 4.8, QuickCheck == 2.*,- snap == 0.13.*,- snap-core == 0.9.*,+ snap >= 0.13.2.8 && < 0.14,+ snap-core >= 0.9 && < 0.10, mtl >= 2 && < 3, transformers == 0.3.*,- text == 0.11.*,+ text >= 0.11 && < 1.2, bytestring >= 0.9.1 && < 0.11, containers == 0.5.*,- process == 1.1.*,+ process >= 1.1 && < 1.3, io-streams == 1.*, async == 2.*,- digestive-functors+ digestive-functors == 0.7.*,+ hxt == 9.*,+ HandsomeSoup == 0.3.*+++Test-Suite test-snap-testing+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Main.hs+ build-depends: base >= 4.6 && < 4.8,+ QuickCheck == 2.*,+ snap >= 0.13.2.8 && < 0.14,+ snap-core >= 0.9 && < 0.10,+ lens >= 3 && < 5,+ mtl >= 2 && < 3,+ transformers == 0.3.*,+ text >= 0.11 && < 1.2,+ bytestring >= 0.9.1 && < 0.11,+ containers == 0.5.*,+ process >= 1.1 && < 1.3,+ io-streams == 1.*,+ async == 2.*,+ digestive-functors == 0.7.*,+ hxt == 9.*,+ HandsomeSoup == 0.3.*+ build-depends: snap-testing >= 0.6
src/Snap/Test/BDD.hs view
@@ -4,8 +4,9 @@ ( -- * Types SnapTesting- , TestRequest- , TestLog(..)+ , TestResult(..)+ , Sentiment(..)+ , TestResponse(..) , SnapTestingConfig (..) -- * Configuration@@ -19,36 +20,43 @@ -- * Labeling , name - -- * Creating Requests+ -- * Applying Predicates+ , should+ , shouldNot++ -- * Helpers for running tests+ , css+ , val++ -- * Getting Responses , get , get' , post , params - -- * Request predicates- , succeeds+ -- * Predicates on values+ , equal+ , beTrue++ -- * Predicates on Responses+ , succeed , notfound- , redirects- , redirectsto+ , redirect+ , redirectTo+ , haveText+ , haveSelector++ -- * Stateful value tests , changes- , changes'- , contains- , notcontains - -- * Form tests+ -- * Stateful form tests , FormExpectations(..) , form - -- * Stateful unit tests- , equals-- -- * Pure unit tests- , assert- -- * Run actions after block , cleanup - -- * Evaluate arbitrary action+ -- * Evaluating arbitrary actions , eval -- * Create helpers@@ -58,48 +66,81 @@ , quickCheck ) where -import Prelude hiding (FilePath)-import Data.Map (Map, fromList)-import Data.ByteString (ByteString, isInfixOf)+import Prelude hiding (FilePath, log)+import Data.Map (Map)+import qualified Data.Map as M (lookup, mapKeys, empty, fromList)+import Data.ByteString (ByteString) import Data.Text (Text, pack, unpack)-import qualified Data.Text as T (append)-import Data.Text.Encoding (encodeUtf8)-import Data.Monoid (mempty)+import qualified Data.Text as T (append, concat, isInfixOf)+import Data.Text.Encoding (encodeUtf8, decodeUtf8) import Data.Maybe (fromMaybe)-import qualified Data.Map as M (lookup, mapKeys)+import Data.List (intercalate, intersperse)++import Control.Applicative import Control.Monad (void) import Control.Monad.Trans import Control.Monad.Trans.State (StateT, evalStateT) import qualified Control.Monad.Trans.State as S (get, put) import Control.Exception (SomeException, catch)+import Control.Concurrent.Async import System.Process (system)+ import Snap.Core (Response(..), getHeader)-import Snap.Snaplet (Handler, SnapletInit)+import Snap.Snaplet (Handler, SnapletInit, Snaplet) import Snap.Test (RequestBuilder, getResponseBody) import qualified Snap.Test as Test-import Snap.Snaplet.Test (runHandler, evalHandler)+import Snap.Snaplet.Test (runHandler', evalHandler', getSnaplet+ , closeSnaplet, InitializerState) import Test.QuickCheck (Args(..), Result(..), Testable, quickCheckWithResult, stdArgs)+ import System.IO.Streams (InputStream, OutputStream)-import qualified System.IO.Streams as S-import qualified System.IO.Streams.Concurrent as S-import Control.Concurrent.Async+import qualified System.IO.Streams as Stream+import qualified System.IO.Streams.Concurrent as Stream+ import qualified Text.Digestive as DF+import qualified Text.HandsomeSoup as HS+import qualified Text.XML.HXT.Core as HXT -- | The main type for this library, where `b` is your application state, -- often called `App`. This is a State monad on top of IO, where the State carries -- your application (or, more specifically, a top-level handler), and stream of test results -- to be reported as passing or failing.-type SnapTesting b a = StateT (Handler b b (), SnapletInit b b, OutputStream TestLog) IO a+type SnapTesting b a = StateT (Handler b b ()+ , (Snaplet b, InitializerState b)+ , OutputStream TestResult) IO a --- | TestRequests are created with `get` and `post`.-type TestRequest = RequestBuilder IO ()+-- | A TestResponse is the result of making a request. Many predicates operate on these types of+-- responses, and custom predicates can be written against them.+data TestResponse = Html Text | NotFound | Redirect Int Text | Other Int | Empty --- | TestLog is what is streamed to report generators. It is a flatten tree structure.-data TestLog = NameStart Text | NameEnd | TestPass Text | TestFail Text | TestError Text deriving Show+data CssSelector = CssSelector Text -data SnapTestingConfig = SnapTestingConfig { reportGenerators :: [InputStream TestLog -> IO ()]+-- | Tests have messages that are agnostic to whether the result should hold or should not hold.+-- The sentiment is attached to them to indicate that positive/negative statement. This allows+-- the same message to be used for tests asserted with `should` and `shouldNot`.+data Sentiment a = Positive a | Negative a deriving Show++flipSentiment :: Sentiment a -> Sentiment a+flipSentiment (Positive a) = Negative a+flipSentiment (Negative a) = Positive a+++-- | TestResult is a a flattened tree structure that reflects the structure of your tests,+-- and is the data that is passed to report generators.+data TestResult = NameStart Text+ | NameEnd+ | TestPass (Sentiment Text)+ | TestFail (Sentiment Text)+ | TestError Text deriving Show++-- | The configuration that is passed to the test runner, currently just a list of report+-- generators, that are each passed a stream of results, and can do any side effecting thing+-- with them.+data SnapTestingConfig = SnapTestingConfig { reportGenerators :: [InputStream TestResult -> IO ()] } ++-- | The default configuration just prints results to the console, using the `consoleReport`. defaultConfig :: SnapTestingConfig defaultConfig = SnapTestingConfig { reportGenerators = [consoleReport] }@@ -107,9 +148,9 @@ -- | dupN duplicates an input stream N times dupN :: Int -> InputStream a -> IO [InputStream a]-dupN 0 s = return []+dupN 0 _ = return [] dupN 1 s = return [s]-dupN n s = do (a, b) <- S.map (\x -> (x,x)) s >>= S.unzip+dupN n s = do (a, b) <- Stream.map (\x -> (x,x)) s >>= Stream.unzip rest <- dupN (n - 1) b return (a:rest) @@ -120,14 +161,19 @@ -> SnapTesting b () -- ^ Block of tests -> IO () runSnapTests conf site app tests = do- (inp, out) <- S.makeChanPipe+ (inp, out) <- Stream.makeChanPipe let rgs = reportGenerators conf istreams <- dupN (length rgs) inp- consumers <- mapM (\(inp, hndl) -> async (hndl inp)) (zip istreams rgs)- evalStateT tests (site, app, out)- S.write Nothing out- mapM_ wait consumers- return ()+ consumers <- mapM (\(inp', hndl) -> async (hndl inp')) (zip istreams rgs)+ init <- getSnaplet (Just "test") app+ case init of+ Left err -> error $ show err+ Right (snaplet, initstate) -> do+ evalStateT tests (site, (snaplet, initstate), out)+ Stream.write Nothing out+ mapM_ wait consumers+ closeSnaplet initstate+ return () -- | Prints test results to the console. For example:@@ -135,11 +181,11 @@ -- > /auth/new_user -- > success PASSED -- > creates a new account PASSED-consoleReport :: InputStream TestLog -> IO ()+consoleReport :: InputStream TestResult -> IO () consoleReport stream = cr 0- where cr indent = do log <- S.read stream+ where cr indent = do log <- Stream.read stream case log of- Nothing -> return ()+ Nothing -> putStrLn "" >> return () Just (NameStart n) -> do putStrLn "" printIndent indent putStr (unpack n)@@ -147,87 +193,159 @@ Just NameEnd -> cr (indent - indentUnit) Just (TestPass _) -> do putStr " PASSED" cr indent- Just (TestFail _) -> do putStr " FAILED"- cr indent+ Just (TestFail msg) -> do putStr " FAILED\n"+ printMessage indent msg+ cr indent Just (TestError msg) -> do putStr " ERROR(" putStr (unpack msg) putStr ")" cr indent indentUnit = 2 printIndent n = putStr (replicate n ' ')-+ printMessage n (Positive m) = do printIndent n+ putStrLn "Should have held:"+ printIndent n+ putStrLn (unpack m)+ printMessage n (Negative m) = do printIndent n+ putStrLn "Should not have held:"+ printIndent n+ putStrLn (unpack m) -- | Sends the test results to desktop notifications on linux. -- Prints how many tests passed and failed.-linuxDesktopReport :: InputStream TestLog -> IO ()+linuxDesktopReport :: InputStream TestResult -> IO () linuxDesktopReport stream = do- res <- S.toList stream- let (passed, total) = count res- case passed == total of- True ->+ res <- Stream.toList stream+ let (failing, total) = count [] res+ case failing of+ [] -> void $ system $ "notify-send -u low -t 2000 'All Tests Passing' 'All " ++ (show total) ++ " tests passed.'"- False ->+ _ -> void $ system $ "notify-send -u normal -t 2000 'Some Tests Failing' '" ++- (show (total - passed)) ++ " out of " ++- (show total) ++ " tests failed.'"- where count [] = (0, 0)- count (TestPass _ : xs) = let (p, t) = count xs- in (1 + p, 1 + t)- count (TestFail _ : xs) = let (p, t) = count xs- in (p, 1 + t)- count (TestError _ : xs) = let (p, t) = count xs- in (p, 1 + t)- count (_ : xs) = count xs+ (show (length failing)) ++ " out of " +++ (show total) ++ " tests failed:\n\n" ++ (intercalate "\n\n" $ reverse failing) ++ "'"+ where count :: [Text] -> [TestResult] -> ([String], Int)+ count _ [] = ([], 0)+ count n (TestPass _ : xs) = let (f, t) = count n xs+ in (f, 1 + t)+ count n (TestFail _ : xs) = let (f, t) = count n xs+ in (f ++ [unpack $ T.concat $ intersperse " > " $ reverse n], 1 + t)+ count n (TestError _ : xs) = let (f, t) = count n xs+ in (f, 1 + t)+ count n (NameStart nm : xs) = count (nm:n) xs+ count n (NameEnd : xs) = count (tail n) xs -writeRes :: TestLog -> SnapTesting b ()+writeRes :: TestResult -> SnapTesting b () writeRes log = do (_,_,out) <- S.get- lift $ S.write (Just log) out+ lift $ Stream.write (Just log) out -- | Labels a block of tests with a descriptive name, to be used in report generation. name :: Text -- ^ Name of block -> SnapTesting b () -- ^ Block of tests -> SnapTesting b () name s a = do- (_,_,out) <- S.get writeRes (NameStart s) a writeRes NameEnd --- | Creates a new GET request.-get :: ByteString -- ^ The url to request.- -> TestRequest-get = flip Test.get mempty+runRequest :: RequestBuilder IO () -> SnapTesting b TestResponse+runRequest req = do+ (site, app, _) <- S.get+ res <- liftIO $ runHandlerSafe req site app+ case res of+ Left err -> do+ writeRes (TestError err)+ return $ Empty+ Right response -> do+ case rspStatus response of+ 404 -> return NotFound+ 200 -> do+ body <- liftIO $ getResponseBody response+ return $ Html $ decodeUtf8 body+ _ -> if (rspStatus response) >= 300 && (rspStatus response) < 400+ then do let url = fromMaybe "" $ getHeader "Location" response+ return (Redirect (rspStatus response) (decodeUtf8 url))+ else return (Other (rspStatus response)) --- | Creates a new GET request, with query parameters.-get' :: ByteString -- ^ The url to request.+-- | Runs a GET request+get :: Text -- ^ The url to request.+ -> SnapTesting b TestResponse+get = flip get' M.empty+++-- | Runs a GET request, with a set of parameters.+get' :: Text -- ^ The url to request. -> Map ByteString [ByteString] -- ^ The parameters to send.- -> TestRequest-get' = Test.get+ -> SnapTesting b TestResponse+get' path ps = runRequest (Test.get (encodeUtf8 path) ps) + -- | Creates a new POST request, with a set of parameters.-post :: ByteString -- ^ The url to request.+post :: Text -- ^ The url to request. -> Map ByteString [ByteString] -- ^ The parameters to send.- -> TestRequest-post = Test.postUrlEncoded+ -> SnapTesting b TestResponse+post path ps = runRequest (Test.postUrlEncoded (encodeUtf8 path) ps) -- | A helper to construct parameters. params :: [(ByteString, ByteString)] -- ^ Pairs of parameter and value. -> Map ByteString [ByteString]-params = fromList . map (\x -> (fst x, [snd x]))+params = M.fromList . map (\x -> (fst x, [snd x])) +-- | Constructor for CSS selectors+css :: Applicative m => Text -> m CssSelector+css = pure . CssSelector++-- | A constructor for pure values (this is just a synonym for `pure` from `Applicative`).+val :: Applicative m => a -> m a+val = pure++-- | This takes a TestResult and writes it to the test log, so it is processed+-- by the report generators.+should :: SnapTesting b TestResult -> SnapTesting b ()+should test = do res <- test+ writeRes res++-- | This is similar to `should`, but it asserts that the test should fail, and+-- inverts the corresponding message sentiment.+shouldNot :: SnapTesting b TestResult -> SnapTesting b ()+shouldNot test = do res <- test+ case res of+ TestPass msg -> writeRes (TestFail (flipSentiment msg))+ TestFail msg -> writeRes (TestPass (flipSentiment msg))+ _ -> writeRes res++-- | Assert that a response (which should be Html) has a given selector.+haveSelector :: TestResponse -> CssSelector -> TestResult+haveSelector (Html body) (CssSelector selector) = case HXT.runLA (HXT.hread HXT.>>> HS.css (unpack selector)) (unpack body) of+ [] -> TestFail msg+ _ -> TestPass msg+ where msg = (Positive $ T.concat ["Html contains selector: ", selector, "\n\n", body])+haveSelector _ (CssSelector match) = TestFail (Positive (T.concat ["Body contains css selector: ", match]))++-- | Asserts that a response (which should be Html) has given text.+haveText :: TestResponse -> Text -> TestResult+haveText (Html body) match =+ if T.isInfixOf match body+ then TestPass (Positive $ T.concat [body, "' contains '", match, "'."])++ else TestFail (Positive $ T.concat [body, "' contains '", match, "'."])+haveText _ match = TestFail (Positive (T.concat ["Body contains: ", match]))++ -- | Checks that the handler evaluates to the given value.-equals :: (Show a, Eq a) => a -- ^ Value to compare against- -> Handler b b a -- ^ Handler that should evaluate to the same thing- -> SnapTesting b ()-equals a ha = do- b <- eval ha- res <- testEqual "Expected value to equal " a b- writeRes res+equal :: (Show a, Eq a)+ => a+ -> a+ -> TestResult+equal a b = if a == b+ then TestPass (Positive (T.concat [pack $ show a, " == ", pack $ show b]))+ else TestFail (Positive (T.concat [pack $ show a, " == ", pack $ show b])) -- | Helper to bring the results of other tests into the test suite.-assert :: Bool -> SnapTesting b ()-assert b = equals b (return True)+beTrue :: Bool -> TestResult+beTrue True = TestPass (Positive "assertion")+beTrue False = TestFail (Positive "assertion") -- | A data type for tests against forms. data FormExpectations a = Value a -- ^ The value the form should take (and should be valid)@@ -243,35 +361,40 @@ form expected theForm theParams = do r <- eval $ DF.postForm "form" theForm (const $ return lookupParam) case expected of- Value a -> equals (snd r) (return $ Just a)+ Value a -> should $ equal <$> val (snd r) <*> val (Just a) ErrorPaths expectedPaths -> do let viewErrorPaths = map (DF.fromPath . fst) $ DF.viewErrors $ fst r- assert (all (`elem` viewErrorPaths) expectedPaths- && (length viewErrorPaths == length expectedPaths))+ should $ beTrue <$> val (all (`elem` viewErrorPaths) expectedPaths+ && (length viewErrorPaths == length expectedPaths)) where lookupParam pth = case M.lookup (DF.fromPath pth) fixedParams of Nothing -> return [] Just v -> return [DF.TextInput v] fixedParams = M.mapKeys (T.append "form.") theParams -- | Checks that the given request results in a success (200) code.-succeeds :: TestRequest -> SnapTesting b ()-succeeds req = run req testSuccess+succeed :: TestResponse -> TestResult+succeed (Html _) = TestPass (Positive "Request 200s.")+succeed _ = TestFail (Positive "Request 200s.") -- | Checks that the given request results in a not found (404) code.-notfound :: TestRequest -> SnapTesting b ()-notfound req = run req test404+notfound :: TestResponse -> TestResult+notfound NotFound = TestPass (Positive "Request 404s.")+notfound _ = TestFail (Positive "Request 404s.") -- | Checks that the given request results in a redirect (3**) code.-redirects :: TestRequest -> SnapTesting b ()-redirects req = run req testRedirect+redirect :: TestResponse -> TestResult+redirect (Redirect _ _) = TestPass (Positive "Request redirects.")+redirect _ = TestFail (Positive "Request redirects.") -- | Checks that the given request results in a redirect to a specific url.-redirectsto :: TestRequest -- ^ Request to run- -> Text -- ^ URL it should redirect to- -> SnapTesting b ()-redirectsto req uri = run req (testRedirectTo $ encodeUtf8 uri)+redirectTo :: TestResponse -- ^ Request to run+ -> Text -- ^ URL it should redirect to+ -> TestResult+redirectTo (Redirect _ actual) expected | actual == expected = TestPass (Positive (T.concat ["Redirecting actual: ", actual, " expected: ", expected]))+redirectTo (Redirect _ actual) expected = TestFail (Positive (T.concat ["Redirecting actual: ", actual, " expected: ", expected]))+redirectTo _ expected = TestFail (Positive (T.concat ["Redirects to ", expected])) --- | Checks that the monadic value given changes by the function specified after the request is run.+-- | Checks that the monadic value given changes by the function specified after the given test block is run. -- -- For example, if you wanted to make sure that account creation was creating new accounts: --@@ -280,38 +403,15 @@ -- > , ("new_user.email", "jdoe@c.com") -- > , ("new_user.password", "foobar")]) changes :: (Show a, Eq a)- => (a -> a) -- ^ Change function- -> Handler b b a -- ^ Monadic value- -> TestRequest -- ^ Request to run.+ => (a -> a) -- ^ Change function+ -> Handler b b a -- ^ Monadic value+ -> SnapTesting b c -- ^ Test block to run. -> SnapTesting b ()-changes delta measure req = do- (site, app, _) <- S.get- changes' delta measure (liftIO $ runHandlerSafe req site app)---- | A more general variant of `changes` that allows an arbitrary block instead of a request.-changes' :: (Show a, Eq a) =>- (a -> a) -- ^ Change function- -> Handler b b a -- ^ Monadic value- -> SnapTesting b c -- ^ Block of tests to run- -> SnapTesting b ()-changes' delta measure act = do+changes delta measure act = do before <- eval measure _ <- act after <- eval measure- res <- testEqual "Expected value to change" (delta before) after- writeRes res---- | Checks that the response body of a given request contains some text.-contains :: TestRequest -- ^ Request to run- -> Text -- ^ Text that body should contain- -> SnapTesting b ()-contains req mtch = run req (testBodyContains (encodeUtf8 mtch))---- | Checks that the response body of a given request does not contain some text.-notcontains :: TestRequest -- ^ Request to run- -> Text -- ^ Text that body should not contain- -> SnapTesting b ()-notcontains req mtch = run req (testBodyNotContains (encodeUtf8 mtch))+ should $ equal <$> val (delta before) <*> val after -- | Runs an action after a block of tests, usually used to remove database state. cleanup :: Handler b b () -- ^ Action to run after tests@@ -320,7 +420,7 @@ cleanup cu act = do act (_, app, _) <- S.get- _ <- liftIO $ runHandlerSafe (get "") cu app+ _ <- liftIO $ runHandlerSafe (Test.get "" M.empty) cu app return () -- | Evaluate arbitrary actions@@ -348,90 +448,21 @@ quickCheck p = do res <- liftIO $ quickCheckWithResult (stdArgs { chatty = False }) p case res of- Success{} -> writeRes (TestPass "")- GaveUp{} -> writeRes (TestPass "")- Failure{} -> writeRes (TestFail "")- NoExpectedFailure{} -> writeRes (TestFail "")+ Success{} -> writeRes (TestPass (Positive ""))+ GaveUp{} -> writeRes (TestPass (Positive ""))+ Failure{} -> writeRes (TestFail (Positive ""))+ NoExpectedFailure{} -> writeRes (TestFail (Positive "")) -- Private helpers-runHandlerSafe :: TestRequest -> Handler b b v -> SnapletInit b b -> IO (Either Text Response)-runHandlerSafe req site app =- catch (runHandler (Just "test") req site app) (\(e::SomeException) -> return $ Left (pack $ show e))--evalHandlerSafe :: Handler b b v -> SnapletInit b b -> IO (Either Text v)-evalHandlerSafe act app =- catch (evalHandler (Just "test") (get "") act app) (\(e::SomeException) -> return $ Left (pack $ show e))---run :: TestRequest -> (Response -> SnapTesting b TestLog) -> SnapTesting b ()-run req asrt = do- (site, app, _) <- S.get- res <- liftIO $ runHandlerSafe req site app- case res of- Left err -> writeRes (TestError err)- Right response -> do- testlog <- asrt response- writeRes testlog---- Low level matchers - these parallel HUnit assertions in Snap.Test--testEqual :: (Eq a, Show a) => Text -> a -> a -> SnapTesting b TestLog-testEqual msg a b = return $ if a == b then TestPass "" else TestFail msg--testBool :: Text -> Bool -> SnapTesting b TestLog-testBool msg b = return $ if b then TestPass "" else TestFail msg--testSuccess :: Response -> SnapTesting b TestLog-testSuccess rsp = testEqual message 200 status- where- message = pack $ "Expected success (200) but got (" ++ show status ++ ")"- status = rspStatus rsp--test404 :: Response -> SnapTesting b TestLog-test404 rsp = testEqual message 404 status- where- message = pack $ "Expected Not Found (404) but got (" ++ show status ++ ")"- status = rspStatus rsp--testRedirectTo :: ByteString- -> Response- -> SnapTesting b TestLog-testRedirectTo uri rsp = do- testRedirect rsp- testEqual message uri rspUri- where- rspUri = fromMaybe "" $ getHeader "Location" rsp- message = pack $ "Expected redirect to " ++ show uri- ++ " but got redirected to "- ++ show rspUri ++ " instead"--testRedirect :: Response -> SnapTesting b TestLog-testRedirect rsp = testBool message (300 <= status && status <= 399)- where- message = pack $ "Expected redirect but got status code ("- ++ show status ++ ")"- status = rspStatus rsp---containsGen :: (Bool -> Bool) -> Text -> ByteString -> Response -> SnapTesting b TestLog-containsGen b message match rsp =- do- body <- liftIO $ getResponseBody rsp- return $ if b (match `isInfixOf` body) then TestPass "" else TestFail message--testBodyContains :: ByteString- -> Response- -> SnapTesting b TestLog-testBodyContains match = containsGen id message match- where- message = pack $ "Expected body to contain \"" ++ show match- ++ "\", but didn't"-+runHandlerSafe :: RequestBuilder IO ()+ -> Handler b b v+ -> (Snaplet b, InitializerState b)+ -> IO (Either Text Response)+runHandlerSafe req site (s, is) =+ catch (runHandler' s is req site) (\(e::SomeException) -> return $ Left (pack $ show e)) -testBodyNotContains :: ByteString- -> Response- -> SnapTesting b TestLog-testBodyNotContains match = containsGen not message match- where- message = pack $ "Expected body to not contain \"" ++ show match- ++ "\", but did"+evalHandlerSafe :: Handler b b v+ -> (Snaplet b, InitializerState b)+ -> IO (Either Text v)+evalHandlerSafe act (s, is) =+ catch (evalHandler' s is (Test.get "" M.empty) act) (\(e::SomeException) -> return $ Left (pack $ show e))
+ test/Main.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction, GADTs, TemplateHaskell #-}++module Main where+++----------------------------------------------------------+-- Section 0: Imports. --+----------------------------------------------------------+import Control.Applicative+import Control.Lens+import Data.ByteString (ByteString)+import Data.Text (Text)+import Data.Maybe (fromMaybe)+import qualified Data.Map as M+import Snap (Handler, method, Method(..), writeText, writeBS,+ getParam, SnapletInit, makeSnaplet, addRoutes,+ route, liftIO, void)+import qualified Snap as Snap++import Control.Concurrent.Async (async)+import Control.Concurrent.MVar (MVar, newEmptyMVar, tryPutMVar, tryTakeMVar, isEmptyMVar)+import qualified System.IO.Streams as Stream+import qualified System.IO.Streams.Concurrent as Stream+import System.Exit (exitSuccess, exitFailure)++import Snap.Test.BDD++----------------------------------------------------------+-- Section 1: Example application used for testing. --+----------------------------------------------------------+data App = App { _mv :: MVar () }++makeLenses ''App++html :: Text+html = "<table><tr><td>One</td><td>Two</td></tr></table>"++routes :: [(ByteString, Handler App App ())]+routes = [("/test", method GET $ writeText html)+ ,("/test", method POST $ writeText "")+ ,("/params", do mq <- getParam "q"+ writeBS $ fromMaybe "" mq)+ ,("/redirect", Snap.redirect "/test")+ ,("/setmv", do m <- use mv+ liftIO $ tryPutMVar m ()+ return ())+ ]++app :: MVar () -> SnapletInit App App+app mv = makeSnaplet "app" "An snaplet example application." Nothing $ do+ addRoutes routes+ return (App mv)+++----------------------------------------------------------+-- Section 2: Test suite against application. --+----------------------------------------------------------+tests :: SnapTesting App ()+tests = do+ name "should match selector from a GET request" $ do+ should $ haveSelector <$> get "/test" <*> css "table td"+ shouldNot $ haveSelector <$> get "/test" <*> css "table td.doesntexist"+ shouldNot $ haveSelector <$> get "/redirect" <*> css "table td.doesntexist"+ shouldNot $ haveSelector <$> get "/invalid_url" <*> css "table td.doesntexist"+ name "should not match html on POST request" $+ shouldNot $ haveText <$> post "/test" M.empty <*> val "<html>"+ name "should post parameters" $ do+ should $ haveText <$> post "/params" (params [("q", "hello")]) <*> val "hello"+ shouldNot $ haveText <$> post "/params" (params [("r", "hello")]) <*> val "hello"+ name "basic equality" $ do+ should $ equal <$> val 1 <*> val 1+ should $ equal <$> eval (return 1) <*> val 1+ name "booleans from other tests" $ do+ should $ beTrue <$> val True+ shouldNot $ beTrue <$> val False+ name "status codes" $ do+ name "200" $ do+ should $ succeed <$> get "/test"+ shouldNot $ succeed <$> get "/invalid_url"+ name "404" $ do+ shouldNot $ notfound <$> get "/test"+ should $ notfound <$> get "/invalid_url"+ name "3**" $ do+ should $ redirect <$> get "/redirect"+ shouldNot $ redirect <$> get "/test"+ name "3** with target" $ do+ should $ redirectTo <$> get "/redirect" <*> val "/test"+ shouldNot $ redirectTo <$> get "/redirect" <*> val "/redirect"+ shouldNot $ redirectTo <$> get "/test" <*> val "/redirect"+ name "should reflect stateful changes" $ do+ let isE = use mv >>= \m -> liftIO $ isEmptyMVar m+ cleanup (use mv >>= \m -> void $ liftIO $ tryTakeMVar m) $ do+ should $ equal <$> eval isE <*> val True+ changes not isE $ post "/setmv" M.empty+ changes id isE $ post "/setmv" M.empty+ should $ equal <$> eval isE <*> val True++----------------------------------------------------------+-- Section 3: Code to interface with cabal test. --+----------------------------------------------------------+main :: IO ()+main = do+ (inp, out) <- Stream.makeChanPipe+ mvar <- newEmptyMVar+ async $ runSnapTests defaultConfig { reportGenerators = [streamReport out, consoleReport] }+ (route routes)+ (app mvar)+ tests+ res <- Stream.toList inp+ if length (filter isFailing res) == 0+ then exitSuccess+ else exitFailure+ where streamReport out results = do res <- Stream.read results+ case res of+ Nothing -> Stream.write Nothing out+ Just r -> do+ Stream.write (Just r) out+ streamReport out results+ isFailing (TestFail _) = True+ isFailing (TestError _) = True+ isFailing _ = False