diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -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. 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.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 diff --git a/spec/Main.hs b/spec/Main.hs --- a/spec/Main.hs +++ b/spec/Main.hs @@ -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 = "
OneTwo
" 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 on PUT request" $ put "/test" M.empty >>= shouldNotHaveText "" 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) diff --git a/spec/Utils.hs b/spec/Utils.hs --- a/spec/Utils.hs +++ b/spec/Utils.hs @@ -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 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 @@ -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) #-}