snap-testing-0.6.0.0: src/Snap/Test/BDD.hs
{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}
module Snap.Test.BDD
(
-- * Types
SnapTesting
, TestResult(..)
, Sentiment(..)
, TestResponse(..)
, SnapTestingConfig (..)
-- * Configuration
, defaultConfig
-- * Running tests
, runSnapTests
, consoleReport
, linuxDesktopReport
-- * Labeling
, name
-- * Applying Predicates
, should
, shouldNot
-- * Helpers for running tests
, css
, val
-- * Getting Responses
, get
, get'
, post
, params
-- * Predicates on values
, equal
, beTrue
-- * Predicates on Responses
, succeed
, notfound
, redirect
, redirectTo
, haveText
, haveSelector
-- * Stateful value tests
, changes
-- * Stateful form tests
, FormExpectations(..)
, form
-- * Run actions after block
, cleanup
-- * Evaluating arbitrary actions
, eval
-- * Create helpers
, modifySite
-- * Integrate with QuickCheck
, quickCheck
) where
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, concat, isInfixOf)
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import Data.Maybe (fromMaybe)
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, Snaplet)
import Snap.Test (RequestBuilder, getResponseBody)
import qualified Snap.Test as Test
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 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 ()
, (Snaplet b, InitializerState b)
, OutputStream TestResult) IO a
-- | 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
data CssSelector = CssSelector Text
-- | 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]
}
-- | dupN duplicates an input stream N times
dupN :: Int -> InputStream a -> IO [InputStream a]
dupN 0 _ = return []
dupN 1 s = return [s]
dupN n s = do (a, b) <- Stream.map (\x -> (x,x)) s >>= Stream.unzip
rest <- dupN (n - 1) b
return (a:rest)
-- | Run a set of tests, putting the results through the specified report generators
runSnapTests :: SnapTestingConfig -- ^ Configuration for test runner
-> 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 conf site app tests = do
(inp, out) <- Stream.makeChanPipe
let rgs = reportGenerators conf
istreams <- dupN (length rgs) inp
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:
--
-- > /auth/new_user
-- > success PASSED
-- > creates a new account PASSED
consoleReport :: InputStream TestResult -> IO ()
consoleReport stream = cr 0
where cr indent = do log <- Stream.read stream
case log of
Nothing -> putStrLn "" >> return ()
Just (NameStart n) -> do putStrLn ""
printIndent indent
putStr (unpack n)
cr (indent + indentUnit)
Just NameEnd -> cr (indent - indentUnit)
Just (TestPass _) -> do putStr " PASSED"
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 TestResult -> IO ()
linuxDesktopReport stream = do
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.'"
_ ->
void $ system $ "notify-send -u normal -t 2000 'Some Tests Failing' '" ++
(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 :: TestResult -> SnapTesting b ()
writeRes log = do (_,_,out) <- S.get
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
writeRes (NameStart s)
a
writeRes NameEnd
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))
-- | 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.
-> SnapTesting b TestResponse
get' path ps = runRequest (Test.get (encodeUtf8 path) ps)
-- | Creates a new POST request, with a set of parameters.
post :: Text -- ^ The url to request.
-> Map ByteString [ByteString] -- ^ The parameters to send.
-> 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 = 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.
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.
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)
| ErrorPaths [Text] -- ^ The error paths that should be populated
-- | Test against digestive-functors forms.
form :: (Eq a, Show a)
=> FormExpectations a -- ^ If the form should succeed, Value a is what it should produce.
-- If failing, ErrorPaths should be all the errors that are triggered.
-> DF.Form Text (Handler b b) a -- ^ The form to run
-> Map Text Text -- ^ The parameters to pass
-> SnapTesting b ()
form expected theForm theParams =
do r <- eval $ DF.postForm "form" theForm (const $ return lookupParam)
case expected of
Value a -> should $ equal <$> val (snd r) <*> val (Just a)
ErrorPaths expectedPaths ->
do let viewErrorPaths = map (DF.fromPath . fst) $ DF.viewErrors $ fst r
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.
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 :: TestResponse -> TestResult
notfound NotFound = TestPass (Positive "Request 404s.")
notfound _ = TestFail (Positive "Request 404s.")
-- | Checks that the given request results in a redirect (3**) code.
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.
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 given test block 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
-> SnapTesting b c -- ^ Test block to run.
-> SnapTesting b ()
changes delta measure act = do
before <- eval measure
_ <- act
after <- eval measure
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
-> SnapTesting b () -- ^ Tests to run
-> SnapTesting b ()
cleanup cu act = do
act
(_, app, _) <- S.get
_ <- liftIO $ runHandlerSafe (Test.get "" M.empty) cu app
return ()
-- | Evaluate arbitrary actions
eval :: Handler b b a -- ^ Action to evaluate
-> SnapTesting b a
eval act = do
(_, app, _) <- 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, out) <- S.get
S.put (f site, app, out)
res <- act
S.put (site, app, out)
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{} -> writeRes (TestPass (Positive ""))
GaveUp{} -> writeRes (TestPass (Positive ""))
Failure{} -> writeRes (TestFail (Positive ""))
NoExpectedFailure{} -> writeRes (TestFail (Positive ""))
-- Private helpers
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))
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))