827 lines
30 KiB
Haskell
827 lines
30 KiB
Haskell
{-# LANGUAGE CPP #-}
|
|
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE DeriveGeneric #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE TypeOperators #-}
|
|
{-# LANGUAGE TypeSynonymInstances #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
|
|
module Servant.ServerSpec where
|
|
|
|
|
|
import Control.Monad (forM_, when)
|
|
import Control.Monad.Trans.Except (ExceptT, throwE)
|
|
import Data.Aeson (FromJSON, ToJSON, decode', encode)
|
|
import Data.ByteString (ByteString)
|
|
import Data.ByteString.Conversion ()
|
|
import Data.Char (toUpper)
|
|
#if !MIN_VERSION_base(4,8,0)
|
|
import Data.Monoid ((<>), mempty)
|
|
#else
|
|
import Data.Monoid ((<>))
|
|
#endif
|
|
import Data.Proxy (Proxy (Proxy))
|
|
import Data.String (fromString)
|
|
import Data.String.Conversions (cs)
|
|
import qualified Data.Text as T
|
|
import GHC.Generics (Generic)
|
|
import Network.HTTP.Types (hAccept, hContentType,
|
|
methodDelete, methodGet, methodHead,
|
|
methodPatch, methodPost, methodPut,
|
|
ok200, parseQuery, status409)
|
|
import Network.Wai (Application, Request, pathInfo,
|
|
queryString, rawQueryString,
|
|
responseLBS, responseBuilder)
|
|
import Network.Wai.Test (assertHeader, defaultRequest, request,
|
|
runSession, simpleBody, SResponse)
|
|
import Test.Hspec (Spec, describe, it, shouldBe)
|
|
import Test.Hspec.Wai (get, liftIO, matchHeaders,
|
|
matchStatus, post, request,
|
|
shouldRespondWith, with, (<:>))
|
|
import Test.Hspec.Wai.Internal (WaiSession(WaiSession))
|
|
import Servant.API ((:<|>) (..), (:>),
|
|
addHeader, Capture,
|
|
Delete, Get, Header (..), Headers,
|
|
HttpVersion, IsSecure(..), JSON, MatrixFlag,
|
|
MatrixParam, MatrixParams, Patch, PlainText,
|
|
Post, Put, RemoteHost, QueryFlag, QueryParam,
|
|
QueryParams, Raw, ReqBody)
|
|
import Servant.API.Authentication
|
|
import Servant.Server.Internal.Authentication
|
|
import Servant.Server (Server, serve, ServantErr(..), err404)
|
|
import Servant.Server.Internal (RouteMismatch (..))
|
|
|
|
|
|
-- * test data types
|
|
|
|
data Person = Person {
|
|
name :: String,
|
|
age :: Integer
|
|
}
|
|
deriving (Eq, Show, Generic)
|
|
|
|
instance ToJSON Person
|
|
instance FromJSON Person
|
|
|
|
alice :: Person
|
|
alice = Person "Alice" 42
|
|
|
|
data Animal = Animal {
|
|
species :: String,
|
|
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
|
|
queryParamSpec
|
|
matrixParamSpec
|
|
headerSpec
|
|
rawSpec
|
|
unionSpec
|
|
prioErrorsSpec
|
|
errorsSpec
|
|
responseHeadersSpec
|
|
miscReqCombinatorsSpec
|
|
authRequiredSpec
|
|
|
|
|
|
type CaptureApi = Capture "legs" Integer :> Get '[JSON] Animal
|
|
captureApi :: Proxy CaptureApi
|
|
captureApi = Proxy
|
|
captureServer :: Integer -> ExceptT ServantErr IO Animal
|
|
captureServer legs = case legs of
|
|
4 -> return jerry
|
|
2 -> return tweety
|
|
_ -> throwE err404
|
|
|
|
captureSpec :: Spec
|
|
captureSpec = do
|
|
describe "Servant.API.Capture" $ do
|
|
with (return (serve captureApi captureServer)) $ do
|
|
|
|
it "can capture parts of the 'pathInfo'" $ do
|
|
response <- get "/2"
|
|
liftIO $ decode' (simpleBody response) `shouldBe` Just tweety
|
|
|
|
it "returns 404 if the decoding fails" $ do
|
|
get "/notAnInt" `shouldRespondWith` 404
|
|
|
|
with (return (serve
|
|
(Proxy :: Proxy (Capture "captured" String :> Raw))
|
|
(\ "captured" request_ respond ->
|
|
respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do
|
|
it "strips the captured path snippet from pathInfo" $ do
|
|
get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String]))
|
|
|
|
|
|
type GetApi = Get '[JSON] Person
|
|
:<|> "empty" :> Get '[] ()
|
|
:<|> "post" :> Post '[] ()
|
|
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
|
|
|
|
it "allows to GET a Person" $ do
|
|
response <- get "/"
|
|
return response `shouldRespondWith` 200
|
|
liftIO $ decode' (simpleBody response) `shouldBe` Just alice
|
|
|
|
it "throws 405 (wrong method) on POSTs" $ do
|
|
post "/" "" `shouldRespondWith` 405
|
|
post "/empty" "" `shouldRespondWith` 405
|
|
|
|
it "returns 204 if the type is '()'" $ do
|
|
get "/empty" `shouldRespondWith` ""{ matchStatus = 204 }
|
|
|
|
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
|
|
|
|
|
|
type QueryParamApi = QueryParam "name" String :> Get '[JSON] Person
|
|
:<|> "a" :> QueryParams "names" String :> Get '[JSON] Person
|
|
:<|> "b" :> QueryFlag "capitalize" :> Get '[JSON] Person
|
|
|
|
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) }
|
|
|
|
queryParamServer (Just name_) = return alice{name = name_}
|
|
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"
|
|
}
|
|
|
|
|
|
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"
|
|
}
|
|
|
|
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
|
|
|
|
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 =
|
|
ReqBody '[JSON] Person :> Post '[JSON] Integer
|
|
:<|> "bla" :> ReqBody '[JSON] Person :> Post '[JSON] Integer
|
|
:<|> "empty" :> Post '[] ()
|
|
|
|
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
|
|
let post' x = Test.Hspec.Wai.request methodPost x [(hContentType
|
|
, "application/json;charset=utf-8")]
|
|
|
|
it "allows to POST a Person" $ do
|
|
post' "/" (encode alice) `shouldRespondWith` "42"{
|
|
matchStatus = 201
|
|
}
|
|
|
|
it "allows alternative routes if all have request bodies" $ do
|
|
post' "/bla" (encode alice) `shouldRespondWith` "42"{
|
|
matchStatus = 201
|
|
}
|
|
|
|
it "handles trailing '/' gracefully" $ do
|
|
post' "/bla/" (encode alice) `shouldRespondWith` "42"{
|
|
matchStatus = 201
|
|
}
|
|
|
|
it "correctly rejects invalid request bodies with status 400" $ do
|
|
post' "/" "some invalid body" `shouldRespondWith` 400
|
|
|
|
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] ()
|
|
headerApi :: Proxy (HeaderApi a)
|
|
headerApi = Proxy
|
|
|
|
headerSpec :: Spec
|
|
headerSpec = describe "Servant.API.Header" $ do
|
|
|
|
let expectsInt :: Maybe Int -> ExceptT ServantErr IO ()
|
|
expectsInt (Just x) = when (x /= 5) $ error "Expected 5"
|
|
expectsInt Nothing = error "Expected an int"
|
|
|
|
let expectsString :: Maybe String -> ExceptT ServantErr IO ()
|
|
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
|
|
|
|
|
|
type RawApi = "foo" :> Raw
|
|
rawApi :: Proxy RawApi
|
|
rawApi = Proxy
|
|
rawApplication :: Show a => (Request -> a) -> Application
|
|
rawApplication f request_ respond = respond $ responseLBS ok200 [] (cs $ show $ f request_)
|
|
|
|
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 =
|
|
"foo" :> Get '[JSON] Person
|
|
:<|> "bar" :> Get '[JSON] Animal
|
|
:<|> "foo" :> Get '[PlainText] T.Text
|
|
:<|> "bar" :> Post '[JSON] Animal
|
|
:<|> "bar" :> Put '[JSON] Animal
|
|
:<|> "bar" :> Delete '[JSON] ()
|
|
unionApi :: Proxy AlternativeApi
|
|
unionApi = Proxy
|
|
|
|
unionServer :: Server AlternativeApi
|
|
unionServer =
|
|
return alice
|
|
:<|> return jerry
|
|
:<|> return "a string"
|
|
:<|> return jerry
|
|
:<|> return jerry
|
|
:<|> return ()
|
|
|
|
unionSpec :: Spec
|
|
unionSpec = do
|
|
describe "Servant.API.Alternative" $ do
|
|
with (return $ serve unionApi unionServer) $ do
|
|
|
|
it "unions endpoints" $ do
|
|
response <- get "/foo"
|
|
liftIO $ do
|
|
decode' (simpleBody response) `shouldBe`
|
|
Just alice
|
|
response_ <- get "/bar"
|
|
liftIO $ do
|
|
decode' (simpleBody response_) `shouldBe`
|
|
Just jerry
|
|
|
|
it "checks all endpoints before returning 415" $ do
|
|
get "/foo" `shouldRespondWith` 200
|
|
|
|
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
|
|
|
|
|
|
-- | fake equality to use for testing the RouteMismatch spec (errorSpec).
|
|
-- this is a hack around RouteMismatch not having an `Eq` instance.
|
|
(=:=) :: RouteMismatch -> RouteMismatch -> Bool
|
|
NotFound =:= NotFound = True
|
|
WrongMethod =:= WrongMethod = True
|
|
(InvalidBody ib1) =:= (InvalidBody ib2) = ib1 == ib2
|
|
(HttpError s1 hs1 mb1) =:= (HttpError s2 hs2 mb2) = s1 == s2 && hs1 == hs2 && mb1 == mb2
|
|
(RouteMismatch _) =:= (RouteMismatch _) = True
|
|
_ =:= _ = False
|
|
|
|
-- | 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
|
|
let rm = RouteMismatch (responseBuilder status409 [] mempty)
|
|
|
|
describe "Servant.Server.Internal.RouteMismatch" $ do
|
|
it "RouteMismatch > *" $ do
|
|
(ib <> rm) =:= rm `shouldBe` True
|
|
(wm <> rm) =:= rm `shouldBe` True
|
|
(nf <> rm) =:= rm `shouldBe` True
|
|
(he <> rm) =:= rm `shouldBe` True
|
|
|
|
(rm <> ib) =:= rm `shouldBe` True
|
|
(rm <> wm) =:= rm `shouldBe` True
|
|
(rm <> nf) =:= rm `shouldBe` True
|
|
(rm <> he) =:= rm `shouldBe` True
|
|
|
|
it "RouteMismatch > HttpError > *" $ do
|
|
(ib <> he) =:= he `shouldBe` True
|
|
(wm <> he) =:= he `shouldBe` True
|
|
(nf <> he) =:= he `shouldBe` True
|
|
|
|
(he <> ib) =:= he `shouldBe` True
|
|
(he <> wm) =:= he `shouldBe` True
|
|
(he <> nf) =:= he `shouldBe` True
|
|
|
|
it "HE > InvalidBody > (WM,NF)" $ do
|
|
(wm <> ib) =:= ib `shouldBe` True
|
|
(nf <> ib) =:= ib `shouldBe` True
|
|
|
|
(ib <> wm) =:= ib `shouldBe` True
|
|
(ib <> nf) =:= ib `shouldBe` True
|
|
|
|
it "HE > IB > WrongMethod > NF" $ do
|
|
(nf <> wm) =:= wm `shouldBe` True
|
|
|
|
(wm <> nf) =:= wm `shouldBe` True
|
|
|
|
-- TODO: this is redundant, but maybe helpful for clarity.
|
|
it "* > NotFound" $ do
|
|
(he <> nf) =:= he `shouldBe` True
|
|
(ib <> nf) =:= ib `shouldBe` True
|
|
(wm <> nf) =:= wm `shouldBe` True
|
|
(rm <> nf) =:= rm `shouldBe` True
|
|
|
|
(nf <> he) =:= he `shouldBe` True
|
|
(nf <> ib) =:= ib `shouldBe` True
|
|
(nf <> wm) =:= wm `shouldBe` True
|
|
(nf <> rm) =:= rm `shouldBe` True
|
|
|
|
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
|
|
|
|
|
|
-- | we include two endpoints /foo and /bar and we put the BasicAuth
|
|
-- portion in two different places
|
|
type AuthUser = ByteString
|
|
type BasicAuthFooRealm = AuthProtect (BasicAuth "foo-realm") AuthUser 'Strict
|
|
type BasicAuthBarRealm = AuthProtect (BasicAuth "bar-realm") AuthUser 'Strict
|
|
type AuthRequiredAPI = BasicAuthFooRealm :> "foo" :> Get '[JSON] Person
|
|
:<|> "bar" :> BasicAuthBarRealm :> Get '[JSON] Animal
|
|
|
|
basicAuthFooCheck :: BasicAuth "foo-realm" -> IO (Maybe AuthUser)
|
|
basicAuthFooCheck (BasicAuth user pass) = if user == "servant" && pass == "server"
|
|
then return (Just "servant")
|
|
else return Nothing
|
|
|
|
basicAuthBarCheck :: BasicAuth "bar-realm" -> IO (Maybe AuthUser)
|
|
basicAuthBarCheck (BasicAuth usr pass) = if usr == "bar" && pass == "bar"
|
|
then return (Just "bar")
|
|
else return Nothing
|
|
authRequiredApi :: Proxy AuthRequiredAPI
|
|
authRequiredApi = Proxy
|
|
|
|
authRequiredServer :: Server AuthRequiredAPI
|
|
authRequiredServer = basicAuthStrict basicAuthFooCheck (const . return $ alice)
|
|
:<|> basicAuthStrict basicAuthBarCheck (const . return $ jerry)
|
|
|
|
-- base64-encoded "servant:server"
|
|
base64ServantColonServer :: ByteString
|
|
base64ServantColonServer = "c2VydmFudDpzZXJ2ZXI="
|
|
|
|
-- base64-encoded "bar:bar"
|
|
base64BarColonPassword :: ByteString
|
|
base64BarColonPassword = "YmFyOmJhcg=="
|
|
|
|
-- base64-encoded "user:password"
|
|
base64UserColonPassword :: ByteString
|
|
base64UserColonPassword = "dXNlcjpwYXNzd29yZA=="
|
|
|
|
authGet :: ByteString -> ByteString -> WaiSession SResponse
|
|
authGet path base64EncodedAuth = Test.Hspec.Wai.request methodGet path [("Authorization", "Basic " <> base64EncodedAuth)] ""
|
|
|
|
authRequiredSpec :: Spec
|
|
authRequiredSpec = do
|
|
describe "Servant.API.Authentication" $ do
|
|
with (return $ serve authRequiredApi authRequiredServer) $ do
|
|
it "allows access with the correct username and password" $ do
|
|
response <- authGet "/foo" base64ServantColonServer
|
|
liftIO $ do
|
|
decode' (simpleBody response) `shouldBe` Just alice
|
|
|
|
response <- authGet "/bar" base64BarColonPassword
|
|
liftIO $ do
|
|
decode' (simpleBody response) `shouldBe` Just jerry
|
|
|
|
it "rejects requests with the incorrect username and password" $ do
|
|
authGet "/foo" base64UserColonPassword `shouldRespondWith` 401
|
|
authGet "/bar" base64UserColonPassword `shouldRespondWith` 401
|
|
|
|
it "does not respond to non-authenticated requests" $ do
|
|
get "/foo" `shouldRespondWith` 401
|
|
get "/bar" `shouldRespondWith` 401
|
|
|
|
it "adds the appropriate header to rejected 401 requests" $ do
|
|
foo401 <- get "/foo"
|
|
bar401 <- get "/bar"
|
|
WaiSession (assertHeader "WWW-Authenticate" "Basic realm=\"foo-realm\"" foo401)
|
|
WaiSession (assertHeader "WWW-Authenticate" "Basic realm=\"bar-realm\"" bar401)
|