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

731 lines
25 KiB
Haskell
Raw Normal View History

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
2014-12-10 16:10:57 +01:00
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
2014-12-10 16:10:57 +01:00
module Servant.ServerSpec where
import Control.Monad (forM_, when)
import Control.Monad.Trans.Either (EitherT, left)
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,
ok200, parseQuery, status409)
import Network.Wai (Application, Request, pathInfo,
queryString, rawQueryString,
responseLBS)
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 ((:<|>) (..), (:>),
2015-05-02 04:38:53 +02:00
addHeader, Capture,
Delete, Get, Header (..), Headers,
HttpVersion, IsSecure(..), JSON, MatrixFlag,
MatrixParam, MatrixParams, Patch, PlainText,
Post, Put, RemoteHost, QueryFlag, QueryParam,
QueryParams, Raw, ReqBody)
2015-05-02 04:38:53 +02:00
import Servant.Server (Server, serve, ServantErr(..), err404)
import Servant.Server.Internal.RoutingApplication
(RouteMismatch (..))
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
2014-12-28 23:07:14 +01:00
matrixParamSpec
2015-02-24 14:48:17 +01:00
headerSpec
2014-12-10 16:10:57 +01:00
rawSpec
unionSpec
prioErrorsSpec
errorsSpec
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-05-02 04:38:53 +02:00
captureServer :: Integer -> EitherT ServantErr IO Animal
2014-12-10 16:10:57 +01:00
captureServer legs = case legs of
4 -> return jerry
2 -> return tweety
2015-05-02 04:38:53 +02:00
_ -> left 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 MatrixParamApi = "a" :> MatrixParam "name" String :> Get '[JSON] Person
:<|> "b" :> MatrixParams "names" String :> "bsub" :> MatrixParams "names" String :> Get '[JSON] Person
:<|> "c" :> MatrixFlag "capitalize" :> Get '[JSON] Person
:<|> "d" :> Capture "foo" Integer :> MatrixParam "name" String :> MatrixFlag "capitalize" :> "dsub" :> Get '[JSON] Person
2014-12-28 23:07:14 +01:00
matrixParamApi :: Proxy MatrixParamApi
matrixParamApi = Proxy
mpServer :: Server MatrixParamApi
mpServer = matrixParamServer :<|> mpNames :<|> mpCapitalize alice :<|> mpComplex
where mpNames (_:name2:_) _ = return alice { name = name2 }
mpNames _ _ = return alice
mpCapitalize p False = return p
mpCapitalize p True = return p { name = map toUpper (name p) }
matrixParamServer (Just name) = return alice{name = name}
matrixParamServer Nothing = return alice
mpAge age p = return p { age = age }
mpComplex capture name cap = matrixParamServer name >>= flip mpCapitalize cap >>= mpAge capture
matrixParamSpec :: Spec
matrixParamSpec = do
describe "Servant.API.MatrixParam" $ do
it "allows to retrieve simple matrix parameters" $
(flip runSession) (serve matrixParamApi mpServer) $ do
response1 <- Network.Wai.Test.request defaultRequest{
pathInfo = ["a;name=bob"]
}
liftIO $ do
decode' (simpleBody response1) `shouldBe` Just alice{
name = "bob"
}
it "allows to retrieve lists in matrix parameters" $
(flip runSession) (serve matrixParamApi mpServer) $ do
response2 <- Network.Wai.Test.request defaultRequest{
pathInfo = ["b;names=bob;names=john", "bsub;names=anna;names=sarah"]
}
liftIO $
decode' (simpleBody response2) `shouldBe` Just alice{
name = "john"
}
it "allows to retrieve value-less matrix parameters" $
(flip runSession) (serve matrixParamApi mpServer) $ do
response3 <- Network.Wai.Test.request defaultRequest{
pathInfo = ["c;capitalize"]
}
liftIO $
decode' (simpleBody response3) `shouldBe` Just alice{
name = "ALICE"
}
response3' <- Network.Wai.Test.request defaultRequest{
pathInfo = ["c;capitalize="]
}
liftIO $
decode' (simpleBody response3') `shouldBe` Just alice{
name = "ALICE"
}
it "allows to retrieve matrix parameters on captured segments" $
(flip runSession) (serve matrixParamApi mpServer) $ do
response4 <- Network.Wai.Test.request defaultRequest{
pathInfo = ["d", "12;name=stephen;capitalize", "dsub"]
}
liftIO $
decode' (simpleBody response4) `shouldBe` Just alice{
name = "STEPHEN",
age = 12
}
response4' <- Network.Wai.Test.request defaultRequest{
pathInfo = ["d;ignored=1", "5", "dsub"]
}
liftIO $
decode' (simpleBody response4') `shouldBe` Just alice{
name = "Alice",
age = 5
}
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-05-02 04:38:53 +02:00
let expectsInt :: Maybe Int -> EitherT 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-05-02 04:38:53 +02:00
let expectsString :: Maybe String -> EitherT 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
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