diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2012-2015 Fujimura Daisuke, Simon Hengel +Copyright (c) 2012-2018 Fujimura Daisuke, Simon Hengel Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/hspec-wai.cabal b/hspec-wai.cabal --- a/hspec-wai.cabal +++ b/hspec-wai.cabal @@ -1,25 +1,25 @@ --- This file has been generated from package.yaml by hpack version 0.11.0. +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.39.1. -- -- see: https://github.com/sol/hpack name: hspec-wai -version: 0.6.6 +version: 0.12.0 homepage: https://github.com/hspec/hspec-wai#readme bug-reports: https://github.com/hspec/hspec-wai/issues license: MIT license-file: LICENSE copyright: (c) 2012-2014 Fujimura Daisuke, - (c) 2014-2015 Simon Hengel + (c) 2014-2018 Simon Hengel author: Fujimura Daisuke , Simon Hengel maintainer: Fujimura Daisuke , Simon Hengel build-type: Simple -cabal-version: >= 1.10 category: Testing synopsis: Experimental Hspec support for testing WAI applications description: Experimental Hspec support for testing WAI applications - extra-source-files: changelog @@ -32,25 +32,24 @@ src ghc-options: -Wall build-depends: - base == 4.* + QuickCheck + , base >=4.9.1.0 && <5 , base-compat - , bytestring >= 0.10 - , text - , transformers + , bytestring >=0.10 , case-insensitive + , hspec-core ==2.* + , hspec-expectations >=0.8.0 , http-types - , wai >= 3 - , wai-extra >= 3 - , hspec-core == 2.* - , hspec-expectations - , QuickCheck - , with-location >= 0.1.0 + , text + , transformers + , wai >=3 + , wai-extra >=3.1.14 exposed-modules: Test.Hspec.Wai Test.Hspec.Wai.QuickCheck Test.Hspec.Wai.Internal - other-modules: Test.Hspec.Wai.Matcher + other-modules: Test.Hspec.Wai.Util Paths_hspec_wai default-language: Haskell2010 @@ -60,24 +59,24 @@ main-is: Spec.hs hs-source-dirs: src - , test + test ghc-options: -Wall + build-tool-depends: + hspec-discover:hspec-discover build-depends: - base == 4.* + QuickCheck + , base >=4.9.1.0 && <5 , base-compat - , bytestring >= 0.10 - , text - , transformers + , bytestring >=0.10 , case-insensitive - , http-types - , wai >= 3 - , wai-extra >= 3 - , hspec-core == 2.* - , hspec-expectations - , QuickCheck - , with-location >= 0.1.0 , hspec - , QuickCheck + , hspec-core ==2.* + , hspec-expectations >=0.8.0 + , http-types + , text + , transformers + , wai >=3.2.2 + , wai-extra >=3.1.14 other-modules: Test.Hspec.Wai Test.Hspec.Wai.Internal @@ -87,4 +86,5 @@ Test.Hspec.Wai.MatcherSpec Test.Hspec.Wai.UtilSpec Test.Hspec.WaiSpec + Paths_hspec_wai default-language: Haskell2010 diff --git a/src/Test/Hspec/Wai.hs b/src/Test/Hspec/Wai.hs --- a/src/Test/Hspec/Wai.hs +++ b/src/Test/Hspec/Wai.hs @@ -1,5 +1,7 @@ +{-# LANGUAGE PackageImports #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} -- | Have a look at the for -- an example of how to use this library. module Test.Hspec.Wai ( @@ -21,46 +23,59 @@ -- * Matching on the response , shouldRespondWith + , ResponseMatcher(..) , MatchHeader(..) +, MatchBody(..) +, Body , (<:>) -- * Helpers and re-exports , liftIO , with +, withState +, getState , pending , pendingWith +, SResponse(..) ) where +import Prelude () +import "base-compat" Prelude.Compat + import Data.Foldable import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as LB import Control.Monad.IO.Class +import Control.Monad.Trans.Class (lift) import Network.Wai (Request(..)) import Network.HTTP.Types import Network.Wai.Test hiding (request) import qualified Network.Wai.Test as Wai -import Data.WithLocation +import Test.Hspec.Expectations import Test.Hspec.Core.Spec hiding (pending, pendingWith) import qualified Test.Hspec.Core.Spec as Core import Test.Hspec.Core.Hooks -import Test.Hspec.Expectations (expectationFailure) import Test.Hspec.Wai.Util import Test.Hspec.Wai.Internal import Test.Hspec.Wai.Matcher --- | An alias for `before`. -with :: IO a -> SpecWith a -> Spec -with = before +import Network.Wai (Application) +with :: IO Application -> SpecWith ((), Application) -> Spec +with action = before ((,) () <$> action) + +withState :: IO (st, Application) -> SpecWith (st, Application) -> Spec +withState = before + -- | A lifted version of `Core.pending`. -pending :: WaiSession () +pending :: WaiSession st () pending = liftIO Core.pending -- | A lifted version of `Core.pendingWith`. -pendingWith :: String -> WaiSession () +pendingWith :: String -> WaiSession st () pendingWith = liftIO . Core.pendingWith -- | Set the expectation that a response matches a specified `ResponseMatcher`. @@ -96,40 +111,40 @@ -- `matchHeaders`: -- -- > get "/" `shouldRespondWith` "foo" {matchHeaders = ["Content-Type" <:> "text/plain"]} --- > -- matches if body is "foo", status is 200 and ther is a header field "Content-Type: text/plain" -shouldRespondWith :: WithLocation (WaiSession SResponse -> ResponseMatcher -> WaiExpectation) +-- > -- matches if body is "foo", status is 200 and there is a header field "Content-Type: text/plain" +shouldRespondWith :: HasCallStack => WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st shouldRespondWith action matcher = do r <- action forM_ (match r matcher) (liftIO . expectationFailure) -- | Perform a @GET@ request to the application under test. -get :: ByteString -> WaiSession SResponse +get :: ByteString -> WaiSession st SResponse get path = request methodGet path [] "" -- | Perform a @POST@ request to the application under test. -post :: ByteString -> LB.ByteString -> WaiSession SResponse +post :: ByteString -> LB.ByteString -> WaiSession st SResponse post path = request methodPost path [] -- | Perform a @PUT@ request to the application under test. -put :: ByteString -> LB.ByteString -> WaiSession SResponse +put :: ByteString -> LB.ByteString -> WaiSession st SResponse put path = request methodPut path [] -- | Perform a @PATCH@ request to the application under test. -patch :: ByteString -> LB.ByteString -> WaiSession SResponse +patch :: ByteString -> LB.ByteString -> WaiSession st SResponse patch path = request methodPatch path [] -- | Perform an @OPTIONS@ request to the application under test. -options :: ByteString -> WaiSession SResponse +options :: ByteString -> WaiSession st SResponse options path = request methodOptions path [] "" -- | Perform a @DELETE@ request to the application under test. -delete :: ByteString -> WaiSession SResponse +delete :: ByteString -> WaiSession st SResponse delete path = request methodDelete path [] "" -- | Perform a request to the application under test, with specified HTTP -- method, request path, headers and body. -request :: Method -> ByteString -> [Header] -> LB.ByteString -> WaiSession SResponse -request method path headers body = getApp >>= liftIO . runSession (Wai.srequest $ SRequest req body) +request :: Method -> ByteString -> [Header] -> LB.ByteString -> WaiSession st SResponse +request method path headers = WaiSession . lift . Wai.srequest . SRequest req where req = setPath defaultRequest {requestMethod = method, requestHeaders = headers} path @@ -138,6 +153,6 @@ -- The specified list of key-value pairs is encoded as -- @application/x-www-form-urlencoded@ and used as request body. -- --- In additon the @Content-Type@ is set to @application/x-www-form-urlencoded@. -postHtmlForm :: ByteString -> [(String, String)] -> WaiSession SResponse +-- In addition the @Content-Type@ is set to @application/x-www-form-urlencoded@. +postHtmlForm :: ByteString -> [(String, String)] -> WaiSession st SResponse postHtmlForm path = request methodPost path [(hContentType, "application/x-www-form-urlencoded")] . formUrlEncodeQuery diff --git a/src/Test/Hspec/Wai/Internal.hs b/src/Test/Hspec/Wai/Internal.hs --- a/src/Test/Hspec/Wai/Internal.hs +++ b/src/Test/Hspec/Wai/Internal.hs @@ -2,44 +2,59 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} module Test.Hspec.Wai.Internal ( WaiExpectation , WaiSession(..) , runWaiSession +, runWithState , withApplication , getApp +, getState , formatHeader ) where -import Prelude () -import Prelude.Compat - import Control.Monad.IO.Class +import Control.Monad.Trans.Class import Control.Monad.Trans.Reader import Network.Wai (Application) import Network.Wai.Test hiding (request) import Test.Hspec.Core.Spec import Test.Hspec.Wai.Util (formatHeader) +#if MIN_VERSION_base(4,9,0) && !MIN_VERSION_base(4,13,0) +import Control.Monad.Fail +#endif + -- | An expectation in the `WaiSession` monad. Failing expectations are --- communicated through exceptions (similar to `Expectation` and +-- communicated through exceptions (similar to `Test.Hspec.Expectations.Expectation` and -- `Test.HUnit.Base.Assertion`). -type WaiExpectation = WaiSession () +type WaiExpectation st = WaiSession st () -- | A test --- session that carries the `Application` under test an some client state. -newtype WaiSession a = WaiSession {unWaiSession :: Session a} - deriving (Functor, Applicative, Monad, MonadIO) +-- session that carries the `Application` under test and some client state. +newtype WaiSession st a = WaiSession {unWaiSession :: ReaderT st Session a} + deriving (Functor, Applicative, Monad, MonadIO +#if MIN_VERSION_base(4,9,0) + , MonadFail +#endif + ) -runWaiSession :: WaiSession a -> Application -> IO a -runWaiSession = runSession . unWaiSession +runWaiSession :: WaiSession () a -> Application -> IO a +runWaiSession action app = runWithState action ((), app) -withApplication :: Application -> WaiSession a -> IO a +runWithState :: WaiSession st a -> (st, Application) -> IO a +runWithState action (st, app) = runSession (flip runReaderT st $ unWaiSession action) app + +withApplication :: Application -> WaiSession () a -> IO a withApplication = flip runWaiSession -instance Example WaiExpectation where - type Arg WaiExpectation = Application - evaluateExample e p action = evaluateExample (action $ runWaiSession e) p ($ ()) +instance Example (WaiExpectation st) where + type Arg (WaiExpectation st) = (st, Application) + evaluateExample e p action = evaluateExample (action $ runWithState e) p ($ ()) -getApp :: WaiSession Application -getApp = WaiSession ask +getApp :: WaiSession st Application +getApp = WaiSession (lift ask) + +getState :: WaiSession st st +getState = WaiSession ask diff --git a/src/Test/Hspec/Wai/Matcher.hs b/src/Test/Hspec/Wai/Matcher.hs --- a/src/Test/Hspec/Wai/Matcher.hs +++ b/src/Test/Hspec/Wai/Matcher.hs @@ -1,18 +1,24 @@ +{-# LANGUAGE PackageImports #-} {-# LANGUAGE ViewPatterns #-} module Test.Hspec.Wai.Matcher ( ResponseMatcher(..) , MatchHeader(..) +, MatchBody(..) +, Body , (<:>) +, bodyEquals , match +, formatHeader ) where import Prelude () -import Prelude.Compat +import "base-compat" Prelude.Compat import Control.Monad import Data.Maybe import Data.String import Data.Text.Lazy.Encoding (encodeUtf8) +import qualified Data.Text.Lazy as T import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as LB import Network.HTTP.Types @@ -20,19 +26,39 @@ import Test.Hspec.Wai.Util +type Body = LB.ByteString + data ResponseMatcher = ResponseMatcher { matchStatus :: Int , matchHeaders :: [MatchHeader] -, matchBody :: Maybe LB.ByteString +, matchBody :: MatchBody } -data MatchHeader = MatchHeader ([Header] -> Maybe String) +data MatchHeader = MatchHeader ([Header] -> Body -> Maybe String) +data MatchBody = MatchBody ([Header] -> Body -> Maybe String) + +bodyEquals :: Body -> MatchBody +bodyEquals body = MatchBody (\_ actual -> bodyMatcher actual body) + where + bodyMatcher :: Body -> Body -> Maybe String + bodyMatcher (toStrict -> actual) (toStrict -> expected) = actualExpected "body mismatch:" actual_ expected_ <$ guard (actual /= expected) + where + (actual_, expected_) = case (safeToString actual, safeToString expected) of + (Just x, Just y) -> (x, y) + _ -> (show actual, show expected) + +matchAny :: MatchBody +matchAny = MatchBody (\_ _ -> Nothing) + +instance IsString MatchBody where + fromString = bodyEquals . encodeUtf8 . T.pack + instance IsString ResponseMatcher where - fromString s = ResponseMatcher 200 [] (Just . encodeUtf8 . fromString $ s) + fromString = ResponseMatcher 200 [] . fromString instance Num ResponseMatcher where - fromInteger n = ResponseMatcher (fromInteger n) [] Nothing + fromInteger n = ResponseMatcher (fromInteger n) [] matchAny (+) = error "ResponseMatcher does not support (+)" (-) = error "ResponseMatcher does not support (-)" (*) = error "ResponseMatcher does not support (*)" @@ -40,34 +66,28 @@ signum = error "ResponseMatcher does not support `signum`" match :: SResponse -> ResponseMatcher -> Maybe String -match (SResponse (Status status _) headers body) (ResponseMatcher expectedStatus expectedHeaders expectedBody) = mconcat [ +match (SResponse (Status status _) headers body) (ResponseMatcher expectedStatus expectedHeaders (MatchBody bodyMatcher)) = mconcat [ actualExpected "status mismatch:" (show status) (show expectedStatus) <$ guard (status /= expectedStatus) - , checkHeaders headers expectedHeaders - , expectedBody >>= matchBody_ body + , checkHeaders headers body expectedHeaders + , bodyMatcher headers body ] - where - matchBody_ (toStrict -> actual) (toStrict -> expected) = actualExpected "body mismatch:" actual_ expected_ <$ guard (actual /= expected) - where - (actual_, expected_) = case (safeToString actual, safeToString expected) of - (Just x, Just y) -> (x, y) - _ -> (show actual, show expected) - actualExpected :: String -> String -> String -> String - actualExpected message actual expected = unlines [ - message - , " expected: " ++ expected - , " but got: " ++ actual - ] +actualExpected :: String -> String -> String -> String +actualExpected message actual expected = unlines [ + message + , " expected: " ++ expected + , " but got: " ++ actual + ] -checkHeaders :: [Header] -> [MatchHeader] -> Maybe String -checkHeaders headers m = case go m of +checkHeaders :: [Header] -> Body -> [MatchHeader] -> Maybe String +checkHeaders headers body m = case go m of [] -> Nothing xs -> Just (mconcat xs ++ "the actual headers were:\n" ++ unlines (map formatHeader headers)) where - go = catMaybes . map (\(MatchHeader p) -> p headers) + go = catMaybes . map (\(MatchHeader p) -> p headers body) (<:>) :: HeaderName -> ByteString -> MatchHeader -name <:> value = MatchHeader $ \headers -> guard (header `notElem` headers) >> (Just . unlines) [ +name <:> value = MatchHeader $ \headers _body -> guard (header `notElem` headers) >> (Just . unlines) [ "missing header:" , formatHeader header ] diff --git a/src/Test/Hspec/Wai/QuickCheck.hs b/src/Test/Hspec/Wai/QuickCheck.hs --- a/src/Test/Hspec/Wai/QuickCheck.hs +++ b/src/Test/Hspec/Wai/QuickCheck.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} module Test.Hspec.Wai.QuickCheck ( property , (==>) @@ -19,26 +20,30 @@ import Test.Hspec.Wai.Internal -property :: Testable a => a -> Application -> Property +property :: Testable a => a -> (State a, Application) -> Property property = unWaiProperty . toProperty -data WaiProperty = WaiProperty {unWaiProperty :: Application -> Property} +data WaiProperty st = WaiProperty {unWaiProperty :: (st, Application) -> Property} class Testable a where - toProperty :: a -> WaiProperty + type State a + toProperty :: a -> WaiProperty (State a) -instance Testable WaiProperty where +instance Testable (WaiProperty st) where + type State (WaiProperty st) = st toProperty = id -instance Testable WaiExpectation where - toProperty action = WaiProperty (QuickCheck.property . runWaiSession action) +instance Testable (WaiExpectation st) where + type State (WaiExpectation st) = st + toProperty action = WaiProperty (QuickCheck.property . runWithState action) instance (Arbitrary a, Show a, Testable prop) => Testable (a -> prop) where + type State (a -> prop) = State prop toProperty prop = WaiProperty $ QuickCheck.property . (flip $ unWaiProperty . toProperty . prop) infixr 0 ==> -(==>) :: Testable prop => Bool -> prop -> WaiProperty +(==>) :: Testable prop => Bool -> prop -> WaiProperty (State prop) (==>) = lift (QuickCheck.==>) -lift :: Testable prop => (a -> Property -> Property) -> a -> prop -> WaiProperty +lift :: Testable prop => (a -> Property -> Property) -> a -> prop -> WaiProperty (State prop) lift f a prop = WaiProperty $ \app -> f a (unWaiProperty (toProperty prop) app) diff --git a/src/Test/Hspec/Wai/Util.hs b/src/Test/Hspec/Wai/Util.hs --- a/src/Test/Hspec/Wai/Util.hs +++ b/src/Test/Hspec/Wai/Util.hs @@ -1,8 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} module Test.Hspec.Wai.Util where import Control.Monad -import Data.Monoid import Data.Maybe import Data.List import Data.Word @@ -12,12 +12,16 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy as LB -import Data.ByteString.Lazy.Builder (Builder) -import qualified Data.ByteString.Lazy.Builder as Builder +import Data.ByteString.Builder (Builder) +import qualified Data.ByteString.Builder as Builder import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.CaseInsensitive as CI import Network.HTTP.Types + +#if !MIN_VERSION_base(4,11,0) +import Data.Monoid +#endif formatHeader :: Header -> String formatHeader header@(name, value) = " " ++ fromMaybe (show header) (safeToString $ B8.concat [CI.original name, ": ", value]) diff --git a/test/Test/Hspec/Wai/UtilSpec.hs b/test/Test/Hspec/Wai/UtilSpec.hs --- a/test/Test/Hspec/Wai/UtilSpec.hs +++ b/test/Test/Hspec/Wai/UtilSpec.hs @@ -1,16 +1,20 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} module Test.Hspec.Wai.UtilSpec (main, spec) where import Test.Hspec import Test.Hspec.QuickCheck import Test.QuickCheck import Test.Hspec.Wai.Util -import Data.Monoid import Network.HTTP.Types (parseSimpleQuery) import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as LB import qualified Data.Text as T import qualified Data.Text.Encoding as T + +#if !MIN_VERSION_base(4,11,0) +import Data.Monoid +#endif main :: IO () main = hspec spec diff --git a/test/Test/Hspec/WaiSpec.hs b/test/Test/Hspec/WaiSpec.hs --- a/test/Test/Hspec/WaiSpec.hs +++ b/test/Test/Hspec/WaiSpec.hs @@ -8,6 +8,7 @@ import Network.Wai import Test.Hspec.Wai +import Test.Hspec.Wai.Internal (withApplication) main :: IO () main = hspec spec @@ -22,38 +23,45 @@ requestMethod req `shouldBe` method rawPathInfo req `shouldBe` path requestHeaders req `shouldBe` headers - rawBody <- requestBody req + rawBody <- getRequestBodyChunk req rawBody `shouldBe` body respond $ responseLBS status200 [] "" spec :: Spec spec = do - describe "get" $ with (return $ expectMethod methodGet) $ - it "sends a get request" $ + describe "WaiSession" $ do + it "has a MonadFail instance" $ do + withApplication undefined $ do + 23 <- return (42 :: Int) + return () + `shouldThrow` anyIOException + + describe "get" $ with (return $ expectMethod methodGet) $ do + it "sends a get request" $ do get "/" `shouldRespondWith` 200 - describe "post" $ with (return $ expectMethod methodPost) $ - it "sends a post request" $ + describe "post" $ with (return $ expectMethod methodPost) $ do + it "sends a post request" $ do post "/" "" `shouldRespondWith` 200 - describe "put" $ with (return $ expectMethod methodPut) $ - it "sends a put request" $ + describe "put" $ with (return $ expectMethod methodPut) $ do + it "sends a put request" $ do put "/" "" `shouldRespondWith` 200 - describe "options" $ with (return $ expectMethod methodOptions) $ - it "sends an options request" $ + describe "options" $ with (return $ expectMethod methodOptions) $ do + it "sends an options request" $ do options "/" `shouldRespondWith` 200 - describe "delete" $ with (return $ expectMethod methodDelete) $ - it "sends a delete request" $ + describe "delete" $ with (return $ expectMethod methodDelete) $ do + it "sends a delete request" $ do delete "/" `shouldRespondWith` 200 - describe "request" $ with (return $ expectRequest methodGet "/foo" body accept) $ - it "sends method, path, headers, and body" $ + describe "request" $ with (return $ expectRequest methodGet "/foo" body accept) $ do + it "sends method, path, headers, and body" $ do request methodGet "/foo" accept (BL.fromChunks [body]) `shouldRespondWith` 200 - describe "postHtmlForm" $ with (return $ expectRequest methodPost "/foo" "foo=bar" formEncoded) $ - it "sends a post request with form-encoded params" $ + describe "postHtmlForm" $ with (return $ expectRequest methodPost "/foo" "foo=bar" formEncoded) $ do + it "sends a post request with form-encoded params" $ do postHtmlForm "/foo" [("foo", "bar")] `shouldRespondWith` 200 where