hspec-snap 0.3.2.9 → 0.3.3.0
raw patch · 5 files changed
+107/−84 lines, 5 filesdep ~aesondep ~hspec-snapPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: aeson, hspec-snap
API changes (from Hackage documentation)
+ Test.Hspec.Snap: postJson :: ToJSON tj => Text -> tj -> SnapHspecM b TestResponse
- Test.Hspec.Snap: shouldChange :: (Show a, Eq a) => (a -> a) -> (Handler b b a) -> SnapHspecM b c -> SnapHspecM b ()
+ Test.Hspec.Snap: shouldChange :: (Show a, Eq a) => (a -> a) -> Handler b b a -> SnapHspecM b c -> SnapHspecM b ()
Files
- CHANGELOG +2/−0
- hspec-snap.cabal +4/−3
- spec/Main.hs +29/−21
- spec/Utils.hs +7/−4
- src/Test/Hspec/Snap.hs +65/−56
CHANGELOG view
@@ -1,3 +1,5 @@+0.3.3.0 - 2015-6-5 - Add postJson helper.+ 0.3.2.9 - 2015-5-22 - Typo in previous release (dependency in test suite was wrong). 0.3.2.8 - 2015-5-22 - Add spec/Utils.hs to other-modules so it is included in cabal sdist.
hspec-snap.cabal view
@@ -1,5 +1,5 @@ name: hspec-snap-version: 0.3.2.9+version: 0.3.3.0 synopsis: A library for testing with Hspec and the Snap Web Framework homepage: https://github.com/dbp/hspec-snap license: BSD3@@ -19,6 +19,7 @@ Test.Hspec.Snap hs-source-dirs: src build-depends: base >= 4.6 && < 4.9+ , aeson >= 0.6 && < 1 , bytestring >= 0.9 && < 0.11 , containers >= 0.4 && < 0.6 , digestive-functors >= 0.7 && < 0.9@@ -40,7 +41,7 @@ main-is: Main.hs other-modules: Utils build-depends: base >= 4.6 && < 4.9- , aeson >= 0.6 && < 0.8.1+ , aeson >= 0.6 && < 1 , bytestring >= 0.9 && < 0.11 , containers >= 0.4 && < 0.6 , digestive-functors >= 0.7 && < 0.9@@ -55,4 +56,4 @@ , text >= 0.11 && < 1.3 , transformers >= 0.3 && < 0.5 , directory >= 1.2 && < 1.3- build-depends: hspec-snap == 0.3.2.9+ build-depends: hspec-snap == 0.3.3.0
spec/Main.hs view
@@ -51,13 +51,13 @@ import Snap.Snaplet.Session.Backends.CookieSession import System.Directory (doesFileExist, removeFile)-import System.IO import Text.Digestive import Test.Hspec import Test.Hspec.Snap -import Utils (writeJSON)+import Utils (writeJSON+ ,parseJsonBody) ---------------------------------------------------------- -- Section 1: Example application used for testing. --@@ -88,7 +88,7 @@ html = "<html><table><tr><td>One</td><td>Two</td></tr></table></html>" testForm :: Form Text (Handler App App) (Text, Text)-testForm = (,) <$> "a" .: check "Should not be empty" (\t -> not $ T.null t) (text Nothing)+testForm = (,) <$> "a" .: check "Should not be empty" (not . T.null) (text Nothing) <*> "b" .: text Nothing data ExampleObject = ExampleObject Integer Text deriving (Show, Eq)@@ -101,7 +101,7 @@ instance FromJSON ExampleObject where parseJSON (Object o) = ExampleObject <$> o Ae..: "aNumber" <*> o Ae..: "aString"- parseJSON _ = fail $ "Expected ExampleObject as JSON object"+ parseJSON _ = fail "Expected ExampleObject as JSON object" exampleObj :: ExampleObject exampleObj = ExampleObject 42 "foo"@@ -131,7 +131,12 @@ ,("/getsess/:k", do Just k <- fmap T.decodeUtf8 <$> getParam "k" Just r <- with sess $ getFromSession k writeText r)- ,("/json", writeJSON $ exampleObj)+ ,("/json", writeJSON exampleObj)+ ,("/postJson", do+ Just (ExampleObject i t) <- parseJsonBody+ writeJSON $ ExampleObject (i + 1)+ (t `T.append` "!")+ ) ] app :: MVar (Map Int Foo) -> MVar () -> SnapletInit App App@@ -155,8 +160,8 @@ eval (newFoo s "const") tests :: MVar (Map Int Foo) -> MVar () -> Spec-tests store mvar =- snap (route routes) (app store mvar) $ do+tests store' mvar =+ snap (route routes) (app store' mvar) $ do describe "requests" $ do it "should match selector from a GET request" $ do p <- get "/test"@@ -171,14 +176,17 @@ it "should post parameters" $ do post "/params" (params [("q", "hello")]) >>= shouldHaveText "POST hello" post "/params" (params [("r", "hello")]) >>= shouldNotHaveText "hello"+ it "should post json" $ do+ Json raw <- postJson "/postJson" exampleObj+ Just (ExampleObject 43 "foo!") `shouldEqual` decode raw it "should not match <html> on PUT request" $ put "/test" M.empty >>= shouldNotHaveText "<html>" it "should put parameters" $ do put "/params" (params [("q", "hello")]) >>= shouldHaveText "PUT hello" put "/params" (params [("r", "hello")]) >>= shouldNotHaveText "hello" it "basic equality" $ do- eval (return 1) >>= shouldEqual 1- shouldNotEqual 1 2+ eval (return 1) >>= shouldEqual (1::Integer)+ shouldNotEqual 1 (2::Integer) it "status code 200" $ do get "/test" >>= should200 get "/invalid_url" >>= shouldNot200@@ -202,9 +210,9 @@ after (\_ -> void $ tryTakeMVar mvar) $ it "should reflect stateful in handler" $ do eval isE >>= shouldEqual True- post "/setmv" M.empty+ void $ post "/setmv" M.empty eval isE >>= shouldEqual False- post "/setmv" M.empty+ void $ post "/setmv" M.empty eval isE >>= shouldEqual False eval (use mv >>= \m -> void $ liftIO $ tryTakeMVar m) it "cleans up" $ eval isE >>= shouldEqual True@@ -216,11 +224,11 @@ 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+ it "should call predicates on valid data" $ form (Predicate (("oo" `T.isInfixOf`) . fst)) testForm (M.fromList [("a", "foobar")]) describe "sessions" $ do it "should be able to modify session in handlers" $- recordSession $ do get "/setsess/4"+ recordSession $ do void $ get "/setsess/4" sessionShouldContain "4" sessionShouldContain "bar" it "should be able to modify session with eval" $@@ -228,13 +236,13 @@ sessionShouldContain "foozlo" sessionShouldContain "bar" it "should be able to persist sessions between requests" $- recordSession $ do get "/setsess/3"+ recordSession $ do void $ get "/setsess/3" get "/getsess/3" >>= shouldHaveText "bar" it "should be able to persist sessions between eval and requests" $ recordSession $ do eval (with sess $ setInSession "2" "bar" >> commitSession) get "/getsess/2" >>= shouldHaveText "bar" it "should be able to persist sessions between requests and eval" $- recordSession $ do get "/setsess/1"+ recordSession $ do void $ get "/setsess/1" eval (with sess $ getFromSession "1" ) >>= shouldEqual (Just "bar") it "should be able to persist sessions between eval and eval" $ recordSession $ do eval (with sess $ setInSession "foofoo" "bar" >> commitSession)@@ -250,10 +258,10 @@ Just (Foo _ _ s) <- eval (lookupFoo i) s `shouldEqual` "const" it "should be able to modify defaulted values" $- do (Foo _ s _) <- create (\_ -> FooFields (return "Hi!"))- s `shouldEqual` "Hi!"- (Foo _ s _) <- create id- s `shouldNotEqual` "Hi!"+ do (Foo _ s' _) <- create (\_ -> FooFields (return "Hi!"))+ s' `shouldEqual` "Hi!"+ (Foo _ s'' _) <- create id+ s'' `shouldNotEqual` "Hi!" ----------------------------------------------------------@@ -262,5 +270,5 @@ main :: IO () main = do mvar <- newEmptyMVar- store <- newMVar M.empty- hspec (tests store mvar)+ store' <- newMVar M.empty+ hspec (tests store' mvar)
spec/Utils.hs view
@@ -4,15 +4,18 @@ Module : Utils Description : Helpers for testing -Currently just copypasta from snap-extras to avoid dependency conflicts -} module Utils where -import Data.Aeson (encode, ToJSON)+import Data.Aeson (decode, encode, FromJSON, ToJSON)+import Control.Applicative ((<$>)) -import Snap.Core (modifyResponse, setHeader, writeLBS- ,MonadSnap)+import Snap.Core (modifyResponse, readRequestBody+ ,setHeader, writeLBS ,MonadSnap) +-- | Attempts to parse JSON from a request body of max 1MiB+parseJsonBody :: (MonadSnap m, FromJSON fj) => m (Maybe fj)+parseJsonBody = decode <$> readRequestBody 1048576 ------------------------------------------------------------------------------- -- | Set MIME to 'application/json' and write given object into
src/Test/Hspec/Snap.hs view
@@ -29,6 +29,7 @@ , get , get' , post+ , postJson , put , put' , params@@ -79,20 +80,21 @@ , evalHandlerSafe ) where -import Control.Applicative ((<$>), (<|>))-import Control.Concurrent.MVar (MVar, modifyMVar, newEmptyMVar,- newMVar, putMVar, readMVar, takeMVar,- tryTakeMVar)+import Control.Applicative ((<$>))+import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar+ ,putMVar, readMVar, 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.Aeson (encode, ToJSON) import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as LBS (ByteString)-import Data.ByteString.Lazy (fromStrict)+import Data.ByteString.Lazy (fromStrict, toStrict) import qualified Data.Map as M-import Data.Maybe (fromJust, fromMaybe, isJust)+import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T@@ -101,14 +103,12 @@ import Snap.Snaplet (Handler, Snaplet, SnapletInit, SnapletLens, with) import Snap.Snaplet.Session (SessionManager, commitSession,- sessionToList, setInSession,- withSession)+ sessionToList, setInSession) 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 (afterAll) import Test.Hspec.Core.Spec import qualified Text.Digestive as DF import qualified Text.HandsomeSoup as HS@@ -155,9 +155,8 @@ type Arg (SnapHspecM b ()) = SnapHspecState b evaluateExample s _ cb _ = do mv <- newEmptyMVar- cb $ \st@(SnapHspecState _ _ _ _ _ _ _) ->- do ((),(SnapHspecState r' _ _ _ _ _ _)) <- runStateT s st- putMVar mv r'+ cb $ \st -> do ((),SnapHspecState r' _ _ _ _ _ _) <- runStateT s st+ putMVar mv r' takeMVar mv -- | Factory instances allow you to easily generate test data.@@ -198,7 +197,7 @@ mv <- runIO (newMVar []) case snapinit of Left err -> error $ show err- Right (snaplet, initstate) -> do+ Right (snaplet, initstate) -> afterAll (const $ closeSnaplet initstate) $ before (return (SnapHspecState Success site snaplet initstate mv (return ()) (return ()))) spec @@ -223,7 +222,7 @@ -- | 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 _ _ _) ->+afterEval h = after (\(SnapHspecState _r _site s i _ _ _) -> do res <- evalHandlerSafe h s i case res of Right _ -> return ()@@ -231,47 +230,49 @@ -- | 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)+beforeEval h = beforeWith (\state@(SnapHspecState _r _site s i _ _ _) -> do void $ evalHandlerSafe h s i+ return state) class HasSession b where getSessionLens :: SnapletLens b SessionManager recordSession :: HasSession b => SnapHspecM b a -> SnapHspecM b a recordSession a =- do st@(SnapHspecState r site s i mv bef aft) <- S.get+ do (SnapHspecState r site s i mv bef aft) <- S.get S.put (SnapHspecState r site s i mv (do ps <- liftIO $ readMVar mv with getSessionLens $ mapM_ (uncurry setInSession) ps with getSessionLens commitSession) (do ps' <- with getSessionLens sessionToList- liftIO $ takeMVar mv+ void . liftIO $ takeMVar mv liftIO $ putMVar mv ps')) res <- a (SnapHspecState r' _ _ _ _ _ _) <- S.get- liftIO $ takeMVar mv+ void . liftIO $ takeMVar mv liftIO $ putMVar mv [] S.put (SnapHspecState r' site s i mv bef aft) return res +sessContents :: SnapHspecM b Text+sessContents = do+ (SnapHspecState _ _ _ _ mv _ _) <- S.get+ ps <- liftIO $ readMVar mv+ return $ T.concat (map (uncurry T.append) ps)+ sessionShouldContain :: Text -> SnapHspecM b () sessionShouldContain t =- do (SnapHspecState _ _ _ _ mv _ _) <- S.get- ps <- liftIO $ readMVar mv- let contents = T.concat (map (uncurry T.append) ps)+ do contents <- sessContents if t `T.isInfixOf` contents then setResult Success- else setResult (Fail $ "Session did not contain: " ++ (T.unpack t)- ++ "\n\nSession was:\n" ++ (T.unpack contents))+ else setResult (Fail $ "Session did not contain: " ++ T.unpack t+ ++ "\n\nSession was:\n" ++ T.unpack contents) sessionShouldNotContain :: Text -> SnapHspecM b () sessionShouldNotContain t =- do (SnapHspecState _ _ _ _ mv _ _) <- S.get- ps <- liftIO $ readMVar mv- let contents = T.concat (map (uncurry T.append) ps)+ do contents <- sessContents if t `T.isInfixOf` contents- then setResult (Fail $ "Session should not have contained: " ++ (T.unpack t)- ++ "\n\nSession was:\n" ++ (T.unpack contents))+ then setResult (Fail $ "Session should not have contained: " ++ T.unpack t+ ++ "\n\nSession was:\n" ++ T.unpack contents) else setResult Success -- | Runs a DELETE request@@ -295,15 +296,21 @@ post :: Text -> Snap.Params -> SnapHspecM b TestResponse post path ps = runRequest (Test.postUrlEncoded (T.encodeUtf8 path) ps) +-- | Creates a new POST request with a given JSON value as the request body.+postJson :: ToJSON tj => Text -> tj -> SnapHspecM b TestResponse+postJson path json = runRequest $ Test.postRaw (T.encodeUtf8 path)+ "application/json"+ (toStrict $ encode json)+ -- | Creates a new PUT request, with a set of parameters, with a default type of "application/x-www-form-urlencoded" put :: Text -> Snap.Params -> SnapHspecM b TestResponse-put path params = put' path "application/x-www-form-urlencoded" params+put path params' = put' path "application/x-www-form-urlencoded" params' -- | Creates a new PUT request with a configurable MIME/type put' :: Text -> Text -> Snap.Params -> SnapHspecM b TestResponse-put' path mime params = runRequest $ do+put' path mime params' = runRequest $ do Test.put (T.encodeUtf8 path) (T.encodeUtf8 mime) ""- Test.setQueryString params+ Test.setQueryString params' -- | Restricts a response to matches for a given CSS selector. -- Does nothing to non-Html responses.@@ -316,11 +323,11 @@ -- | Runs an arbitrary stateful action from your application. eval :: Handler b b a -> SnapHspecM b a-eval act = do (SnapHspecState _ site app is mv bef aft) <- S.get- liftIO $ fmap (either (error . T.unpack) id) $ evalHandlerSafe (do bef- r <- act- aft- return r) app is+eval act = do (SnapHspecState _ _site app is _mv bef aft) <- S.get+ liftIO $ either (error . T.unpack) id <$> evalHandlerSafe (do bef+ r <- act+ aft+ return r) app is -- | Records a test Success or Fail. Only the first Fail will be@@ -335,11 +342,11 @@ -- an action has been run. shouldChange :: (Show a, Eq a) => (a -> a)- -> (Handler b b a)+ -> Handler b b a -> SnapHspecM b c -> SnapHspecM b () shouldChange f v act = do before' <- eval v- act+ void act after' <- eval v shouldEqual (f before') after' @@ -424,17 +431,17 @@ 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])+ 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])) -- | Assert that a response (which should be Html) doesn't have a given selector. shouldNotHaveSelector :: Text -> TestResponse -> SnapHspecM b () shouldNotHaveSelector selector r@(Html body) = setResult $ if haveSelector' selector r- then (Fail msg)+ then Fail msg else Success- where msg = (T.unpack $ T.concat ["Html should not have contained selector: ", selector, "\n\n", body])+ where msg = T.unpack $ T.concat ["Html should not have contained selector: ", selector, "\n\n", body] shouldNotHaveSelector _ _ = setResult Success haveSelector' :: Text -> TestResponse -> Bool@@ -482,24 +489,24 @@ Nothing -> setResult (Fail $ T.unpack $ T.append "Expected form to validate. Resulted in errors: " (T.pack (show $ DF.viewErrors $ fst r)))- Just v -> case f v of- True -> setResult Success- False -> setResult (Fail $ T.unpack $- T.append "Expected predicate to pass on value: "- (T.pack (show v)))+ Just v -> if f v+ then setResult Success+ else setResult (Fail $ T.unpack $+ T.append "Expected predicate to pass on value: "+ (T.pack (show v))) ErrorPaths expectedPaths -> do let viewErrorPaths = map (DF.fromPath . fst) $ DF.viewErrors $ fst r if all (`elem` viewErrorPaths) expectedPaths then if length viewErrorPaths == length expectedPaths then setResult Success else setResult (Fail $ "Number of errors did not match test. Got:\n\n "- ++ (show viewErrorPaths)+ ++ show viewErrorPaths ++ "\n\nBut expected:\n\n"- ++ (show expectedPaths))+ ++ show expectedPaths) else setResult (Fail $ "Did not have all errors specified. Got:\n\n"- ++ (show viewErrorPaths)+ ++ show viewErrorPaths ++ "\n\nBut expected:\n\n"- ++ (show expectedPaths))+ ++ show expectedPaths) where lookupParam pth = case M.lookup (DF.fromPath pth) fixedParams of Nothing -> return [] Just v -> return [DF.TextInput v]@@ -511,14 +518,14 @@ (SnapHspecState _ site app is _ bef aft) <- S.get res <- liftIO $ runHandlerSafe req (bef >> site >> aft) app is case res of- Left err -> do+ Left err -> error $ T.unpack err- Right response -> do+ Right response -> case rspStatus response of 404 -> return NotFound- 200 -> do+ 200 -> liftIO $ parse200 response- _ -> if (rspStatus response) >= 300 && (rspStatus response) < 400+ _ -> 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))@@ -549,3 +556,5 @@ -> 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))++{-# ANN put ("HLint: ignore Eta reduce"::String) #-}