diff --git a/hspec-snap.cabal b/hspec-snap.cabal --- a/hspec-snap.cabal +++ b/hspec-snap.cabal @@ -1,5 +1,5 @@ name: hspec-snap -version: 0.1.0.0 +version: 0.2.0.0 synopsis: A library for testing with Hspec and the Snap Web Framework homepage: https://github.com/dbp/hspec-snap license: BSD3 @@ -47,4 +47,4 @@ , snap-core >= 0.9 && < 0.10 , text >= 0.11 && < 1.2 , transformers >= 0.3 && < 0.4 - build-depends: hspec-snap == 0.1.0.0 + build-depends: hspec-snap == 0.2.0.0 diff --git a/spec/Main.hs b/spec/Main.hs --- a/spec/Main.hs +++ b/spec/Main.hs @@ -70,15 +70,15 @@ describe "requests" $ do it "should match selector from a GET request" $ do p <- get "/test" - p `shouldHaveSelector` "table td" - p `shouldNotHaveSelector` "table td.doesntexist" - get "/redirect" >>= flip shouldNotHaveSelector "table td.doesntexist" - get "/invalid_url" >>= flip shouldNotHaveSelector "table td.doesntexist" + shouldHaveSelector "table td" p + shouldNotHaveSelector "table td.doesntexist" p + get "/redirect" >>= shouldNotHaveSelector "table td.doesntexist" + get "/invalid_url" >>= shouldNotHaveSelector "table td.doesntexist" it "should not match on POST request" $ - post "/test" M.empty >>= flip shouldNotHaveText "" + post "/test" M.empty >>= shouldNotHaveText "" it "should post parameters" $ do - post "/params" (params [("q", "hello")]) >>= flip shouldHaveText "hello" - post "/params" (params [("r", "hello")]) >>= flip shouldNotHaveText "hello" + post "/params" (params [("q", "hello")]) >>= shouldHaveText "hello" + post "/params" (params [("r", "hello")]) >>= shouldNotHaveText "hello" it "basic equality" $ do eval (return 1) >>= shouldEqual 1 shouldNotEqual 1 2 @@ -114,6 +114,8 @@ form (ErrorPaths ["a"]) testForm (M.fromList [("a", ""), ("b", "bar")]) form (ErrorPaths ["a"]) testForm (M.fromList [("b", "bar")]) form (ErrorPaths ["a"]) testForm (M.fromList []) + it "should call predicates on valid data" $ do + form (Predicate (("oo" `T.isInfixOf`) . fst)) testForm (M.fromList [("a", "foobar")]) ---------------------------------------------------------- diff --git a/src/Test/Hspec/Snap.hs b/src/Test/Hspec/Snap.hs --- a/src/Test/Hspec/Snap.hs +++ b/src/Test/Hspec/Snap.hs @@ -8,6 +8,10 @@ module Test.Hspec.Snap ( -- * Running blocks of hspec-snap tests snap + , modifySite + , modifySite' + , afterEval + , beforeEval -- * Core data types , TestResponse(..) @@ -22,10 +26,14 @@ , post , params + -- * Helpers for dealing with TestResponses + , restrictResponse + -- * Evaluating application code , eval -- * Unit test assertions + , shouldChange , shouldEqual , shouldNotEqual , shouldBeTrue @@ -62,12 +70,13 @@ 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 (fromMaybe) +import Data.Maybe (fromJust, fromMaybe, isJust) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -107,6 +116,11 @@ takeMVar mv -- | Runs a given action once after all the tests in the given block have run. +-- +-- __Warning__: Due to current limitations to how Hspec works, this only works +-- if all of the tests within the block are run. This means that +-- if you only run some of the tests (using the @-m@ option) the action will +-- not be run. afterAll :: IO () -> SpecWith a -> SpecWith a afterAll action = go where go spec = do forest <- runIO $ runSpecM spec @@ -136,6 +150,22 @@ -- suite can have multiple calls to `snap`, though each one will cause -- the site initializer to run, which is often a slow operation (and -- will slow down test suites). +-- +-- __Warning__: Due to current limitations to how Hspec works, the way +-- that we run cleanup actions (using `afterAll`) from your site initializer depends on /all/ +-- of the tests within the block passed to `snap` running. This means that +-- if you only run some of the tests (using the @-m@ option) the cleanup +-- won't happen. But, there is no reason why you can't have many calls to +-- `snap`, so the recommended behavior is to only use @-m@ with queries +-- that will run entire blocks. For example: +-- +-- > describe "api-tests" $ snap ... +-- > describe "db-tests" $ snap ... +-- +-- And then run with @-m api-tests@ or @-m db-tests@, rather than trying +-- to match anything within. Hopefully, hspec will eventually be able to support +-- what we need in such a way that filtering on any query won't prevent the +-- cleanup from running. snap :: Handler b b () -> SnapletInit b b -> SpecWith (SnapHspecState b) -> Spec snap site app spec = do snapinit <- runIO $ getSnaplet (Just "test") app @@ -145,6 +175,34 @@ afterAll (closeSnaplet initstate) $ before (return (SnapHspecState Success site snaplet initstate)) spec +-- | This allows you to change the default handler you are running +-- requests against within a block. This is most likely useful for +-- setting request state (for example, logging a user in). +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)) + +-- | This performs a similar operation to `modifySite` but in the context +-- of `SnapHspecM` (which is needed if you need to `eval`, produce values, and +-- hand them somewhere else (so they can't be created within `f`). +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 + +-- | Evaluate a Handler action after each test. +afterEval :: Handler b b () -> SpecWith (SnapHspecState b) -> SpecWith (SnapHspecState b) +afterEval h = after (\(SnapHspecState r site s i) -> void $ evalHandlerSafe h s i) + +-- | Evaluate a Handler action before each test. +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) + -- | Runs a GET request. get :: Text -> SnapHspecM b TestResponse get path = get' path M.empty @@ -162,6 +220,15 @@ post :: Text -> Snap.Params -> SnapHspecM b TestResponse post path ps = runRequest (Test.postUrlEncoded (T.encodeUtf8 path) ps) +-- | Restricts a response to matches for a given CSS selector. +-- Does nothing to non-Html responses. +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 + -- | Runs an arbitrary stateful action from your application. eval :: Handler b b a -> SnapHspecM b a eval act = do (SnapHspecState _ _ app is) <- S.get @@ -176,6 +243,19 @@ Success -> S.put (SnapHspecState r s a i) _ -> return () +-- | Asserts that a given stateful action will produce a specific different result after +-- an action has been run. +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' + + -- | Asserts that two values are equal. shouldEqual :: (Show a, Eq a) => a @@ -252,41 +332,41 @@ shouldNot300To _ _ = setResult Success -- | Assert that a response (which should be Html) has a given selector. -shouldHaveSelector :: TestResponse -> Text -> SnapHspecM b () -shouldHaveSelector r@(Html body) selector = - setResult $ if haveSelector' r selector +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])) +shouldHaveSelector match _ = setResult (Fail (T.unpack $ T.concat ["Non-HTML body should have contained css selector: ", match])) -- | Assert that a response (which should be Html) doesn't have a given selector. -shouldNotHaveSelector :: TestResponse -> Text -> SnapHspecM b () -shouldNotHaveSelector r@(Html body) selector = - setResult $ if haveSelector' r selector +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' :: TestResponse -> Text -> Bool -haveSelector' (Html body) selector = +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 -- | Asserts that the response (which should be Html) contains the given text. -shouldHaveText :: TestResponse -> Text -> SnapHspecM b () -shouldHaveText (Html body) match = +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])) +shouldHaveText match _ = setResult (Fail (T.unpack $ T.concat ["Body contains: ", match])) -- | Asserts that the response (which should be Html) does not contain the given text. -shouldNotHaveText :: TestResponse -> Text -> SnapHspecM b () -shouldNotHaveText (Html body) 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 @@ -295,6 +375,7 @@ -- | A data type for tests against forms. data FormExpectations a = Value a -- ^ The value the form should take (and should be valid) + | Predicate (a -> Bool) | ErrorPaths [Text] -- ^ The error paths that should be populated -- | Tests against digestive-functors forms. @@ -308,6 +389,7 @@ 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