module Test.Hspec.Snap (
snap
, modifySite
, modifySite'
, afterEval
, beforeEval
, TestResponse(..)
, SnapHspecM
, afterAll
, get
, get'
, post
, params
, restrictResponse
, eval
, shouldChange
, shouldEqual
, shouldNotEqual
, shouldBeTrue
, shouldNotBeTrue
, should200
, shouldNot200
, should404
, shouldNot404
, should300
, shouldNot300
, should300To
, shouldNot300To
, shouldHaveSelector
, shouldNotHaveSelector
, shouldHaveText
, shouldNotHaveText
, FormExpectations(..)
, form
, SnapHspecState(..)
, setResult
, runRequest
, runHandlerSafe
, evalHandlerSafe
) where
import Control.Applicative ((<$>))
import Control.Concurrent.MVar (modifyMVar, newEmptyMVar, newMVar,
putMVar, takeMVar)
import Control.Exception (SomeException, catch)
import Control.Monad (void)
import Control.Monad.State (StateT (..), runStateT)
import qualified Control.Monad.State as S (get, put)
import Control.Monad.Trans (liftIO)
import Data.ByteString (ByteString)
import qualified Data.Map as M
import Data.Maybe (fromJust, fromMaybe, isJust)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Snap.Core (Response (..), getHeader)
import qualified Snap.Core as Snap
import Snap.Snaplet (Handler, Snaplet, SnapletInit)
import Snap.Snaplet.Test (InitializerState, closeSnaplet,
evalHandler', getSnaplet, runHandler')
import Snap.Test (RequestBuilder, getResponseBody)
import qualified Snap.Test as Test
import Test.Hspec
import Test.Hspec.Core
import qualified Text.Digestive as DF
import qualified Text.HandsomeSoup as HS
import qualified Text.XML.HXT.Core as HXT
data TestResponse = Html Text | NotFound | Redirect Int Text | Other Int | Empty deriving (Show, Eq)
type SnapHspecM b = StateT (SnapHspecState b) IO
data SnapHspecState b = SnapHspecState Result (Handler b b ()) (Snaplet b) (InitializerState b)
instance Example (SnapHspecM b ()) where
type Arg (SnapHspecM b ()) = SnapHspecState b
evaluateExample s _ cb _ =
do mv <- newEmptyMVar
cb $ \st@(SnapHspecState _ _ _ _) -> do ((),(SnapHspecState r' _ _ _)) <- runStateT s st
putMVar mv r'
takeMVar mv
afterAll :: IO () -> SpecWith a -> SpecWith a
afterAll action = go
where go spec = do forest <- runIO $ runSpecM spec
res <- runIO $ mapM countFlatten forest
let specs = map snd res
let count = foldr (+) 0 (map fst res)
mvar <- runIO $ newMVar count
after (\_ -> cleanup mvar) (fromSpecList specs)
countFlatten :: SpecTree a -> IO (Int, SpecTree a)
countFlatten (SpecGroup s t) =
do (count, t') <- joinCount <$> mapM countFlatten t
return (count, SpecGroup s t')
countFlatten (BuildSpecs a) = do s <- a
(count, s') <- joinCount <$> mapM countFlatten s
return (count, BuildSpecs (return s'))
countFlatten (SpecItem s i) = return (1, SpecItem s i)
joinCount :: [(Int, b)] -> (Int, [b])
joinCount = foldr (\(a,b) (c,d) -> (a + c, b:d)) (0, [])
cleanup mv = modifyMVar mv $ \v -> if v == 1
then action >>= return . (v,)
else return (v 1, ())
snap :: Handler b b () -> SnapletInit b b -> SpecWith (SnapHspecState b) -> Spec
snap site app spec = do
snapinit <- runIO $ getSnaplet (Just "test") app
case snapinit of
Left err -> error $ show err
Right (snaplet, initstate) -> do
afterAll (closeSnaplet initstate) $
before (return (SnapHspecState Success site snaplet initstate)) spec
modifySite :: (Handler b b () -> Handler b b ())
-> SpecWith (SnapHspecState b)
-> SpecWith (SnapHspecState b)
modifySite f = beforeWith (\(SnapHspecState r site snaplet initst) ->
return (SnapHspecState r (f site) snaplet initst))
modifySite' :: (Handler b b () -> Handler b b ())
-> SnapHspecM b a
-> SnapHspecM b a
modifySite' f a = do (SnapHspecState r site s i) <- S.get
S.put (SnapHspecState r (f site) s i)
a
afterEval :: Handler b b () -> SpecWith (SnapHspecState b) -> SpecWith (SnapHspecState b)
afterEval h = after (\(SnapHspecState r site s i) -> void $ evalHandlerSafe h s i)
beforeEval :: Handler b b () -> SpecWith (SnapHspecState b) -> SpecWith (SnapHspecState b)
beforeEval h = beforeWith (\state@(SnapHspecState r site s i) -> do void $ evalHandlerSafe h s i
return state)
get :: Text -> SnapHspecM b TestResponse
get path = get' path M.empty
get' :: Text -> Snap.Params -> SnapHspecM b TestResponse
get' path ps = runRequest (Test.get (T.encodeUtf8 path) ps)
params :: [(ByteString, ByteString)]
-> Snap.Params
params = M.fromList . map (\x -> (fst x, [snd x]))
post :: Text -> Snap.Params -> SnapHspecM b TestResponse
post path ps = runRequest (Test.postUrlEncoded (T.encodeUtf8 path) ps)
restrictResponse :: Text -> TestResponse -> TestResponse
restrictResponse selector (Html body) =
case HXT.runLA (HXT.xshow $ HXT.hread HXT.>>> HS.css (T.unpack selector)) (T.unpack body) of
[] -> Html ""
matches -> Html (T.concat (map T.pack matches))
restrictResponse _ r = r
eval :: Handler b b a -> SnapHspecM b a
eval act = do (SnapHspecState _ _ app is) <- S.get
liftIO $ fmap (either (error . T.unpack) id) $ evalHandlerSafe act app is
setResult :: Result -> SnapHspecM b ()
setResult r = do (SnapHspecState r' s a i) <- S.get
case r' of
Success -> S.put (SnapHspecState r s a i)
_ -> return ()
shouldChange :: (Show a, Eq a)
=> (a -> a)
-> (Handler b b a)
-> SnapHspecM b c
-> SnapHspecM b ()
shouldChange f v act = do before' <- eval v
act
after' <- eval v
shouldEqual (f before') after'
shouldEqual :: (Show a, Eq a)
=> a
-> a
-> SnapHspecM b ()
shouldEqual a b = if a == b
then setResult Success
else setResult (Fail ("Should have held: " ++ show a ++ " == " ++ show b))
shouldNotEqual :: (Show a, Eq a)
=> a
-> a
-> SnapHspecM b ()
shouldNotEqual a b = if a == b
then setResult (Fail ("Should not have held: " ++ show a ++ " == " ++ show b))
else setResult Success
shouldBeTrue :: Bool
-> SnapHspecM b ()
shouldBeTrue True = setResult Success
shouldBeTrue False = setResult (Fail "Value should have been True.")
shouldNotBeTrue :: Bool
-> SnapHspecM b ()
shouldNotBeTrue False = setResult Success
shouldNotBeTrue True = setResult (Fail "Value should have been True.")
should200 :: TestResponse -> SnapHspecM b ()
should200 (Html _) = setResult Success
should200 (Other 200) = setResult Success
should200 r = setResult (Fail (show r))
shouldNot200 :: TestResponse -> SnapHspecM b ()
shouldNot200 (Html _) = setResult (Fail "Got Html back.")
shouldNot200 (Other 200) = setResult (Fail "Got Other with 200 back.")
shouldNot200 _ = setResult Success
should404 :: TestResponse -> SnapHspecM b ()
should404 NotFound = setResult Success
should404 r = setResult (Fail (show r))
shouldNot404 :: TestResponse -> SnapHspecM b ()
shouldNot404 NotFound = setResult (Fail "Got NotFound back.")
shouldNot404 _ = setResult Success
should300 :: TestResponse -> SnapHspecM b ()
should300 (Redirect _ _) = setResult Success
should300 r = setResult (Fail (show r))
shouldNot300 :: TestResponse -> SnapHspecM b ()
shouldNot300 (Redirect _ _) = setResult (Fail "Got Redirect back.")
shouldNot300 _ = setResult Success
should300To :: Text -> TestResponse -> SnapHspecM b ()
should300To pth (Redirect _ to) | pth `T.isPrefixOf` to = setResult Success
should300To _ r = setResult (Fail (show r))
shouldNot300To :: Text -> TestResponse -> SnapHspecM b ()
shouldNot300To pth (Redirect _ to) | pth `T.isPrefixOf` to = setResult (Fail "Got Redirect back.")
shouldNot300To _ _ = setResult Success
shouldHaveSelector :: Text -> TestResponse -> SnapHspecM b ()
shouldHaveSelector selector r@(Html body) =
setResult $ if haveSelector' selector r
then Success
else (Fail msg)
where msg = (T.unpack $ T.concat ["Html should have contained selector: ", selector, "\n\n", body])
shouldHaveSelector match _ = setResult (Fail (T.unpack $ T.concat ["Non-HTML body should have contained css selector: ", match]))
shouldNotHaveSelector :: Text -> TestResponse -> SnapHspecM b ()
shouldNotHaveSelector selector r@(Html body) =
setResult $ if haveSelector' selector r
then (Fail msg)
else Success
where msg = (T.unpack $ T.concat ["Html should not have contained selector: ", selector, "\n\n", body])
shouldNotHaveSelector _ _ = setResult Success
haveSelector' :: Text -> TestResponse -> Bool
haveSelector' selector (Html body) =
case HXT.runLA (HXT.hread HXT.>>> HS.css (T.unpack selector)) (T.unpack body) of
[] -> False
_ -> True
haveSelector' _ _ = False
shouldHaveText :: Text -> TestResponse -> SnapHspecM b ()
shouldHaveText match (Html body) =
if T.isInfixOf match body
then setResult Success
else setResult (Fail $ T.unpack $ T.concat [body, "' contains '", match, "'."])
shouldHaveText match _ = setResult (Fail (T.unpack $ T.concat ["Body contains: ", match]))
shouldNotHaveText :: Text -> TestResponse -> SnapHspecM b ()
shouldNotHaveText match (Html body) =
if T.isInfixOf match body
then setResult (Fail $ T.unpack $ T.concat [body, "' contains '", match, "'."])
else setResult Success
shouldNotHaveText _ _ = setResult Success
data FormExpectations a = Value a
| Predicate (a -> Bool)
| ErrorPaths [Text]
form :: (Eq a, Show a)
=> FormExpectations a
-> DF.Form Text (Handler b b) a
-> M.Map Text Text
-> SnapHspecM b ()
form expected theForm theParams =
do r <- eval $ DF.postForm "form" theForm (const $ return lookupParam)
case expected of
Value a -> shouldEqual (snd r) (Just a)
Predicate f -> shouldBeTrue (isJust (snd r) && f (fromJust (snd r)))
ErrorPaths expectedPaths ->
do let viewErrorPaths = map (DF.fromPath . fst) $ DF.viewErrors $ fst r
shouldBeTrue (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
runRequest :: RequestBuilder IO () -> SnapHspecM b TestResponse
runRequest req = do
(SnapHspecState _ site app is) <- S.get
res <- liftIO $ runHandlerSafe req site app is
case res of
Left err -> do
error $ T.unpack err
Right response -> do
case rspStatus response of
404 -> return NotFound
200 -> do
body <- liftIO $ getResponseBody response
return $ Html $ T.decodeUtf8 body
_ -> if (rspStatus response) >= 300 && (rspStatus response) < 400
then do let url = fromMaybe "" $ getHeader "Location" response
return (Redirect (rspStatus response) (T.decodeUtf8 url))
else return (Other (rspStatus response))
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 (T.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 (T.pack $ show e))