module Snap.Test.BDD
(
SnapTesting
, TestRequest
, TestLog
, SnapTestingConfig (..)
, defaultConfig
, runSnapTests
, consoleReport
, linuxDesktopReport
, name
, get
, get'
, post
, params
, succeeds
, notfound
, redirects
, redirectsto
, changes
, changes'
, contains
, notcontains
, equals
, cleanup
, eval
, modifySite
, quickCheck
) where
import Prelude hiding (FilePath)
import Data.Map (Map, fromList)
import Data.ByteString (ByteString, isInfixOf)
import Data.Text (Text, pack, unpack)
import qualified Data.Text as T (append, isInfixOf)
import Data.Text.Encoding (encodeUtf8)
import Data.Monoid (mempty, mconcat)
import Data.Maybe (fromMaybe)
import Control.Monad (void, unless)
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 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)
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
type SnapTesting b a = StateT (Handler b b (), SnapletInit b b, OutputStream TestLog) IO a
type TestRequest = RequestBuilder IO ()
data TestLog = NameStart Text | NameEnd | TestPass Text | TestFail Text | TestError Text deriving Show
data SnapTestingConfig = SnapTestingConfig { reportGenerators :: [InputStream TestLog -> IO ()]
}
defaultConfig :: SnapTestingConfig
defaultConfig = SnapTestingConfig { reportGenerators = [consoleReport]
}
dupN :: Int -> InputStream a -> IO [InputStream a]
dupN 0 s = return []
dupN 1 s = return [s]
dupN n s = do (a, b) <- S.map (\x -> (x,x)) s >>= S.unzip
rest <- dupN (n 1) b
return (a:rest)
runSnapTests :: SnapTestingConfig
-> Handler b b ()
-> SnapletInit b b
-> SnapTesting b ()
-> IO ()
runSnapTests conf site app tests = do
(inp, out) <- S.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 ()
consoleReport :: InputStream TestLog -> IO ()
consoleReport stream = cr 0
where cr indent = do log <- S.read stream
case log of
Nothing -> 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 _) -> do putStr " FAILED"
cr indent
Just (TestError msg) -> do putStr " ERROR("
putStr (unpack msg)
putStr ")"
cr indent
indentUnit = 2
printIndent n = putStr (replicate n ' ')
linuxDesktopReport :: InputStream TestLog -> IO ()
linuxDesktopReport stream = do
res <- S.toList stream
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 (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
writeRes :: TestLog -> SnapTesting b ()
writeRes log = do (_,_,out) <- S.get
lift $ S.write (Just log) out
name :: Text
-> SnapTesting b ()
-> SnapTesting b ()
name s a = do
(_,_,out) <- S.get
writeRes (NameStart s)
a
writeRes NameEnd
get :: ByteString
-> TestRequest
get = flip Test.get mempty
get' :: ByteString
-> Map ByteString [ByteString]
-> TestRequest
get' = Test.get
post :: ByteString
-> Map ByteString [ByteString]
-> TestRequest
post = Test.postUrlEncoded
params :: [(ByteString, ByteString)]
-> Map ByteString [ByteString]
params = fromList . map (\x -> (fst x, [snd x]))
equals :: (Show a, Eq a) => a
-> Handler b b a
-> SnapTesting b ()
equals a ha = do
b <- eval ha
res <- testEqual "Expected value to equal " a b
writeRes res
succeeds :: TestRequest -> SnapTesting b ()
succeeds req = run req testSuccess
notfound :: TestRequest -> SnapTesting b ()
notfound req = run req test404
redirects :: TestRequest -> SnapTesting b ()
redirects req = run req testRedirect
redirectsto :: TestRequest
-> Text
-> SnapTesting b ()
redirectsto req uri = run req (testRedirectTo $ encodeUtf8 uri)
changes :: (Show a, Eq a)
=> (a -> a)
-> Handler b b a
-> TestRequest
-> SnapTesting b ()
changes delta measure req = do
(site, app, _) <- S.get
changes' delta measure (liftIO $ runHandlerSafe req site app)
changes' :: (Show a, Eq a) =>
(a -> a)
-> Handler b b a
-> SnapTesting b c
-> SnapTesting b ()
changes' delta measure act = do
before <- eval measure
_ <- act
after <- eval measure
res <- testEqual "Expected value to change" (delta before) after
writeRes res
contains :: TestRequest
-> Text
-> SnapTesting b ()
contains req mtch = run req (testBodyContains (encodeUtf8 mtch))
notcontains :: TestRequest
-> Text
-> SnapTesting b ()
notcontains req mtch = run req (testBodyNotContains (encodeUtf8 mtch))
cleanup :: Handler b b ()
-> SnapTesting b ()
-> SnapTesting b ()
cleanup cu act = do
act
(_, app, _) <- S.get
_ <- liftIO $ runHandlerSafe (get "") cu app
return ()
eval :: Handler b b a
-> SnapTesting b a
eval act = do
(_, app, _) <- S.get
liftIO $ fmap (either (error . unpack) id) $ evalHandlerSafe act app
modifySite :: (Handler b b () -> Handler b b ())
-> SnapTesting b a
-> 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
quickCheck :: Testable prop => prop -> SnapTesting b ()
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 "")
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
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"
testBodyNotContains :: ByteString
-> Response
-> SnapTesting b TestLog
testBodyNotContains match = containsGen not message match
where
message = pack $ "Expected body to not contain \"" ++ show match
++ "\", but did"