hspec-snap 0.2.0.0 → 0.3.0.0

raw patch · 4 files changed

+283/−56 lines, 4 filesdep ~hspec-snapPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: hspec-snap

API changes (from Hackage documentation)

Files

• CHANGELOG +9/−0
• hspec-snap.cabal +6/−3
• spec/Main.hs +113/−21
• src/Test/Hspec/Snap.hs +155/−32

@@ -1,1 +1,10 @@+0.3.0.0 - 2014-10-18 - Add support for factories, and no longer export `afterAll`.+	A more correct implementation of `afterAll` is currently in hspec2+	HEAD, and will be released soon (and we don't want to have to do+	another major version when it does).++0.2.0.0 - 2014-9-24 - Change order of parameters in predicates that take two arguments+	to make pattern of `get req >>= shouldHaveProp foo` work (vs needing to call `flip`).+	And add more predicates.+ 0.1.0.0 - 2014-9-3 - Initial release.

@@ -1,15 +1,18 @@ name:                hspec-snap-version:             0.2.0.0+version:             0.3.0.0 synopsis:            A library for testing with Hspec and the Snap Web Framework homepage:            https://github.com/dbp/hspec-snap license:             BSD3 license-file:        LICENSE author:              Daniel Patterson maintainer:          dbp@dbpmail.net-extra-source-files: CHANGELOG+extra-source-files:  CHANGELOG category:            Web, Snap build-type:          Simple cabal-version:       >=1.8+source-repository head+  type:     git+  location: https://github.com/dbp/hspec-snap  library   exposed-modules:@@ -47,4 +50,4 @@                      , snap-core >= 0.9 && < 0.10                      , text >= 0.11 && < 1.2                      , transformers >= 0.3 && < 0.4-    build-depends: hspec-snap == 0.2.0.0+    build-depends: hspec-snap == 0.3.0.0

@@ -1,4 +1,5 @@ {-# LANGUAGE GADTs                     #-}+{-# LANGUAGE MultiParamTypeClasses     #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings         #-} {-# LANGUAGE TemplateHaskell           #-}@@ -9,32 +10,70 @@ ---------------------------------------------------------- -- Section 0: Imports.                                  -- -----------------------------------------------------------import           Control.Applicative     ((<$>), (<*>))+import           Control.Applicative                         ((<$>), (<*>))+import           Control.Concurrent.MVar                     (MVar, isEmptyMVar,+                                                              newEmptyMVar,+                                                              newMVar, putMVar,+                                                              takeMVar,+                                                              tryPutMVar,+                                                              tryTakeMVar) import           Control.Lens-import           Data.ByteString         (ByteString)-import qualified Data.Map                as M-import           Data.Maybe              (fromMaybe)-import           Data.Text               (Text)-import qualified Data.Text               as T-import           Snap                    (Handler, Method (..), SnapletInit,-                                          addRoutes, getParam, liftIO,-                                          makeSnaplet, method, route, void,-                                          writeBS, writeText)+import           Control.Monad                               (when)+import           Data.ByteString                             (ByteString)+import           Data.Map                                    (Map)+import qualified Data.Map                                    as M+import           Data.Maybe                                  (fromMaybe)+import           Data.Text                                   (Text)+import qualified Data.Text                                   as T+import qualified Data.Text.Encoding                          as T+import           Snap                                        (Handler,+                                                              Method (..),+                                                              Snaplet,+                                                              SnapletInit,+                                                              addRoutes,+                                                              getParam, liftIO,+                                                              makeSnaplet,+                                                              method,+                                                              nestSnaplet,+                                                              route, void, with,+                                                              writeBS,+                                                              writeText) import qualified Snap+import           Snap.Snaplet.Session+import           Snap.Snaplet.Session.Backends.CookieSession+import           System.Directory                            (doesFileExist,+                                                              removeFile)+import           System.IO import           Text.Digestive -import           Control.Concurrent.MVar (MVar, isEmptyMVar, newEmptyMVar,-                                          tryPutMVar, tryTakeMVar) import           Test.Hspec import           Test.Hspec.Snap  ---------------------------------------------------------- -- Section 1: Example application used for testing.     -- -----------------------------------------------------------data App = App { _mv :: MVar () }+data Foo = Foo Int String String+data App = App { _mv :: MVar (), _store :: MVar (Map Int Foo), _sess :: Snaplet SessionManager }  makeLenses ''App +newFoo :: String -> String -> Handler App App Foo+newFoo s1 s2 = do smvar <- use store+                  mp <- liftIO $ takeMVar smvar+                  let i = 1 + M.size mp+                  let foo = Foo i s1 s2+                  liftIO $ putMVar smvar (M.insert i foo mp)+                  return foo++lookupFoo :: Int -> Handler App App (Maybe Foo)+lookupFoo i = do smvar <- use store+                 mp <- liftIO $ takeMVar smvar+                 liftIO $ putMVar smvar mp+                 return (M.lookup i mp)++instance HasSession App where+  getSessionLens = sess+ html :: Text html = "<table><tr><td>One</td><td>Two</td></tr></table>" @@ -52,21 +91,37 @@          ,("/setmv", do m <- use mv                         void $ liftIO $ tryPutMVar m ()                         return ())+         ,("/setsess/:k", do Just k <- fmap T.decodeUtf8 <$> getParam "k"+                             with sess $ setInSession k "bar" >> commitSession+                             writeText "")+         ,("/getsess/:k", do Just k <- fmap T.decodeUtf8 <$> getParam "k"+                             Just r <- with sess $ getFromSession k+                             writeText r)          ] -app :: MVar () -> SnapletInit App App-app mvar = makeSnaplet "app" "An snaplet example application." Nothing $ do-         addRoutes routes-         return (App mvar)+app :: MVar (Map Int Foo) -> MVar () -> SnapletInit App App+app state mvar = makeSnaplet "app" "An snaplet example application." Nothing $ do+   addRoutes routes+   s <- nestSnaplet "sess" sess $ initCookieSessionManager "site_key.txt" "sess" (Just 3600)+   Snap.onUnload (do e <- doesFileExist "site_key.txt"+                     when e $ removeFile "site_key.txt")+   return (App mvar state s)   ---------------------------------------------------------- -- Section 2: Test suite against application.           -- ---------------------------------------------------------- -tests :: MVar () -> Spec-tests mvar =-  snap (route routes) (app mvar) $ do+newtype FooFields = FooFields (IO String)++instance Factory App Foo FooFields where+  fields = FooFields (return "default")+  save (FooFields as) = do s <- liftIO as+                           eval (newFoo s "const")++tests :: MVar (Map Int Foo) -> MVar () -> Spec+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"@@ -116,6 +171,42 @@         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")])+    describe "sessions" $ do+      it "should be able to modify session in handlers" $+        recordSession $ do get "/setsess/4"+                           sessionShouldContain "4"+                           sessionShouldContain "bar"+      it "should be able to modify session with eval" $+        recordSession $ do eval (with sess $ setInSession "foozlo" "bar" >> commitSession)+                           sessionShouldContain "foozlo"+                           sessionShouldContain "bar"+      it "should be able to persist sessions between requests" $+        recordSession $ do 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"+                           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)+                           eval (with sess $ getFromSession "foofoo" ) >>= shouldEqual (Just "bar")+      it "should be able to remove stuff from session" $+        recordSession $ do eval (with sess $ setInSession "foobar" "baz" >> commitSession)+                           sessionShouldContain "foobar"+                           eval (with sess $ deleteFromSession "foobar" >> commitSession)+                           sessionShouldNotContain "foobar"+    describe "factories" $ do+      it "should be able to generate a foo" $+        do (Foo i _ _) <- create id+           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!"   ----------------------------------------------------------@@ -124,4 +215,5 @@ main :: IO () main = do   mvar <- newEmptyMVar-  hspec (tests mvar)+  store <- newMVar M.empty+  hspec (tests store mvar)

@@ -1,9 +1,13 @@-{-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE OverloadedStrings    #-}-{-# LANGUAGE ScopedTypeVariables  #-}-{-# LANGUAGE TupleSections        #-}-{-# LANGUAGE TypeFamilies         #-}-{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE OverloadedStrings      #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE TupleSections          #-}+{-# LANGUAGE TypeFamilies           #-}+{-# LANGUAGE TypeSynonymInstances   #-}  module Test.Hspec.Snap (   -- * Running blocks of hspec-snap tests@@ -17,8 +21,8 @@   , TestResponse(..)   , SnapHspecM -  -- * General Hspec helpers-  , afterAll+  -- * Factory style test data generation+  , Factory(..)    -- * Requests   , get@@ -29,6 +33,12 @@   -- * Helpers for dealing with TestResponses   , restrictResponse +  -- * Dealing with session state (EXPERIMENTAL)+  , recordSession+  , HasSession(..)+  , sessionShouldContain+  , sessionShouldNotContain+   -- * Evaluating application code   , eval @@ -66,9 +76,10 @@   , evalHandlerSafe   ) where -import           Control.Applicative     ((<$>))-import           Control.Concurrent.MVar (modifyMVar, newEmptyMVar, newMVar,-                                          putMVar, takeMVar)+import           Control.Applicative     ((<$>), (<|>))+import           Control.Concurrent.MVar (MVar, modifyMVar, newEmptyMVar,+                                          newMVar, putMVar, readMVar, takeMVar,+                                          tryTakeMVar) import           Control.Exception       (SomeException, catch) import           Control.Monad           (void) import           Control.Monad.State     (StateT (..), runStateT)@@ -82,7 +93,11 @@ 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            (Handler, Snaplet, SnapletInit,+                                          SnapletLens, with)+import           Snap.Snaplet.Session    (SessionManager, commitSession,+                                          sessionToList, setInSession,+                                          withSession) import           Snap.Snaplet.Test       (InitializerState, closeSnaplet,                                           evalHandler', getSnaplet, runHandler') import           Snap.Test               (RequestBuilder, getResponseBody)@@ -104,17 +119,59 @@ type SnapHspecM b = StateT (SnapHspecState b) IO  -- | Internal state used to share site initialization across tests, and to propogate failures.-data SnapHspecState b = SnapHspecState Result (Handler b b ()) (Snaplet b) (InitializerState b)+-- Understanding it is completely unnecessary to use the library.+--+-- The fields it contains, in order, are:+--+-- > Result+-- > Main handler+-- > Startup state+-- > Startup state+-- > Session state+-- > Before handler (runs before each eval)+-- > After handler (runs after each eval).+data SnapHspecState b = SnapHspecState Result+                                       (Handler b b ())+                                       (Snaplet b)+                                       (InitializerState b)+                                       (MVar [(Text, Text)])+                                       (Handler b b ())+                                       (Handler b 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'+       cb $ \st@(SnapHspecState _ _ _ _ _ _ _) ->+              do ((),(SnapHspecState r' _ _ _ _ _ _)) <- runStateT s st+                 putMVar mv r'        takeMVar mv +-- | Factory instances allow you to easily generate test data.+--+-- Essentially, you specify a default way of constructing a+-- data type, and allow certain parts of it to be modified (via+-- the 'fields' data structure).+--+-- An example follows:+--+-- > data Foo = Foo Int+-- > newtype FooFields = FooFields (IO Int)+-- > instance Factory App Foo FooFields where+-- >   fields = randomIO+-- >   save f = liftIO f >>= saveFoo . Foo1+-- >+-- > main = do create id :: SnapHspecM App Foo+-- >           create (const $ FooFields (return 1)) :: SnapHspecM App Foo+class Factory b a d | a -> b, a -> d, d -> a where+  fields :: d+  save :: d -> SnapHspecM b a+  create :: (d -> d) -> SnapHspecM b a+  create transform = save $ transform fields+  reload :: a -> SnapHspecM b a+  reload = return+ -- | 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@@ -169,11 +226,12 @@ snap :: Handler b b () -> SnapletInit b b -> SpecWith (SnapHspecState b) -> Spec snap site app spec = do   snapinit <- runIO $ getSnaplet (Just "test") app+  mv <- runIO (newMVar [])   case snapinit of     Left err -> error $ show err     Right (snaplet, initstate) -> do       afterAll (closeSnaplet initstate) $-        before (return (SnapHspecState Success site snaplet initstate)) spec+        before (return (SnapHspecState Success site snaplet initstate mv (return ()) (return ()))) spec  -- | This allows you to change the default handler you are running -- requests against within a block. This is most likely useful for@@ -181,8 +239,8 @@ 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 f = beforeWith (\(SnapHspecState r site snaplet initst sess bef aft) ->+                             return (SnapHspecState r (f site) snaplet initst sess bef aft))  -- | This performs a similar operation to `modifySite` but in the context -- of `SnapHspecM` (which is needed if you need to `eval`, produce values, and@@ -190,19 +248,63 @@ 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)+modifySite' f a = do (SnapHspecState r site s i sess bef aft) <- S.get+                     S.put (SnapHspecState r (f site) s i sess bef aft)                      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)+afterEval h = after (\(SnapHspecState r site s i _ _ _) ->+                       do res <- evalHandlerSafe h s i+                          case res of+                            Right _ -> return ()+                            Left msg -> liftIO $ print msg)  -- | 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+     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+                                 liftIO $ putMVar mv ps'))+     res <- a+     (SnapHspecState r' _ _ _ _ _ _) <- S.get+     liftIO $ takeMVar mv+     liftIO $ putMVar mv []+     S.put (SnapHspecState r' site s i mv bef aft)+     return res++sessionShouldContain :: Text -> SnapHspecM b ()+sessionShouldContain t =+  do (SnapHspecState _ _ _ _ mv _ _) <- S.get+     ps <- liftIO $ readMVar mv+     let contents = T.concat (map (uncurry T.append) ps)+     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))++sessionShouldNotContain :: Text -> SnapHspecM b ()+sessionShouldNotContain t =+  do (SnapHspecState _ _ _ _ mv _ _) <- S.get+     ps <- liftIO $ readMVar mv+     let contents = T.concat (map (uncurry T.append) ps)+     if t `T.isInfixOf` contents+       then setResult (Fail $ "Session should not have contained: " ++ (T.unpack t)+                            ++ "\n\nSession was:\n" ++ (T.unpack contents))+       else setResult Success+ -- | Runs a GET request. get :: Text -> SnapHspecM b TestResponse get path = get' path M.empty@@ -231,16 +333,19 @@  -- | Runs an arbitrary stateful action from your application. 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+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   -- | Records a test Success or Fail. Only the first Fail will be -- recorded (and will cause the whole block to Fail). setResult :: Result -> SnapHspecM b ()-setResult r = do (SnapHspecState r' s a i) <- S.get+setResult r = do (SnapHspecState r' s a i sess bef aft) <- S.get                  case r' of-                   Success -> S.put (SnapHspecState r s a i)+                   Success -> S.put (SnapHspecState r s a i sess bef aft)                    _ -> return ()  -- | Asserts that a given stateful action will produce a specific different result after@@ -389,11 +494,29 @@   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)))+       Predicate f ->+         case snd r of+           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)))        ErrorPaths expectedPaths ->          do let viewErrorPaths = map (DF.fromPath . fst) $ DF.viewErrors $ fst r-            shouldBeTrue (all (`elem` viewErrorPaths) expectedPaths-                          && (length viewErrorPaths == length expectedPaths))+            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)+                                            ++ "\n\nBut expected:\n\n"+                                            ++ (show expectedPaths))+               else setResult (Fail $ "Did not have all errors specified. Got:\n\n"+                                    ++ (show viewErrorPaths)+                                    ++ "\n\nBut expected:\n\n"+                                    ++ (show expectedPaths))   where lookupParam pth = case M.lookup (DF.fromPath pth) fixedParams of                             Nothing -> return []                             Just v -> return [DF.TextInput v]@@ -402,8 +525,8 @@ -- | Runs a request (built with helpers from Snap.Test), resulting in a response. runRequest :: RequestBuilder IO () -> SnapHspecM b TestResponse runRequest req = do-  (SnapHspecState _ site app is) <- S.get-  res <- liftIO $ runHandlerSafe req site app is+  (SnapHspecState _ site app is _ bef aft) <- S.get+  res <- liftIO $ runHandlerSafe req (bef >> site >> aft) app is   case res of     Left err -> do       error $ T.unpack err