packages feed

snap-testing 0.1.0.0 → 0.2.0.0

raw patch · 3 files changed

+403/−403 lines, 3 files

Files

snap-testing.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                snap-testing-version:             0.1.0.0+version:             0.2.0.0 synopsis:            A library for BDD-style testing with the Snap Web Framework -- description: homepage:            https://github.com/dbp/snap-testing@@ -17,7 +17,7 @@  library   exposed-modules:-        Snap.Testing+        Snap.Test.BDD   hs-source-dirs: src   -- other-modules:   build-depends:       base ==4.6.*,
+ src/Snap/Test/BDD.hs view
@@ -0,0 +1,401 @@+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}++{-|++This library allows you to write tests against handlers, checking+response codes and bodies, modifications of state, etc. The tests are written+in a hierarchical fashion, with labels to help organize them, and+various ways of reporting on the results of testing are possible.++All of the tests are run in the "test" environment, so be sure to+create the corresponding .cfg files and databases, etc.++Here is a complete example (where routes are your applications routes, and+app is your site initializer):++> runSnapTests [consoleReport, desktopReport] (route routes) app $ do+>   name "/auth/new_user" $ do+>     name "success" $+>       succeeds (get "/auth/new_user")+>     name "creates a new account" $+>       cleanup clearAccounts $+>       changes (+1) countAccounts (post "/auth/new_user" $ params+>                                   [ ("new_user.name", "Jane")+>                                   , ("new_user.email", "jdoe@c.com")+>                                   , ("new_user.password", "foobar")])++There are many different predicates available (and a basic way of+integrating QuickCheck), and it is relatively easy to add+functionality on top of what is built in. For example, to add a way of+creating users and logging in as them for a block of tests you could+do the following (this is using the auth snaplet - if you are doing+somethinge else, obviously the `with auth ...` line would be+different):++> withUser :: SnapTesting App a -> SnapTesting App a+> withUser = modifySite $ \site -> do+>   au <- fmap fromJust getRandomUser+>   with auth $ forceLogin au+>   site++Where `getRandomUser` is a function written in your applications+handler (using whatever state needed).++-}+module Snap.Test.BDD+       (+       -- * Types+         SnapTesting+       , TestRequest+       , TestResult(..)++       -- * Running tests+       , runSnapTests+       , consoleReport+       , linuxDesktopReport++       -- * Labeling+       , name++       -- * Creating Requests+       , get+       , post+       , params++       -- * Request predicates+       , succeeds+       , notfound+       , redirects+       , redirectsto+       , changes+       , changes'+       , contains+       , notcontains++       -- * Stateful unit tests+       , equals++       -- * Run actions after block+       , cleanup++       -- * Evaluate arbitrary action+       , eval++       -- * Create helpers+       , modifySite++       -- * Integrate with QuickCheck+       , quickCheck+       ) where++import           Data.Map (Map, fromList)+import           Data.ByteString (ByteString, isInfixOf)+import           Data.Text (Text, pack, unpack)+import qualified Data.Text as T (append)+import           Data.Text.Encoding (encodeUtf8)+import           Data.Monoid (mempty)+import           Data.Maybe (fromJust)+import           Control.Monad (liftM, zipWithM, void)+import           Control.Monad.Trans+import           Control.Monad.Trans.State (StateT, evalStateT)+import qualified Control.Monad.Trans.State as S (get, put)+import           Control.Monad.Trans.Writer (WriterT(..), tell)+import           Control.Exception (SomeException, catch)+import           System.Process (system)+import           Snap.Core (Response(..), getHeader)+import           Snap.Snaplet (Handler, SnapletInit)+import           Snap.Test (RequestBuilder, getResponseBody)+import qualified Snap.Test as Test+import           Snap.Snaplet.Test (runHandler, evalHandler)+import           Test.QuickCheck (Args(..), Result(..), Testable, quickCheckWithResult, stdArgs)++-- | The main type for this library, where `b` is your application state,+-- often called `App`. This is a State and Writer monad on top of IO, where the State carries+-- your application (or, more specifically, a top-level handler), and the Writer allows tests+-- to be reported as passing or failing.+type SnapTesting b a = WriterT [TestLog] (StateT (Handler b b (), SnapletInit b b) IO) a++-- | TestRequests are created with `get` and `post`.+type TestRequest = RequestBuilder IO ()++-- | TestResults are what are used to write report generators (two are included). The result+-- is a tree structure.+data TestResult = ResultName Text [TestResult] | ResultPass Text | ResultFail Text+-- TestLog is the flat datastructure that will be turned into the TestResult tree+data TestLog = NameStart Text | NameEnd | TestPass Text | TestFail Text deriving Show++-- | Run a set of tests, putting the results through the specified report generators+runSnapTests :: [[TestResult] -> IO ()] -- ^ Report generators+                -> Handler b b ()       -- ^ Site that requests are run against (often route routes, where routes are your sites routes).+                -> SnapletInit b b      -- ^ Site initializer+                -> SnapTesting b ()     -- ^ Block of tests+                -> IO ()+runSnapTests rgs site app tests = do+  testlog <- liftM snd $ evalStateT (runWriterT tests) (site, app)+  let res = fst $ buildResult [] testlog+  _ <- zipWithM ($) rgs (repeat res)+  return ()++buildResult :: [TestResult] -> [TestLog] -> ([TestResult], [TestLog])+buildResult acc [] = (acc, [])+buildResult acc ((NameStart nm):xs) =+  let (cur, rest) = buildResult [] xs in+  buildResult (acc ++ [(ResultName nm cur)]) rest+buildResult acc (NameEnd:xs) = (acc, xs)+buildResult acc ((TestPass desc):xs) = buildResult (acc ++ [ResultPass desc]) xs+buildResult acc ((TestFail desc):xs) = buildResult (acc ++ [ResultFail desc]) xs++-- | Prints test results to the console. For example:+--+-- > /auth/new_user+-- >  success+-- >    PASSED+-- >  creates a new account+-- >    PASSED+consoleReport :: [TestResult] -> IO ()+consoleReport = cg 0+  where cg _ [] = return ()+        cg indent (ResultName n children : xs) = do+          fmt indent n+          cg (indent + 2) children+          cg indent xs+        cg indent (ResultPass n : xs) = do+          fmt indent (T.append "PASSED " n)+          cg indent xs+        cg indent (ResultFail n : xs) = do+          fmt indent (T.append "FAILED: " n)+          cg indent xs+        fmt indent t = putStrLn $ replicate indent ' ' ++ unpack t++-- | Sends the test results to desktop notifications on linux. Prints how many tests passed and failed.+linuxDesktopReport ::  [TestResult] -> IO ()+linuxDesktopReport res = do+  let (passed, total) = count res+  case passed == total of+    True ->+      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 (ResultName _ children : xs) = count (children ++ xs)+       count (ResultPass _ : xs) = let (p, t) = count xs+                                   in (1 + p, 1 + t)+       count (ResultFail _ : xs) = let (p, t) = count xs+                                   in (p, 1 + t)++-- | 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+  tell [NameStart s]+  a+  tell [NameEnd]++-- | Creates a new GET request.+get :: ByteString -- ^ The url to request.+    -> TestRequest+get = flip Test.get mempty++-- | Creates a new POST request, with a set of parameters.+post :: ByteString                  -- ^ The url to request.+     -> Map ByteString [ByteString] -- ^ The parameters to send.+     -> TestRequest+post = Test.postUrlEncoded++-- | A helper to construct parameters.+params :: [(ByteString, ByteString)] -- ^ Pairs of parameter and value.+       -> Map ByteString [ByteString]+params = fromList . map (\x -> (fst x, [snd x]))++-- | 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+  tell [res]++-- | Checks that the given request results in a success (200) code.+succeeds :: TestRequest -> SnapTesting b ()+succeeds req = run req testSuccess++-- | Checks that the given request results in a not found (404) code.+notfound :: TestRequest -> SnapTesting b ()+notfound req = run req test404++-- | Checks that the given request results in a redirect (3**) code.+redirects :: TestRequest -> SnapTesting b ()+redirects req = run req testRedirect++-- | 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)++-- | Checks that the monadic value given changes by the function specified after the request is run.+--+-- For example, if you wanted to make sure that account creation was creating new accounts:+--+-- > changes (+1) countAccounts (post "/auth/new_user" $ params+-- >                             [ ("new_user.name", "Jane")+-- >                             , ("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.+        -> SnapTesting b ()+changes delta measure req = do+  (site, app) <- lift 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+  before <- eval measure+  _ <- act+  after <- eval measure+  res <- testEqual "Expected value to change" (delta before) after+  tell [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))++-- | Runs an action after a block of tests, usually used to remove database state.+cleanup :: Handler b b ()   -- ^ Action to run after tests+        -> SnapTesting b () -- ^ Tests to run+        -> SnapTesting b ()+cleanup cu act = do+  act+  (_, app) <- lift S.get+  _ <- liftIO $ runHandlerSafe (get "") cu app+  return ()++-- | Evaluate arbitrary actions+eval :: Handler b b a -- ^ Action to evaluate+     -> SnapTesting b a+eval act = do+  (_, app) <- lift S.get+  liftIO $ fmap (either (error. unpack) id) $ evalHandlerSafe act app+++-- | Given a site to site function (like, generating a random user and logging in), run the given block of test with the modified state.+modifySite :: (Handler b b () -> Handler b b ()) -- ^ Site modification function+           -> SnapTesting b a -- ^ Tests to run+           -> SnapTesting b a+modifySite f act = do+  (site, app) <- lift S.get+  lift $ S.put (f site, app)+  res <- act+  lift $ S.put (site, app)+  return res++-- | Allows you to run a quickcheck test. All 100 test passing counts as a pass, any failure a failure.+-- Currently the reporting is really bad (you don't see what the failing example is).+quickCheck :: Testable prop => prop -> SnapTesting b ()+quickCheck p = do+  res <- liftIO $ quickCheckWithResult (stdArgs { chatty = False }) p+  case res of+    Success{} -> tell [TestPass ""]+    GaveUp{} -> tell [TestPass ""]+    Failure{} -> tell [TestFail ""]+    NoExpectedFailure{} -> tell [TestFail ""]++-- 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) <- lift S.get+  res <- liftIO $ runHandlerSafe req site app+  case res of+    Left err -> tell [TestFail $ T.append "Handler returned an error: " err]+    Right response -> do+      testlog <- asrt response+      tell [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 = fromJust $ 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"+++testBodyNotContains :: ByteString+                   -> Response+                   -> SnapTesting b TestLog+testBodyNotContains match = containsGen not message match+  where+    message = pack $ "Expected body to not contain \"" ++ show match+              ++ "\", but did"
− src/Snap/Testing.hs 
@@ -1,401 +0,0 @@-{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}--{-|--This library allows you to write tests against handlers, checking-response codes and bodies, modifications of state, etc. The tests are written-in a hierarchical fashion, with labels to help organize them, and-various ways of reporting on the results of testing are possible.--All of the tests are run in the "test" environment, so be sure to-create the corresponding .cfg files and databases, etc.--Here is a complete example (where routes are your applications routes, and-app is your site initializer):--> runSnapTests [consoleReport, desktopReport] (route routes) app $ do->   name "/auth/new_user" $ do->     name "success" $->       succeeds (get "/auth/new_user")->     name "creates a new account" $->       cleanup clearAccounts $->       changes (+1) countAccounts (post "/auth/new_user" $ params->                                   [ ("new_user.name", "Jane")->                                   , ("new_user.email", "jdoe@c.com")->                                   , ("new_user.password", "foobar")])--There are many different predicates available (and a basic way of-integrating QuickCheck), and it is relatively easy to add-functionality on top of what is built in. For example, to add a way of-creating users and logging in as them for a block of tests you could-do the following (this is using the auth snaplet - if you are doing-somethinge else, obviously the `with auth ...` line would be-different):--> withUser :: SnapTesting App a -> SnapTesting App a-> withUser = modifySite $ \site -> do->   au <- fmap fromJust getRandomUser->   with auth $ forceLogin au->   site--Where `getRandomUser` is a function written in your applications-handler (using whatever state needed).---}-module Snap.Testing-       (-       -- * Types-         SnapTesting-       , TestRequest-       , TestResult(..)--       -- * Running tests-       , runSnapTests-       , consoleReport-       , linuxDesktopReport--       -- * Labeling-       , name--       -- * Creating Requests-       , get-       , post-       , params--       -- * Request predicates-       , succeeds-       , notfound-       , redirects-       , redirectsto-       , changes-       , changes'-       , contains-       , notcontains--       -- * Stateful unit tests-       , equals--       -- * Run actions after block-       , cleanup--       -- * Evaluate arbitrary action-       , eval--       -- * Create helpers-       , modifySite--       -- * Integrate with QuickCheck-       , quickCheck-       ) where--import           Data.Map (Map, fromList)-import           Data.ByteString (ByteString, isInfixOf)-import           Data.Text (Text, pack, unpack)-import qualified Data.Text as T (append)-import           Data.Text.Encoding (encodeUtf8)-import           Data.Monoid (mempty)-import           Data.Maybe (fromJust)-import           Control.Monad (liftM, zipWithM, void)-import           Control.Monad.Trans-import           Control.Monad.Trans.State (StateT, evalStateT)-import qualified Control.Monad.Trans.State as S (get, put)-import           Control.Monad.Trans.Writer (WriterT(..), tell)-import           Control.Exception (SomeException, catch)-import           System.Process (system)-import           Snap.Core (Response(..), getHeader)-import           Snap.Snaplet (Handler, SnapletInit)-import           Snap.Test (RequestBuilder, getResponseBody)-import qualified Snap.Test as Test-import           Snap.Snaplet.Test (runHandler, evalHandler)-import           Test.QuickCheck (Args(..), Result(..), Testable, quickCheckWithResult, stdArgs)---- | The main type for this library, where `b` is your application state,--- often called `App`. This is a State and Writer monad on top of IO, where the State carries--- your application (or, more specifically, a top-level handler), and the Writer allows tests--- to be reported as passing or failing.-type SnapTesting b a = WriterT [TestLog] (StateT (Handler b b (), SnapletInit b b) IO) a---- | TestRequests are created with `get` and `post`.-type TestRequest = RequestBuilder IO ()---- | TestResults are what are used to write report generators (two are included). The result--- is a tree structure.-data TestResult = ResultName Text [TestResult] | ResultPass Text | ResultFail Text--- TestLog is the flat datastructure that will be turned into the TestResult tree-data TestLog = NameStart Text | NameEnd | TestPass Text | TestFail Text deriving Show---- | Run a set of tests, putting the results through the specified report generators-runSnapTests :: [[TestResult] -> IO ()] -- ^ Report generators-                -> Handler b b ()       -- ^ Site that requests are run against (often route routes, where routes are your sites routes).-                -> SnapletInit b b      -- ^ Site initializer-                -> SnapTesting b ()     -- ^ Block of tests-                -> IO ()-runSnapTests rgs site app tests = do-  testlog <- liftM snd $ evalStateT (runWriterT tests) (site, app)-  let res = fst $ buildResult [] testlog-  _ <- zipWithM ($) rgs (repeat res)-  return ()--buildResult :: [TestResult] -> [TestLog] -> ([TestResult], [TestLog])-buildResult acc [] = (acc, [])-buildResult acc ((NameStart nm):xs) =-  let (cur, rest) = buildResult [] xs in-  buildResult (acc ++ [(ResultName nm cur)]) rest-buildResult acc (NameEnd:xs) = (acc, xs)-buildResult acc ((TestPass desc):xs) = buildResult (acc ++ [ResultPass desc]) xs-buildResult acc ((TestFail desc):xs) = buildResult (acc ++ [ResultFail desc]) xs---- | Prints test results to the console. For example:------ > /auth/new_user--- >  success--- >    PASSED--- >  creates a new account--- >    PASSED-consoleReport :: [TestResult] -> IO ()-consoleReport = cg 0-  where cg _ [] = return ()-        cg indent (ResultName n children : xs) = do-          fmt indent n-          cg (indent + 2) children-          cg indent xs-        cg indent (ResultPass n : xs) = do-          fmt indent (T.append "PASSED " n)-          cg indent xs-        cg indent (ResultFail n : xs) = do-          fmt indent (T.append "FAILED: " n)-          cg indent xs-        fmt indent t = putStrLn $ replicate indent ' ' ++ unpack t---- | Sends the test results to desktop notifications on linux. Prints how many tests passed and failed.-linuxDesktopReport ::  [TestResult] -> IO ()-linuxDesktopReport res = do-  let (passed, total) = count res-  case passed == total of-    True ->-      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 (ResultName _ children : xs) = count (children ++ xs)-       count (ResultPass _ : xs) = let (p, t) = count xs-                                   in (1 + p, 1 + t)-       count (ResultFail _ : xs) = let (p, t) = count xs-                                   in (p, 1 + t)---- | 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-  tell [NameStart s]-  a-  tell [NameEnd]---- | Creates a new GET request.-get :: ByteString -- ^ The url to request.-    -> TestRequest-get = flip Test.get mempty---- | Creates a new POST request, with a set of parameters.-post :: ByteString                  -- ^ The url to request.-     -> Map ByteString [ByteString] -- ^ The parameters to send.-     -> TestRequest-post = Test.postUrlEncoded---- | A helper to construct parameters.-params :: [(ByteString, ByteString)] -- ^ Pairs of parameter and value.-       -> Map ByteString [ByteString]-params = fromList . map (\x -> (fst x, [snd x]))---- | 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-  tell [res]---- | Checks that the given request results in a success (200) code.-succeeds :: TestRequest -> SnapTesting b ()-succeeds req = run req testSuccess---- | Checks that the given request results in a not found (404) code.-notfound :: TestRequest -> SnapTesting b ()-notfound req = run req test404---- | Checks that the given request results in a redirect (3**) code.-redirects :: TestRequest -> SnapTesting b ()-redirects req = run req testRedirect---- | 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)---- | Checks that the monadic value given changes by the function specified after the request is run.------ For example, if you wanted to make sure that account creation was creating new accounts:------ > changes (+1) countAccounts (post "/auth/new_user" $ params--- >                             [ ("new_user.name", "Jane")--- >                             , ("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.-        -> SnapTesting b ()-changes delta measure req = do-  (site, app) <- lift 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-  before <- eval measure-  _ <- act-  after <- eval measure-  res <- testEqual "Expected value to change" (delta before) after-  tell [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))---- | Runs an action after a block of tests, usually used to remove database state.-cleanup :: Handler b b ()   -- ^ Action to run after tests-        -> SnapTesting b () -- ^ Tests to run-        -> SnapTesting b ()-cleanup cu act = do-  act-  (_, app) <- lift S.get-  _ <- liftIO $ runHandlerSafe (get "") cu app-  return ()---- | Evaluate arbitrary actions-eval :: Handler b b a -- ^ Action to evaluate-     -> SnapTesting b a-eval act = do-  (_, app) <- lift S.get-  liftIO $ fmap (either (error. unpack) id) $ evalHandlerSafe act app----- | Given a site to site function (like, generating a random user and logging in), run the given block of test with the modified state.-modifySite :: (Handler b b () -> Handler b b ()) -- ^ Site modification function-           -> SnapTesting b a -- ^ Tests to run-           -> SnapTesting b a-modifySite f act = do-  (site, app) <- lift S.get-  lift $ S.put (f site, app)-  res <- act-  lift $ S.put (site, app)-  return res---- | Allows you to run a quickcheck test. All 100 test passing counts as a pass, any failure a failure.--- Currently the reporting is really bad (you don't see what the failing example is).-quickCheck :: Testable prop => prop -> SnapTesting b ()-quickCheck p = do-  res <- liftIO $ quickCheckWithResult (stdArgs { chatty = False }) p-  case res of-    Success{} -> tell [TestPass ""]-    GaveUp{} -> tell [TestPass ""]-    Failure{} -> tell [TestFail ""]-    NoExpectedFailure{} -> tell [TestFail ""]---- 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) <- lift S.get-  res <- liftIO $ runHandlerSafe req site app-  case res of-    Left err -> tell [TestFail $ T.append "Handler returned an error: " err]-    Right response -> do-      testlog <- asrt response-      tell [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 = fromJust $ 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"---testBodyNotContains :: ByteString-                   -> Response-                   -> SnapTesting b TestLog-testBodyNotContains match = containsGen not message match-  where-    message = pack $ "Expected body to not contain \"" ++ show match-              ++ "\", but did"