diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -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. diff --git a/hspec-snap.cabal b/hspec-snap.cabal --- a/hspec-snap.cabal +++ b/hspec-snap.cabal @@ -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 diff --git a/spec/Main.hs b/spec/Main.hs --- a/spec/Main.hs +++ b/spec/Main.hs @@ -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 = "
OneTwo
" @@ -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) 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 @@ -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