diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -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. diff --git a/snap-testing.cabal b/snap-testing.cabal --- a/snap-testing.cabal +++ b/snap-testing.cabal @@ -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 diff --git a/src/Snap/Test/BDD.hs b/src/Snap/Test/BDD.hs --- a/src/Snap/Test/BDD.hs +++ b/src/Snap/Test/BDD.hs @@ -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)) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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 = "
OneTwo
" + +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 "" + 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