diff --git a/README.lhs b/README.lhs --- a/README.lhs +++ b/README.lhs @@ -7,35 +7,48 @@ ## Example ~~~ {.haskell} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, QuasiQuotes #-} module Main (main) where import Test.Hspec import Test.Hspec.Wai +import Test.Hspec.Wai.JSON -import Network.HTTP.Types (status200, hContentType) -import Network.Wai (Application, responseLBS) +import Network.HTTP.Types (hContentType) +import Network.Wai (Application) +import Data.Aeson (Value(..), object, (.=)) +import qualified Web.Scotty as S + main :: IO () main = hspec spec -app :: Application -app _ = ($ responseLBS status200 [("Content-Type", "text/plain")] "hello") +app :: IO Application +app = S.scottyApp $ do + S.get "/" $ do + S.text "hello" + S.get "/some-json" $ do + S.json $ object ["foo" .= Number 23, "bar" .= Number 42] + spec :: Spec -spec = before (return app) $ do - describe "GET /foo" $ do +spec = with app $ do + describe "GET /" $ do it "reponds with 200" $ do - get "/foo" `shouldRespondWith` 200 + get "/" `shouldRespondWith` 200 it "reponds with 'hello'" $ do - get "/foo" `shouldRespondWith` "hello" + get "/" `shouldRespondWith` "hello" it "reponds with 200 / 'hello'" $ do - get "/foo" `shouldRespondWith` "hello" {matchStatus = 200} + get "/" `shouldRespondWith` "hello" {matchStatus = 200} it "has Content-Type: text/plain" $ do - get "/foo" `shouldRespondWith` 200 {matchHeaders = [(hContentType, "text/plain")]} + get "/" `shouldRespondWith` 200 {matchHeaders = [(hContentType, "text/plain")]} + + describe "GET /some-json" $ do + it "reponds with some JSON" $ do + get "/some-json" `shouldRespondWith` [json|{foo: 23, bar: 42}|] ~~~ ## Contributing diff --git a/hspec-wai.cabal b/hspec-wai.cabal --- a/hspec-wai.cabal +++ b/hspec-wai.cabal @@ -1,5 +1,5 @@ name: hspec-wai -version: 0.1.0 +version: 0.2.0 license: MIT license-file: LICENSE copyright: (c) 2012-2014 Fujimura Daisuke, @@ -24,6 +24,7 @@ exposed-modules: Test.Hspec.Wai Test.Hspec.Wai.Internal + Test.Hspec.Wai.JSON other-modules: Test.Hspec.Wai.Util Test.Hspec.Wai.Matcher @@ -37,6 +38,9 @@ , wai >= 3 , wai-extra >= 3 , hspec2 + , template-haskell + , aeson + , aeson-qq >= 0.7.1 test-suite spec type: @@ -60,10 +64,23 @@ , hspec-meta -test-suite example +test-suite doctests + main-is: + doctests.hs type: exitcode-stdio-1.0 ghc-options: + -Wall -Werror -threaded + hs-source-dirs: + test + build-depends: + base == 4.* + , doctest >= 0.9.4.1 + +test-suite README + type: + exitcode-stdio-1.0 + ghc-options: -Wall -Werror -pgmL markdown-unlit main-is: README.lhs @@ -73,4 +90,6 @@ , hspec2 , hspec-wai , http-types + , aeson , wai + , scotty 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,12 +1,24 @@ -{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, FlexibleInstances, TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} +-- | Have a look at the for +-- an example of how to use this library. module Test.Hspec.Wai ( - with +-- * Types + WaiSession +, WaiExpectation + +-- * Performing requests , get , post , put , request + +-- * Matching on the response , shouldRespondWith , ResponseMatcher(..) + +-- * Helpers and re-exports +, liftIO +, with ) where import Data.Foldable @@ -22,46 +34,64 @@ import Test.Hspec.Wai.Internal import Test.Hspec.Wai.Matcher +-- | An alias for `before`. with :: IO a -> SpecWith a -> Spec with = before --- | --- Passs if +-- | Set the expectation that a response matches a specified `ResponseMatcher`. -- --- * the given number matches with the HTTP Status code of the response. --- * the given string matches with the body of the response. --- * the given `ResponseMatcher` matches with the response. +-- A @ResponseMatcher@ matches a response if: -- --- Example: +-- * the specified status matches the HTTP response status code -- --- > get "/foo" `shouldRespondWith` 200 -- Pass --- > get "/foo" `shouldRespondWith` "bar" -- Pass if the body is "bar" --- > get "/foo" `shouldRespondWith` "bar" { matchStatus = 200 } -- Pass if the body is "bar" and status is 200 +-- * the specified body (if any) matches the response body -- - +-- * the response has all of the specified `Header` fields +-- (the response may have arbitrary additional `Header` fields) +-- +-- You can use @ResponseMatcher@'s (broken) `Num` instance to match for a HTTP +-- status code: +-- +-- > get "/" `shouldRespondWith` 200 +-- > -- matches if status is 200 +-- +-- You can use @ResponseMatcher@'s `IsString` instance to match for a HTTP +-- status @200@ and a body: +-- +-- > get "/" `shouldRespondWith` "foo" +-- > -- matches if body is "foo" and status is 200 +-- +-- If you want to match for a different HTTP status, you can use record update +-- notation to specify `matchStatus` explicitly: +-- +-- > get "/" `shouldRespondWith` "foo" {matchStatus = 404} +-- > -- matches if body is "foo" and status is 404 +-- +-- If you want to require a specific header field you can specify +-- `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 :: WaiSession SResponse -> ResponseMatcher -> WaiExpectation shouldRespondWith action matcher = do r <- action forM_ (match r matcher) (liftIO . expectationFailure) --- | --- | Performs `GET` request to running app. +-- | Perform a @GET@ request to the application under test. get :: ByteString -> WaiSession SResponse -get p = request methodGet p "" +get path = request methodGet path "" --- | --- | Performs `POST` request to running app. +-- | Perform a @POST@ request to the application under test. post :: ByteString -> LB.ByteString -> WaiSession SResponse post = request methodPost --- | --- | Performs `PUT` request to running app. +-- | Perform a @PUT@ request to the application under test. put :: ByteString -> LB.ByteString -> WaiSession SResponse put = request methodPut --- | --- | Performs request to running app, with HTTP Method, path and body. +-- | Perform a request to the application under test, with specified HTTP +-- method, request path and body. request :: Method -> ByteString -> LB.ByteString -> WaiSession SResponse -request m p b = getApp >>= liftIO . runSession (Wai.srequest $ SRequest req b) +request method path body = getApp >>= liftIO . runSession (Wai.srequest $ SRequest req body) where - req = setPath defaultRequest {requestMethod = m} p + req = setPath defaultRequest {requestMethod = method} path 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 @@ -1,10 +1,10 @@ -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} module Test.Hspec.Wai.Internal ( WaiExpectation -, WaiSession +, WaiSession(..) , runWaiSession , getApp ) where @@ -12,13 +12,18 @@ import Control.Applicative import Control.Monad.IO.Class import Control.Monad.Trans.Reader -import Network.Wai (Application) -import Network.Wai.Test hiding (request) +import Network.Wai (Application) +import Network.Wai.Test hiding (request) import Test.Hspec -import Test.Hspec.Core (Example (..)) +import Test.Hspec.Core (Example (..)) +-- | An expectation in the `WaiSession` monad. Failing expectations are +-- communicated through exceptions (similar to `Expectation` and +-- `Test.HUnit.Base.Assertion`). type WaiExpectation = WaiSession () +-- | 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) diff --git a/src/Test/Hspec/Wai/JSON.hs b/src/Test/Hspec/Wai/JSON.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Wai/JSON.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE OverloadedStrings, TemplateHaskell #-} +module Test.Hspec.Wai.JSON ( +-- $setup + json +, FromValue(..) +) where + +import Test.Hspec.Wai +import Data.ByteString.Lazy (ByteString) +import Data.Aeson (Value, encode) +import Data.Aeson.QQ +import Language.Haskell.TH.Quote + +-- $setup +-- The examples in this module assume that you have the @QuasiQuotes@ language +-- extension enabled and that "Data.ByteString.Lazy.Char8" is imported +-- qualified as @L@: +-- +-- >>> :set -XQuasiQuotes +-- >>> import Data.ByteString.Lazy.Char8 as L + +-- | A `QuasiQuoter` for constructing JSON values. +-- +-- The constructed value is polymorph and unifies to instances of `FromValue`. +-- +-- When used as a `ResponseMatcher` it matches a response with +-- +-- * a status code of @200@ +-- +-- * a @Content-Type@ header with value @application/json@ +-- +-- * the specified JSON as response body +-- +-- When used as a @ByteString@ it creates a ByteString from the specified JSON +-- that can be used as a request body for e.g. @POST@ and @PUT@ requests. +-- +-- Example: +-- +-- >>> L.putStrLn [json|[23, {foo: 42}]|] +-- [23,{"foo":42}] +json :: QuasiQuoter +json = QuasiQuoter { + quoteExp = \input -> [|fromValue $(quoteExp aesonQQ input)|] +, quotePat = const $ error "No quotePat defined for Test.Hspec.Wai.JSON.json" +, quoteType = const $ error "No quoteType defined for Test.Hspec.Wai.JSON.json" +, quoteDec = const $ error "No quoteDec defined for Test.Hspec.Wai.JSON.json" +} + +class FromValue a where + fromValue :: Value -> a + +instance FromValue ResponseMatcher where + fromValue v = ResponseMatcher 200 [("Content-Type", "application/json")] (Just . encode $ v) + +instance FromValue ByteString where + fromValue = encode diff --git a/test/doctests.hs b/test/doctests.hs new file mode 100644 --- /dev/null +++ b/test/doctests.hs @@ -0,0 +1,22 @@ +module Main where + +import Test.DocTest + +main :: IO () +main = doctest [ + "-isrc" + , "-hide-all-packages" + , "-package base" + , "-package bytestring" + , "-package text" + , "-package transformers" + , "-package case-insensitive" + , "-package http-types" + , "-package wai" + , "-package wai-extra" + , "-package hspec2" + , "-package template-haskell" + , "-package aeson" + , "-package aeson-qq" + , "src/Test/Hspec/Wai/JSON.hs" + ]