servant/servant-server/test/Servant/ServerSpec.hs

675 lines
23 KiB
Haskell
Raw Normal View History

2015-10-12 19:23:13 +02:00
{-# LANGUAGE CPP #-}
2015-10-12 19:14:42 +02:00
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
2014-12-10 16:10:57 +01:00
module Servant.ServerSpec where
2015-10-12 19:23:13 +02:00
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
import Control.Monad (forM_, when)
2015-09-12 14:11:24 +02:00
import Control.Monad.Trans.Except (ExceptT, throwE)
import Data.Aeson (FromJSON, ToJSON, decode', encode)
import Data.ByteString.Conversion ()
import Data.Char (toUpper)
import Data.Monoid ((<>))
import Data.Proxy (Proxy (Proxy))
import Data.String (fromString)
import Data.String.Conversions (cs)
import qualified Data.Text as T
import GHC.Generics (Generic)
2015-04-06 16:43:36 +02:00
import Network.HTTP.Types (hAccept, hContentType,
methodDelete, methodGet, methodHead,
methodPatch, methodPost, methodPut,
2015-10-12 19:23:13 +02:00
ok200, parseQuery, status409,
Status(..))
import Network.Wai (Application, Request, pathInfo,
queryString, rawQueryString,
2015-10-12 19:23:13 +02:00
responseLBS, responseBuilder)
import Network.Wai.Internal (Response(ResponseBuilder))
import Network.Wai.Test (defaultRequest, request,
runSession, simpleBody)
import Test.Hspec (Spec, describe, it, shouldBe)
import Test.Hspec.Wai (get, liftIO, matchHeaders,
matchStatus, post, request,
shouldRespondWith, with, (<:>))
import Servant.API ((:<|>) (..), (:>), Capture, Delete,
Get, Header (..), Headers,
HttpVersion, IsSecure (..), JSON,
Patch, PlainText, Post, Put,
QueryFlag, QueryParam, QueryParams,
Raw, RemoteHost, ReqBody,
addHeader)
2015-05-02 04:38:53 +02:00
import Servant.Server (Server, serve, ServantErr(..), err404)
2015-10-12 19:23:13 +02:00
import Servant.Server.Internal.Router
(tweakResponse, runRouter,
Router, Router'(LeafRouter))
import Servant.Server.Internal.RoutingApplication
2015-10-12 19:23:13 +02:00
(RouteResult(..), RouteMismatch(..),
toApplication)
2014-12-10 16:10:57 +01:00
-- * test data types
data Person = Person {
name :: String,
2015-04-06 16:43:36 +02:00
age :: Integer
2014-12-10 16:10:57 +01:00
}
deriving (Eq, Show, Generic)
instance ToJSON Person
instance FromJSON Person
alice :: Person
alice = Person "Alice" 42
data Animal = Animal {
2015-04-06 16:43:36 +02:00
species :: String,
2014-12-10 16:10:57 +01:00
numberOfLegs :: Integer
}
deriving (Eq, Show, Generic)
instance ToJSON Animal
instance FromJSON Animal
jerry :: Animal
jerry = Animal "Mouse" 4
tweety :: Animal
tweety = Animal "Bird" 2
-- * specs
spec :: Spec
spec = do
captureSpec
getSpec
headSpec
postSpec
putSpec
patchSpec
2014-12-10 16:10:57 +01:00
queryParamSpec
2015-02-24 14:48:17 +01:00
headerSpec
2014-12-10 16:10:57 +01:00
rawSpec
unionSpec
prioErrorsSpec
errorsSpec
2015-10-12 19:23:13 +02:00
routerSpec
responseHeadersSpec
miscReqCombinatorsSpec
2014-12-10 16:10:57 +01:00
2015-01-12 15:08:41 +01:00
type CaptureApi = Capture "legs" Integer :> Get '[JSON] Animal
2014-12-10 16:10:57 +01:00
captureApi :: Proxy CaptureApi
captureApi = Proxy
2015-09-12 14:11:24 +02:00
captureServer :: Integer -> ExceptT ServantErr IO Animal
2014-12-10 16:10:57 +01:00
captureServer legs = case legs of
4 -> return jerry
2 -> return tweety
2015-09-12 14:11:24 +02:00
_ -> throwE err404
2014-12-10 16:10:57 +01:00
captureSpec :: Spec
captureSpec = do
describe "Servant.API.Capture" $ do
with (return (serve captureApi captureServer)) $ do
2015-04-06 16:43:36 +02:00
2014-12-10 16:10:57 +01:00
it "can capture parts of the 'pathInfo'" $ do
response <- get "/2"
2015-04-06 16:43:36 +02:00
liftIO $ decode' (simpleBody response) `shouldBe` Just tweety
it "returns 404 if the decoding fails" $ do
get "/notAnInt" `shouldRespondWith` 404
2014-12-10 16:10:57 +01:00
with (return (serve
(Proxy :: Proxy (Capture "captured" String :> Raw))
2015-01-06 17:26:37 +01:00
(\ "captured" request_ respond ->
respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do
2014-12-10 16:10:57 +01:00
it "strips the captured path snippet from pathInfo" $ do
get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String]))
2015-01-12 15:08:41 +01:00
type GetApi = Get '[JSON] Person
:<|> "empty" :> Get '[] ()
:<|> "post" :> Post '[] ()
2014-12-10 16:10:57 +01:00
getApi :: Proxy GetApi
getApi = Proxy
getSpec :: Spec
getSpec = do
describe "Servant.API.Get" $ do
let server = return alice :<|> return () :<|> return ()
with (return $ serve getApi server) $ do
2015-04-06 16:43:36 +02:00
2014-12-10 16:10:57 +01:00
it "allows to GET a Person" $ do
response <- get "/"
return response `shouldRespondWith` 200
2015-04-06 16:43:36 +02:00
liftIO $ decode' (simpleBody response) `shouldBe` Just alice
2014-12-10 16:10:57 +01:00
it "throws 405 (wrong method) on POSTs" $ do
post "/" "" `shouldRespondWith` 405
2015-04-06 16:43:36 +02:00
post "/empty" "" `shouldRespondWith` 405
2014-12-10 16:10:57 +01:00
it "returns 204 if the type is '()'" $ do
get "/empty" `shouldRespondWith` ""{ matchStatus = 204 }
2015-04-06 16:43:36 +02:00
it "returns 415 if the Accept header is not supported" $ do
Test.Hspec.Wai.request methodGet "" [(hAccept, "crazy/mime")] ""
`shouldRespondWith` 415
headSpec :: Spec
headSpec = do
describe "Servant.API.Head" $ do
let server = return alice :<|> return () :<|> return ()
with (return $ serve getApi server) $ do
it "allows to GET a Person" $ do
response <- Test.Hspec.Wai.request methodHead "/" [] ""
return response `shouldRespondWith` 200
liftIO $ decode' (simpleBody response) `shouldBe` (Nothing :: Maybe Person)
it "does not allow HEAD to POST route" $ do
response <- Test.Hspec.Wai.request methodHead "/post" [] ""
return response `shouldRespondWith` 405
it "throws 405 (wrong method) on POSTs" $ do
post "/" "" `shouldRespondWith` 405
post "/empty" "" `shouldRespondWith` 405
it "returns 204 if the type is '()'" $ do
response <- Test.Hspec.Wai.request methodHead "/empty" [] ""
return response `shouldRespondWith` ""{ matchStatus = 204 }
it "returns 415 if the Accept header is not supported" $ do
Test.Hspec.Wai.request methodHead "" [(hAccept, "crazy/mime")] ""
`shouldRespondWith` 415
2014-12-10 16:10:57 +01:00
2015-01-12 15:08:41 +01:00
type QueryParamApi = QueryParam "name" String :> Get '[JSON] Person
:<|> "a" :> QueryParams "names" String :> Get '[JSON] Person
:<|> "b" :> QueryFlag "capitalize" :> Get '[JSON] Person
2014-12-10 16:10:57 +01:00
queryParamApi :: Proxy QueryParamApi
queryParamApi = Proxy
qpServer :: Server QueryParamApi
qpServer = queryParamServer :<|> qpNames :<|> qpCapitalize
where qpNames (_:name2:_) = return alice { name = name2 }
qpNames _ = return alice
qpCapitalize False = return alice
qpCapitalize True = return alice { name = map toUpper (name alice) }
2015-01-06 17:26:37 +01:00
queryParamServer (Just name_) = return alice{name = name_}
2014-12-10 16:10:57 +01:00
queryParamServer Nothing = return alice
queryParamSpec :: Spec
queryParamSpec = do
describe "Servant.API.QueryParam" $ do
it "allows to retrieve simple GET parameters" $
(flip runSession) (serve queryParamApi qpServer) $ do
let params1 = "?name=bob"
response1 <- Network.Wai.Test.request defaultRequest{
rawQueryString = params1,
queryString = parseQuery params1
}
liftIO $ do
decode' (simpleBody response1) `shouldBe` Just alice{
name = "bob"
}
it "allows to retrieve lists in GET parameters" $
(flip runSession) (serve queryParamApi qpServer) $ do
let params2 = "?names[]=bob&names[]=john"
response2 <- Network.Wai.Test.request defaultRequest{
rawQueryString = params2,
queryString = parseQuery params2,
pathInfo = ["a"]
}
liftIO $
decode' (simpleBody response2) `shouldBe` Just alice{
name = "john"
}
2015-01-13 20:40:41 +01:00
2014-12-10 16:10:57 +01:00
it "allows to retrieve value-less GET parameters" $
(flip runSession) (serve queryParamApi qpServer) $ do
let params3 = "?capitalize"
response3 <- Network.Wai.Test.request defaultRequest{
rawQueryString = params3,
queryString = parseQuery params3,
pathInfo = ["b"]
}
liftIO $
decode' (simpleBody response3) `shouldBe` Just alice{
name = "ALICE"
}
let params3' = "?capitalize="
response3' <- Network.Wai.Test.request defaultRequest{
rawQueryString = params3',
queryString = parseQuery params3',
pathInfo = ["b"]
}
liftIO $
decode' (simpleBody response3') `shouldBe` Just alice{
name = "ALICE"
}
2014-12-28 23:07:14 +01:00
let params3'' = "?unknown="
response3' <- Network.Wai.Test.request defaultRequest{
rawQueryString = params3'',
queryString = parseQuery params3'',
pathInfo = ["b"]
}
liftIO $
decode' (simpleBody response3') `shouldBe` Just alice{
name = "Alice"
}
type PostApi =
2015-01-13 20:40:41 +01:00
ReqBody '[JSON] Person :> Post '[JSON] Integer
:<|> "bla" :> ReqBody '[JSON] Person :> Post '[JSON] Integer
:<|> "empty" :> Post '[] ()
2014-12-10 16:10:57 +01:00
postApi :: Proxy PostApi
postApi = Proxy
postSpec :: Spec
postSpec = do
describe "Servant.API.Post and .ReqBody" $ do
let server = return . age :<|> return . age :<|> return ()
with (return $ serve postApi server) $ do
2015-01-13 20:40:41 +01:00
let post' x = Test.Hspec.Wai.request methodPost x [(hContentType
2015-01-13 22:40:41 +01:00
, "application/json;charset=utf-8")]
2015-01-13 20:40:41 +01:00
2014-12-10 16:10:57 +01:00
it "allows to POST a Person" $ do
2015-01-13 20:40:41 +01:00
post' "/" (encode alice) `shouldRespondWith` "42"{
2014-12-10 16:10:57 +01:00
matchStatus = 201
}
it "allows alternative routes if all have request bodies" $ do
2015-01-13 20:40:41 +01:00
post' "/bla" (encode alice) `shouldRespondWith` "42"{
matchStatus = 201
}
it "handles trailing '/' gracefully" $ do
2015-01-13 20:40:41 +01:00
post' "/bla/" (encode alice) `shouldRespondWith` "42"{
matchStatus = 201
}
2014-12-10 16:10:57 +01:00
it "correctly rejects invalid request bodies with status 400" $ do
2015-01-13 20:40:41 +01:00
post' "/" "some invalid body" `shouldRespondWith` 400
2014-12-10 16:10:57 +01:00
it "returns 204 if the type is '()'" $ do
post' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 }
it "responds with 415 if the requested media type is unsupported" $ do
let post'' x = Test.Hspec.Wai.request methodPost x [(hContentType
, "application/nonsense")]
post'' "/" "anything at all" `shouldRespondWith` 415
type PutApi =
ReqBody '[JSON] Person :> Put '[JSON] Integer
:<|> "bla" :> ReqBody '[JSON] Person :> Put '[JSON] Integer
:<|> "empty" :> Put '[] ()
putApi :: Proxy PutApi
putApi = Proxy
putSpec :: Spec
putSpec = do
describe "Servant.API.Put and .ReqBody" $ do
let server = return . age :<|> return . age :<|> return ()
with (return $ serve putApi server) $ do
let put' x = Test.Hspec.Wai.request methodPut x [(hContentType
, "application/json;charset=utf-8")]
it "allows to put a Person" $ do
put' "/" (encode alice) `shouldRespondWith` "42"{
matchStatus = 200
}
it "allows alternative routes if all have request bodies" $ do
put' "/bla" (encode alice) `shouldRespondWith` "42"{
matchStatus = 200
}
it "handles trailing '/' gracefully" $ do
put' "/bla/" (encode alice) `shouldRespondWith` "42"{
matchStatus = 200
}
it "correctly rejects invalid request bodies with status 400" $ do
put' "/" "some invalid body" `shouldRespondWith` 400
it "returns 204 if the type is '()'" $ do
put' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 }
it "responds with 415 if the requested media type is unsupported" $ do
let put'' x = Test.Hspec.Wai.request methodPut x [(hContentType
, "application/nonsense")]
put'' "/" "anything at all" `shouldRespondWith` 415
type PatchApi =
ReqBody '[JSON] Person :> Patch '[JSON] Integer
:<|> "bla" :> ReqBody '[JSON] Person :> Patch '[JSON] Integer
:<|> "empty" :> Patch '[] ()
patchApi :: Proxy PatchApi
patchApi = Proxy
patchSpec :: Spec
patchSpec = do
describe "Servant.API.Patch and .ReqBody" $ do
let server = return . age :<|> return . age :<|> return ()
with (return $ serve patchApi server) $ do
let patch' x = Test.Hspec.Wai.request methodPatch x [(hContentType
, "application/json;charset=utf-8")]
it "allows to patch a Person" $ do
patch' "/" (encode alice) `shouldRespondWith` "42"{
matchStatus = 200
}
it "allows alternative routes if all have request bodies" $ do
patch' "/bla" (encode alice) `shouldRespondWith` "42"{
matchStatus = 200
}
it "handles trailing '/' gracefully" $ do
patch' "/bla/" (encode alice) `shouldRespondWith` "42"{
matchStatus = 200
}
it "correctly rejects invalid request bodies with status 400" $ do
patch' "/" "some invalid body" `shouldRespondWith` 400
it "returns 204 if the type is '()'" $ do
patch' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 }
it "responds with 415 if the requested media type is unsupported" $ do
let patch'' x = Test.Hspec.Wai.request methodPatch x [(hContentType
, "application/nonsense")]
patch'' "/" "anything at all" `shouldRespondWith` 415
type HeaderApi a = Header "MyHeader" a :> Delete '[JSON] ()
2015-02-24 14:48:17 +01:00
headerApi :: Proxy (HeaderApi a)
headerApi = Proxy
headerSpec :: Spec
headerSpec = describe "Servant.API.Header" $ do
2015-09-12 14:11:24 +02:00
let expectsInt :: Maybe Int -> ExceptT ServantErr IO ()
2015-02-24 14:48:17 +01:00
expectsInt (Just x) = when (x /= 5) $ error "Expected 5"
expectsInt Nothing = error "Expected an int"
2015-09-12 14:11:24 +02:00
let expectsString :: Maybe String -> ExceptT ServantErr IO ()
2015-02-24 14:48:17 +01:00
expectsString (Just x) = when (x /= "more from you") $ error "Expected more from you"
expectsString Nothing = error "Expected a string"
with (return (serve headerApi expectsInt)) $ do
let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader" ,"5")]
it "passes the header to the handler (Int)" $
delete' "/" "" `shouldRespondWith` 204
with (return (serve headerApi expectsString)) $ do
let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader" ,"more from you")]
it "passes the header to the handler (String)" $
delete' "/" "" `shouldRespondWith` 204
2014-12-10 16:10:57 +01:00
type RawApi = "foo" :> Raw
rawApi :: Proxy RawApi
rawApi = Proxy
rawApplication :: Show a => (Request -> a) -> Application
2015-01-06 17:26:37 +01:00
rawApplication f request_ respond = respond $ responseLBS ok200 [] (cs $ show $ f request_)
2014-12-10 16:10:57 +01:00
rawSpec :: Spec
rawSpec = do
describe "Servant.API.Raw" $ do
it "runs applications" $ do
(flip runSession) (serve rawApi (rawApplication (const (42 :: Integer)))) $ do
response <- Network.Wai.Test.request defaultRequest{
pathInfo = ["foo"]
}
liftIO $ do
simpleBody response `shouldBe` "42"
it "gets the pathInfo modified" $ do
(flip runSession) (serve rawApi (rawApplication pathInfo)) $ do
response <- Network.Wai.Test.request defaultRequest{
pathInfo = ["foo", "bar"]
}
liftIO $ do
simpleBody response `shouldBe` cs (show ["bar" :: String])
type AlternativeApi =
2015-01-12 15:08:41 +01:00
"foo" :> Get '[JSON] Person
:<|> "bar" :> Get '[JSON] Animal
:<|> "foo" :> Get '[PlainText] T.Text
2015-04-06 16:43:36 +02:00
:<|> "bar" :> Post '[JSON] Animal
:<|> "bar" :> Put '[JSON] Animal
:<|> "bar" :> Delete '[JSON] ()
2014-12-10 16:10:57 +01:00
unionApi :: Proxy AlternativeApi
unionApi = Proxy
unionServer :: Server AlternativeApi
unionServer =
return alice
:<|> return jerry
:<|> return "a string"
2015-04-06 16:43:36 +02:00
:<|> return jerry
:<|> return jerry
:<|> return ()
2014-12-10 16:10:57 +01:00
unionSpec :: Spec
unionSpec = do
describe "Servant.API.Alternative" $ do
with (return $ serve unionApi unionServer) $ do
2015-04-06 16:43:36 +02:00
2014-12-10 16:10:57 +01:00
it "unions endpoints" $ do
response <- get "/foo"
liftIO $ do
decode' (simpleBody response) `shouldBe`
Just alice
2015-01-06 17:26:37 +01:00
response_ <- get "/bar"
2014-12-10 16:10:57 +01:00
liftIO $ do
2015-01-06 17:26:37 +01:00
decode' (simpleBody response_) `shouldBe`
2014-12-10 16:10:57 +01:00
Just jerry
2015-04-06 16:43:36 +02:00
it "checks all endpoints before returning 415" $ do
get "/foo" `shouldRespondWith` 200
2015-04-06 16:43:36 +02:00
it "returns 404 if the path does not exist" $ do
get "/nonexistent" `shouldRespondWith` 404
type ResponseHeadersApi =
Get '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String)
:<|> Post '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String)
:<|> Put '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String)
:<|> Patch '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String)
responseHeadersServer :: Server ResponseHeadersApi
responseHeadersServer = let h = return $ addHeader 5 $ addHeader "kilroy" "hi"
in h :<|> h :<|> h :<|> h
responseHeadersSpec :: Spec
responseHeadersSpec = describe "ResponseHeaders" $ do
with (return $ serve (Proxy :: Proxy ResponseHeadersApi) responseHeadersServer) $ do
let methods = [(methodGet, 200), (methodPost, 201), (methodPut, 200), (methodPatch, 200)]
it "includes the headers in the response" $
forM_ methods $ \(method, expected) ->
Test.Hspec.Wai.request method "/" [] ""
`shouldRespondWith` "\"hi\""{ matchHeaders = ["H1" <:> "5", "H2" <:> "kilroy"]
, matchStatus = expected
}
it "responds with not found for non-existent endpoints" $
forM_ methods $ \(method,_) ->
Test.Hspec.Wai.request method "blahblah" [] ""
`shouldRespondWith` 404
it "returns 415 if the Accept header is not supported" $
forM_ methods $ \(method,_) ->
Test.Hspec.Wai.request method "" [(hAccept, "crazy/mime")] ""
`shouldRespondWith` 415
type PrioErrorsApi = ReqBody '[JSON] Person :> "foo" :> Get '[JSON] Integer
prioErrorsApi :: Proxy PrioErrorsApi
prioErrorsApi = Proxy
-- | Test the relative priority of error responses from the server.
--
-- In particular, we check whether matching continues even if a 'ReqBody'
-- or similar construct is encountered early in a path. We don't want to
-- see a complaint about the request body unless the path actually matches.
--
prioErrorsSpec :: Spec
prioErrorsSpec = describe "PrioErrors" $ do
let server = return . age
with (return $ serve prioErrorsApi server) $ do
let check (mdescr, method) path (cdescr, ctype, body) resp =
it fulldescr $
Test.Hspec.Wai.request method path [(hContentType, ctype)] body
`shouldRespondWith` resp
where
fulldescr = "returns " ++ show (matchStatus resp) ++ " on " ++ mdescr
++ " " ++ cs path ++ " (" ++ cdescr ++ ")"
get' = ("GET", methodGet)
put' = ("PUT", methodPut)
txt = ("text" , "text/plain;charset=utf8" , "42" )
ijson = ("invalid json", "application/json;charset=utf8", "invalid" )
vjson = ("valid json" , "application/json;charset=utf8", encode alice)
check get' "/" txt 404
check get' "/bar" txt 404
check get' "/foo" txt 415
check put' "/" txt 404
check put' "/bar" txt 404
check put' "/foo" txt 405
check get' "/" ijson 404
check get' "/bar" ijson 404
check get' "/foo" ijson 400
check put' "/" ijson 404
check put' "/bar" ijson 404
check put' "/foo" ijson 405
check get' "/" vjson 404
check get' "/bar" vjson 404
check get' "/foo" vjson 200
check put' "/" vjson 404
check put' "/bar" vjson 404
check put' "/foo" vjson 405
-- | Test server error functionality.
errorsSpec :: Spec
errorsSpec = do
let he = HttpError status409 (Just "A custom error")
let ib = InvalidBody "The body is invalid"
let wm = WrongMethod
let nf = NotFound
2015-01-13 20:40:41 +01:00
describe "Servant.Server.Internal.RouteMismatch" $ do
it "HttpError > *" $ do
ib <> he `shouldBe` he
wm <> he `shouldBe` he
nf <> he `shouldBe` he
he <> ib `shouldBe` he
he <> wm `shouldBe` he
he <> nf `shouldBe` he
it "HE > InvalidBody > (WM,NF)" $ do
he <> ib `shouldBe` he
wm <> ib `shouldBe` ib
nf <> ib `shouldBe` ib
ib <> he `shouldBe` he
ib <> wm `shouldBe` ib
ib <> nf `shouldBe` ib
it "HE > IB > WrongMethod > NF" $ do
he <> wm `shouldBe` he
ib <> wm `shouldBe` ib
nf <> wm `shouldBe` wm
wm <> he `shouldBe` he
wm <> ib `shouldBe` ib
wm <> nf `shouldBe` wm
it "* > NotFound" $ do
he <> nf `shouldBe` he
ib <> nf `shouldBe` ib
wm <> nf `shouldBe` wm
nf <> he `shouldBe` he
nf <> ib `shouldBe` ib
nf <> wm `shouldBe` wm
2015-10-12 19:23:13 +02:00
routerSpec :: Spec
routerSpec = do
describe "Servant.Server.Internal.Router" $ do
let app' :: Application
app' = toApplication $ runRouter router'
router', router :: Router
router' = tweakResponse (twk <$>) router
router = LeafRouter $ \_ cont -> cont (RR . Right $ responseBuilder (Status 201 "") [] "")
twk :: Response -> Response
twk (ResponseBuilder (Status i s) hs b) = ResponseBuilder (Status (i + 1) s) hs b
twk b = b
describe "tweakResponse" . with (return app') $ do
it "calls f on route result" $ do
get "" `shouldRespondWith` 202
type MiscCombinatorsAPI
= "version" :> HttpVersion :> Get '[JSON] String
:<|> "secure" :> IsSecure :> Get '[JSON] String
:<|> "host" :> RemoteHost :> Get '[JSON] String
miscApi :: Proxy MiscCombinatorsAPI
miscApi = Proxy
miscServ :: Server MiscCombinatorsAPI
miscServ = versionHandler
:<|> secureHandler
:<|> hostHandler
where versionHandler = return . show
secureHandler Secure = return "secure"
secureHandler NotSecure = return "not secure"
hostHandler = return . show
miscReqCombinatorsSpec :: Spec
miscReqCombinatorsSpec = with (return $ serve miscApi miscServ) $
describe "Misc. combinators for request inspection" $ do
it "Successfully gets the HTTP version specified in the request" $
go "/version" "\"HTTP/1.0\""
it "Checks that hspec-wai uses HTTP, not HTTPS" $
go "/secure" "\"not secure\""
it "Checks that hspec-wai issues request from 0.0.0.0" $
go "/host" "\"0.0.0.0:0\""
where go path res = Test.Hspec.Wai.get path `shouldRespondWith` res