diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,19 @@ +Copyright (c) 2012-2014 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 +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/example/Spec.hs b/example/Spec.hs new file mode 100644 --- /dev/null +++ b/example/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/hspec-wai.cabal b/hspec-wai.cabal new file mode 100644 --- /dev/null +++ b/hspec-wai.cabal @@ -0,0 +1,74 @@ +name: hspec-wai +version: 0.0.0 +license: MIT +license-file: LICENSE +copyright: (c) 2012-2014 Fujimura Daisuke, + (c) 2014 Simon Hengel +author: Fujimura Daisuke , Simon Hengel +maintainer: Fujimura Daisuke , Simon Hengel +build-type: Simple +cabal-version: >= 1.8 +category: Testing +synopsis: Experimental Hspec support for testing WAI applications (depends on hspec2!) +description: Experimental Hspec support for testing WAI applications (depends on hspec2!) + +source-repository head + type: git + location: https://github.com/hspec/hspec-wai + +library + ghc-options: + -Wall + hs-source-dirs: + src + exposed-modules: + Test.Hspec.Wai + , Test.Hspec.Wai.Internal + other-modules: + Test.Hspec.Wai.Matcher + build-depends: + base == 4.* + , bytestring + , text + , transformers + , http-types + , wai >= 3 + , wai-extra >= 3 + , hspec2 + +test-suite spec + type: + exitcode-stdio-1.0 + ghc-options: + -Wall -Werror + hs-source-dirs: + src, test + main-is: + Spec.hs + build-depends: + base == 4.* + , bytestring + , text + , transformers + , http-types + , wai + , wai-extra + , hspec2 + + , hspec-meta + +test-suite example + type: + exitcode-stdio-1.0 + ghc-options: + -Wall -Werror + hs-source-dirs: + example + main-is: + Spec.hs + build-depends: + base == 4.* + , hspec2 + , hspec-wai + , http-types + , wai diff --git a/src/Test/Hspec/Wai.hs b/src/Test/Hspec/Wai.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Wai.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, FlexibleInstances, TypeFamilies #-} +module Test.Hspec.Wai ( + with +, get +, post +, put +, request +, shouldHaveHeader +, shouldRespondWith +, ResponseMatcher(..) +) where + +import Data.Foldable +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as LB +import Control.Monad.IO.Class +import Network.Wai (Request(..)) +import Network.HTTP.Types +import Network.Wai.Test hiding (request) +import qualified Network.Wai.Test as Wai +import Test.Hspec + +import Test.Hspec.Wai.Internal +import Test.Hspec.Wai.Matcher + +with :: IO a -> SpecWith a -> Spec +with = before + +-- | +-- Passes if the given `Header` exists in the response. +shouldHaveHeader :: WaiSession SResponse -> Header -> WaiExpectation +shouldHaveHeader action header = do + r <- action + forM_ (haveHeader r header) (liftIO . expectationFailure) + +-- | +-- Passs if +-- +-- * 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. +-- +-- Example: +-- +-- > 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 +-- + +shouldRespondWith :: WaiSession SResponse -> ResponseMatcher -> WaiExpectation +shouldRespondWith action matcher = do + r <- action + forM_ (match r matcher) (liftIO . expectationFailure) + +-- | +-- | Performs `GET` request to running app. +get :: ByteString -> WaiSession SResponse +get p = request methodGet p "" + +-- | +-- | Performs `POST` request to running app. +post :: ByteString -> LB.ByteString -> WaiSession SResponse +post = request methodPost + +-- | +-- | Performs `PUT` request to running app. +put :: ByteString -> LB.ByteString -> WaiSession SResponse +put = request methodPut + +-- | +-- | Performs request to running app, with HTTP Method, path and body. +request :: Method -> ByteString -> LB.ByteString -> WaiSession SResponse +request m p b = getApp >>= liftIO . runSession (Wai.srequest $ SRequest req b) + where + req = setPath defaultRequest {requestMethod = m} p diff --git a/src/Test/Hspec/Wai/Internal.hs b/src/Test/Hspec/Wai/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Wai/Internal.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +module Test.Hspec.Wai.Internal ( + WaiExpectation +, WaiSession +, runWaiSession +, getApp +) where + +import Control.Applicative +import Control.Monad.IO.Class +import Control.Monad.Trans.Reader +import Network.Wai (Application) +import Network.Wai.Test hiding (request) +import Test.Hspec +import Test.Hspec.Core (Example (..)) + +type WaiExpectation = WaiSession () + +newtype WaiSession a = WaiSession {unWaiSession :: Session a} + deriving (Functor, Applicative, Monad, MonadIO) + +runWaiSession :: WaiSession a -> Application -> IO a +runWaiSession = runSession . unWaiSession + +instance Example WaiExpectation where + type Arg WaiExpectation = Application + evaluateExample e p action = evaluateExample (action $ runWaiSession e) p ($ ()) + +getApp :: WaiSession Application +getApp = WaiSession ask diff --git a/src/Test/Hspec/Wai/Matcher.hs b/src/Test/Hspec/Wai/Matcher.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Wai/Matcher.hs @@ -0,0 +1,59 @@ +module Test.Hspec.Wai.Matcher ( + ResponseMatcher(..) +, match +, haveHeader +) where + + +import Control.Monad +import Data.Monoid +import Data.Functor +import Data.String +import Data.Text.Lazy.Encoding (encodeUtf8) +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy as LB +import Network.HTTP.Types +import Network.Wai.Test + +data ResponseMatcher = ResponseMatcher { + matchStatus :: Int +, matchBody :: Maybe LB.ByteString +} + +instance IsString ResponseMatcher where + fromString s = ResponseMatcher 200 (Just . encodeUtf8 . fromString $ s) + +instance Num ResponseMatcher where + fromInteger n = ResponseMatcher (fromInteger n) Nothing + (+) = error "ResponseMatcher does not support (+)" + (-) = error "ResponseMatcher does not support (-)" + (*) = error "ResponseMatcher does not support (*)" + abs = error "ResponseMatcher does not support `abs`" + signum = error "ResponseMatcher does not support `signum`" + +match :: SResponse -> ResponseMatcher -> Maybe String +match (SResponse (Status status _) _ body) (ResponseMatcher expectedStatus expectedBody) = mconcat [ + match_ "status mismatch" status expectedStatus + , expectedBody >>= match_ "body mismatch" body + ] + where + match_ :: (Show a, Eq a) => String -> a -> a -> Maybe String + match_ message actual expected = actualExpected message actual expected <$ guard (actual /= expected) + + actualExpected :: Show a => String -> a -> a -> String + actualExpected message actual expected = unlines [ + message + , " expected: " ++ show expected + , " but got: " ++ show actual + ] + +haveHeader :: SResponse -> Header -> Maybe String +haveHeader (SResponse _ headers _) (name, expected) = go $ lookup name headers + where + go Nothing = Just $ "header doesn't exist: " ++ show name + go (Just actual) = if actual == expected + then Nothing + else (Just . unlines) [ "header mismatch" + , " expected: \"" ++ B.unpack expected ++ "\"" + , " but got: \"" ++ B.unpack actual ++ "\"" + ] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-meta-discover #-}