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

951 lines
35 KiB
Haskell
Raw Normal View History

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeApplications #-}
2017-06-19 17:58:25 +02:00
{-# OPTIONS_GHC -freduction-depth=100 #-}
2014-12-10 16:10:57 +01:00
module Servant.ServerSpec where
2018-11-09 20:49:53 +01:00
import Prelude ()
import Prelude.Compat
2018-06-09 08:31:39 +02:00
import Control.Monad
(forM_, unless, when)
import Control.Monad.Error.Class
(MonadError (..))
import Data.Aeson
(FromJSON, ToJSON, decode', encode)
2018-11-09 20:49:53 +01:00
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as Base64
2018-06-09 08:31:39 +02:00
import Data.Char
(toUpper)
import Data.Maybe
(fromMaybe)
2018-06-09 08:31:39 +02:00
import Data.Proxy
(Proxy (Proxy))
import Data.String
(fromString)
import Data.String.Conversions
(cs)
2018-11-09 20:49:53 +01:00
import qualified Data.Text as T
2018-06-09 08:31:39 +02:00
import GHC.Generics
(Generic)
import Network.HTTP.Types
(QueryItem, Status (..), hAccept, hContentType, imATeapot418,
2018-06-09 08:31:39 +02:00
methodDelete, methodGet, methodHead, methodPatch, methodPost,
methodPut, ok200, parseQuery)
import Network.Wai
(Application, Middleware, Request, pathInfo, queryString,
rawQueryString, requestHeaders, responseLBS)
2018-06-09 08:31:39 +02:00
import Network.Wai.Test
(defaultRequest, request, runSession, simpleBody,
simpleHeaders, simpleStatus)
import Servant.API
((:<|>) (..), (:>), AuthProtect, BasicAuth,
BasicAuthData (BasicAuthData), Capture, Capture', CaptureAll,
Delete, EmptyAPI, Fragment, Get, HasStatus (StatusOf), Header,
Headers, HttpVersion, IsSecure (..), JSON, Lenient,
NoContent (..), NoContentVerb, NoFraming, OctetStream, Patch,
PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw,
RemoteHost, ReqBody, SourceIO, StdMethod (..), Stream, Strict,
UVerb, Union, Verb, WithStatus (..), addHeader)
2018-06-09 08:31:39 +02:00
import Servant.Server
(Context ((:.), EmptyContext), Handler, Server, Tagged (..),
2020-10-31 20:45:46 +01:00
emptyServer, err401, err403, err404, respond, serve,
serveWithContext)
2018-11-09 20:49:53 +01:00
import Servant.Test.ComprehensiveAPI
import qualified Servant.Types.SourceT as S
2018-06-09 08:31:39 +02:00
import Test.Hspec
(Spec, context, describe, it, shouldBe, shouldContain)
import Test.Hspec.Wai
(get, liftIO, matchHeaders, matchStatus, shouldRespondWith,
with, (<:>))
2018-11-09 20:49:53 +01:00
import qualified Test.Hspec.Wai as THW
2018-06-09 08:31:39 +02:00
import Servant.Server.Experimental.Auth
2018-06-09 08:31:39 +02:00
(AuthHandler, AuthServerData, mkAuthHandler)
import Servant.Server.Internal.BasicAuth
(BasicAuthCheck (BasicAuthCheck),
BasicAuthResult (Authorized, Unauthorized))
2016-02-28 23:23:32 +01:00
import Servant.Server.Internal.Context
2018-06-09 08:31:39 +02:00
(NamedContext (..))
2014-12-10 16:10:57 +01:00
-- * comprehensive api test
-- This declaration simply checks that all instances are in place.
2016-02-28 23:23:32 +01:00
_ = serveWithContext comprehensiveAPI comprehensiveApiContext
2016-02-28 23:23:32 +01:00
comprehensiveApiContext :: Context '[NamedContext "foo" '[]]
comprehensiveApiContext = NamedContext EmptyContext :. EmptyContext
2014-12-10 16:10:57 +01:00
2016-01-08 17:43:10 +01:00
-- * Specs
2014-12-10 16:10:57 +01:00
spec :: Spec
spec = do
2016-01-08 17:43:10 +01:00
verbSpec
2020-10-31 20:45:46 +01:00
uverbSpec
2014-12-10 16:10:57 +01:00
captureSpec
captureAllSpec
2014-12-10 16:10:57 +01:00
queryParamSpec
fragmentSpec
2016-01-08 17:43:10 +01:00
reqBodySpec
2015-02-24 14:48:17 +01:00
headerSpec
2014-12-10 16:10:57 +01:00
rawSpec
2016-01-08 17:43:10 +01:00
alternativeSpec
responseHeadersSpec
uverbResponseHeadersSpec
2016-01-08 17:43:10 +01:00
miscCombinatorSpec
basicAuthSpec
genAuthSpec
2016-01-08 17:43:10 +01:00
------------------------------------------------------------------------------
-- * verbSpec {{{
------------------------------------------------------------------------------
type VerbApi method status
= Verb method status '[JSON] Person
:<|> "noContent" :> NoContentVerb method
2016-01-08 17:43:10 +01:00
:<|> "header" :> Verb method status '[JSON] (Headers '[Header "H" Int] Person)
:<|> "headerNC" :> Verb method status '[JSON] (Headers '[Header "H" Int] NoContent)
:<|> "accept" :> ( Verb method status '[JSON] Person
:<|> Verb method status '[PlainText] String
)
:<|> "stream" :> Stream method status NoFraming OctetStream (SourceIO BS.ByteString)
2016-01-08 17:43:10 +01:00
verbSpec :: Spec
verbSpec = describe "Servant.API.Verb" $ do
let server :: Server (VerbApi method status)
server = return alice
:<|> return NoContent
:<|> return (addHeader 5 alice)
:<|> return (addHeader 10 NoContent)
:<|> (return alice :<|> return "B")
:<|> return (S.source ["bytestring"])
2018-06-09 08:31:39 +02:00
2016-01-08 17:43:10 +01:00
get200 = Proxy :: Proxy (VerbApi 'GET 200)
post210 = Proxy :: Proxy (VerbApi 'POST 210)
put203 = Proxy :: Proxy (VerbApi 'PUT 203)
delete280 = Proxy :: Proxy (VerbApi 'DELETE 280)
patch214 = Proxy :: Proxy (VerbApi 'PATCH 214)
wrongMethod m = if m == methodPatch then methodPost else methodPatch
test desc api method (status :: Int) = context desc $
with (return $ serve api server) $ do
2016-01-08 17:43:10 +01:00
-- HEAD and 214/215 need not return bodies
unless (status `elem` [214, 215] || method == methodHead) $
it "returns the person" $ do
response <- THW.request method "/" [] ""
2016-01-08 17:43:10 +01:00
liftIO $ statusCode (simpleStatus response) `shouldBe` status
liftIO $ decode' (simpleBody response) `shouldBe` Just alice
it "returns no content on NoContent" $ do
response <- THW.request method "/noContent" [] ""
liftIO $ statusCode (simpleStatus response) `shouldBe` 204
2016-01-08 17:43:10 +01:00
liftIO $ simpleBody response `shouldBe` ""
-- HEAD should not return body
when (method == methodHead) $
it "HEAD returns no content body" $ do
response <- THW.request method "/" [] ""
2016-01-08 17:43:10 +01:00
liftIO $ simpleBody response `shouldBe` ""
it "throws 405 on wrong method " $ do
THW.request (wrongMethod method) "/" [] ""
2016-01-08 17:43:10 +01:00
`shouldRespondWith` 405
it "returns headers" $ do
response1 <- THW.request method "/header" [] ""
2016-01-08 17:43:10 +01:00
liftIO $ statusCode (simpleStatus response1) `shouldBe` status
liftIO $ simpleHeaders response1 `shouldContain` [("H", "5")]
response2 <- THW.request method "/header" [] ""
2016-01-08 17:43:10 +01:00
liftIO $ statusCode (simpleStatus response2) `shouldBe` status
liftIO $ simpleHeaders response2 `shouldContain` [("H", "5")]
it "handles trailing '/' gracefully" $ do
response <- THW.request method "/headerNC/" [] ""
2016-01-08 17:43:10 +01:00
liftIO $ statusCode (simpleStatus response) `shouldBe` status
it "returns 406 if the Accept header is not supported" $ do
THW.request method "" [(hAccept, "crazy/mime")] ""
2016-01-08 17:43:10 +01:00
`shouldRespondWith` 406
it "responds if the Accept header is supported" $ do
response <- THW.request method ""
2016-01-08 17:43:10 +01:00
[(hAccept, "application/json")] ""
liftIO $ statusCode (simpleStatus response) `shouldBe` status
unless (status `elem` [214, 215] || method == methodHead) $
it "allows modular specification of supported content types" $ do
response <- THW.request method "/accept" [(hAccept, "text/plain")] ""
liftIO $ statusCode (simpleStatus response) `shouldBe` status
liftIO $ simpleBody response `shouldBe` "B"
2016-01-08 17:43:10 +01:00
it "sets the Content-Type header" $ do
response <- THW.request method "" [] ""
2016-01-08 17:43:10 +01:00
liftIO $ simpleHeaders response `shouldContain`
[("Content-Type", "application/json;charset=utf-8")]
2016-01-08 17:43:10 +01:00
2018-06-09 08:31:39 +02:00
it "works for Stream as for Result" $ do
response <- THW.request method "/stream" [] ""
liftIO $ statusCode (simpleStatus response) `shouldBe` status
liftIO $ simpleBody response `shouldBe` "bytestring"
2016-01-08 17:43:10 +01:00
test "GET 200" get200 methodGet 200
test "POST 210" post210 methodPost 210
test "PUT 203" put203 methodPut 203
test "DELETE 280" delete280 methodDelete 280
test "PATCH 214" patch214 methodPatch 214
test "GET 200 with HEAD" get200 methodHead 200
-- }}}
------------------------------------------------------------------------------
-- * captureSpec {{{
------------------------------------------------------------------------------
2014-12-10 16:10:57 +01:00
2015-01-12 15:08:41 +01:00
type CaptureApi = Capture "legs" Integer :> Get '[JSON] Animal
2019-03-18 17:18:24 +01:00
:<|> "ears" :> Capture' '[Lenient] "ears" Integer :> Get '[JSON] Animal
:<|> "eyes" :> Capture' '[Strict] "eyes" Integer :> Get '[JSON] Animal
2014-12-10 16:10:57 +01:00
captureApi :: Proxy CaptureApi
captureApi = Proxy
2019-03-18 17:18:24 +01:00
captureServer :: Server CaptureApi
captureServer = getLegs :<|> getEars :<|> getEyes
where getLegs :: Integer -> Handler Animal
getLegs legs = case legs of
4 -> return jerry
2 -> return tweety
_ -> throwError err404
getEars :: Either String Integer -> Handler Animal
getEars (Left _) = return chimera -- ignore integer parse error, return weird animal
2019-03-18 17:18:24 +01:00
getEars (Right 2) = return jerry
getEars (Right _) = throwError err404
getEyes :: Integer -> Handler Animal
getEyes 2 = return jerry
getEyes _ = throwError 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 400 if the decoding fails" $ do
get "/notAnInt" `shouldRespondWith` 400
2014-12-10 16:10:57 +01:00
2019-03-18 17:18:24 +01:00
it "returns an animal if eyes or ears are 2" $ do
get "/ears/2" `shouldRespondWith` 200
get "/eyes/2" `shouldRespondWith` 200
it "returns a weird animal on Lenient Capture" $ do
response <- get "/ears/bla"
liftIO $ decode' (simpleBody response) `shouldBe` Just chimera
it "returns 400 if parsing integer fails on Strict Capture" $ do
get "/eyes/bla" `shouldRespondWith` 400
2014-12-10 16:10:57 +01:00
with (return (serve
(Proxy :: Proxy (Capture "captured" String :> Raw))
2020-10-31 20:45:46 +01:00
(\ "captured" -> Tagged $ \request_ sendResponse ->
sendResponse $ 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]))
2016-05-26 20:10:15 +02:00
-- }}}
------------------------------------------------------------------------------
-- * captureAllSpec {{{
------------------------------------------------------------------------------
type CaptureAllApi = CaptureAll "legs" Integer :> Get '[JSON] Animal
captureAllApi :: Proxy CaptureAllApi
captureAllApi = Proxy
captureAllServer :: [Integer] -> Handler Animal
captureAllServer legs = case sum legs of
4 -> return jerry
2 -> return tweety
0 -> return beholder
2017-01-16 10:44:25 +01:00
_ -> throwError err404
2016-05-26 20:10:15 +02:00
captureAllSpec :: Spec
captureAllSpec = do
describe "Servant.API.CaptureAll" $ do
with (return (serve captureAllApi captureAllServer)) $ do
it "can capture a single element of the 'pathInfo'" $ do
response <- get "/2"
liftIO $ decode' (simpleBody response) `shouldBe` Just tweety
it "can capture multiple elements of the 'pathInfo'" $ do
response <- get "/2/2"
liftIO $ decode' (simpleBody response) `shouldBe` Just jerry
it "can capture arbitrarily many elements of the 'pathInfo'" $ do
response <- get "/1/1/0/1/0/1"
liftIO $ decode' (simpleBody response) `shouldBe` Just jerry
it "can capture when there are no elements in 'pathInfo'" $ do
response <- get "/"
liftIO $ decode' (simpleBody response) `shouldBe` Just beholder
it "returns 400 if the decoding fails" $ do
get "/notAnInt" `shouldRespondWith` 400
it "returns 400 if the decoding fails, regardless of which element" $ do
get "/1/0/0/notAnInt/3/" `shouldRespondWith` 400
it "returns 400 if the decoding fails, even when it's multiple elements" $ do
get "/1/0/0/notAnInt/3/orange/" `shouldRespondWith` 400
with (return (serve
(Proxy :: Proxy (CaptureAll "segments" String :> Raw))
2020-10-31 20:45:46 +01:00
(\ _captured -> Tagged $ \request_ sendResponse ->
sendResponse $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do
2016-05-26 20:10:15 +02:00
it "consumes everything from pathInfo" $ do
get "/captured/foo/bar/baz" `shouldRespondWith` (fromString (show ([] :: [Int])))
2016-01-08 17:43:10 +01:00
-- }}}
------------------------------------------------------------------------------
-- * queryParamSpec {{{
------------------------------------------------------------------------------
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
:<|> "param" :> QueryParam "age" Integer :> Get '[JSON] Person
:<|> "multiparam" :> QueryParams "ages" Integer :> Get '[JSON] Person
2014-12-10 16:10:57 +01:00
queryParamApi :: Proxy QueryParamApi
queryParamApi = Proxy
qpServer :: Server QueryParamApi
qpServer = queryParamServer :<|> qpNames :<|> qpCapitalize :<|> qpAge :<|> qpAges
2014-12-10 16:10:57 +01:00
where qpNames (_:name2:_) = return alice { name = name2 }
qpNames _ = return alice
qpCapitalize False = return alice
qpCapitalize True = return alice { name = map toUpper (name alice) }
qpAge Nothing = return alice
qpAge (Just age') = return alice{ age = age'}
qpAges ages = return alice{ age = sum ages}
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
2014-12-10 16:10:57 +01:00
queryParamSpec :: Spec
queryParamSpec = do
let mkRequest params pinfo = Network.Wai.Test.request defaultRequest
{ rawQueryString = params
, queryString = parseQuery params
, pathInfo = pinfo
}
2014-12-10 16:10:57 +01:00
describe "Servant.API.QueryParam" $ do
2016-01-14 23:43:48 +01:00
it "allows retrieving simple GET parameters" $
flip runSession (serve queryParamApi qpServer) $ do
response1 <- mkRequest "?name=bob" []
liftIO $ decode' (simpleBody response1) `shouldBe` Just alice
{ name = "bob"
}
2014-12-10 16:10:57 +01:00
2016-01-14 23:43:48 +01:00
it "allows retrieving lists in GET parameters" $
flip runSession (serve queryParamApi qpServer) $ do
response2 <- mkRequest "?names[]=bob&names[]=john" ["a"]
liftIO $ decode' (simpleBody response2) `shouldBe` Just alice
{ name = "john"
}
2014-12-10 16:10:57 +01:00
it "parses a query parameter" $
flip runSession (serve queryParamApi qpServer) $ do
response <- mkRequest "?age=55" ["param"]
liftIO $ decode' (simpleBody response) `shouldBe` Just alice
{ age = 55
}
it "generates an error on query parameter parse failure" $
flip runSession (serve queryParamApi qpServer) $ do
response <- mkRequest "?age=foo" ["param"]
liftIO $ statusCode (simpleStatus response) `shouldBe` 400
return ()
it "parses multiple query parameters" $
flip runSession (serve queryParamApi qpServer) $ do
response <- mkRequest "?ages=10&ages=22" ["multiparam"]
liftIO $ decode' (simpleBody response) `shouldBe` Just alice
{ age = 32
}
it "generates an error on parse failures of multiple parameters" $
flip runSession (serve queryParamApi qpServer) $ do
response <- mkRequest "?ages=2&ages=foo" ["multiparam"]
liftIO $ statusCode (simpleStatus response) `shouldBe` 400
return ()
2016-01-14 23:43:48 +01:00
it "allows retrieving value-less GET parameters" $
flip runSession (serve queryParamApi qpServer) $ do
response3 <- mkRequest "?capitalize" ["b"]
liftIO $ decode' (simpleBody response3) `shouldBe` Just alice
{ name = "ALICE"
}
response3' <- mkRequest "?capitalize=" ["b"]
liftIO $ decode' (simpleBody response3') `shouldBe` Just alice
{ name = "ALICE"
}
response3'' <- mkRequest "?unknown=" ["b"]
liftIO $ decode' (simpleBody response3'') `shouldBe` Just alice
{ name = "Alice"
}
describe "Uses queryString instead of rawQueryString" $ do
-- test query parameters rewriter
let queryRewriter :: Middleware
queryRewriter app req = app req
{ queryString = fmap rewrite $ queryString req
}
where
rewrite :: QueryItem -> QueryItem
rewrite (k, v) = (fromMaybe k (BS.stripPrefix "person_" k), v)
let app = queryRewriter $ serve queryParamApi qpServer
it "allows rewriting for simple GET/query parameters" $
flip runSession app $ do
response1 <- mkRequest "?person_name=bob" []
liftIO $ decode' (simpleBody response1) `shouldBe` Just alice
{ name = "bob"
}
it "allows rewriting for lists in GET parameters" $
flip runSession app $ do
response2 <- mkRequest "?person_names[]=bob&person_names[]=john" ["a"]
liftIO $ decode' (simpleBody response2) `shouldBe` Just alice
{ name = "john"
}
it "allows rewriting when parsing multiple query parameters" $
flip runSession app $ do
response <- mkRequest "?person_ages=10&person_ages=22" ["multiparam"]
liftIO $ decode' (simpleBody response) `shouldBe` Just alice
{ age = 32
}
it "allows retrieving value-less GET parameters" $
flip runSession app $ do
response3 <- mkRequest "?person_capitalize" ["b"]
liftIO $ decode' (simpleBody response3) `shouldBe` Just alice
{ name = "ALICE"
}
response3' <- mkRequest "?person_capitalize=" ["b"]
liftIO $ decode' (simpleBody response3') `shouldBe` Just alice
{ name = "ALICE"
}
response3'' <- mkRequest "?person_unknown=" ["b"]
liftIO $ decode' (simpleBody response3'') `shouldBe` Just alice
{ name = "Alice"
}
2014-12-28 23:07:14 +01:00
-- }}}
------------------------------------------------------------------------------
-- * fragmentSpec {{{
------------------------------------------------------------------------------
type FragmentApi = "name" :> Fragment String :> Get '[JSON] Person
:<|> "age" :> Fragment Integer :> Get '[JSON] Person
fragmentApi :: Proxy FragmentApi
fragmentApi = Proxy
fragServer :: Server FragmentApi
fragServer = fragmentServer :<|> fragAge
where
fragmentServer = return alice
fragAge = return alice
fragmentSpec :: Spec
fragmentSpec = do
let mkRequest params pinfo = Network.Wai.Test.request defaultRequest
{ rawQueryString = params
, queryString = parseQuery params
, pathInfo = pinfo
}
describe "Servant.API.Fragment" $ do
it "ignores fragment even if it is present in query" $ do
flip runSession (serve fragmentApi fragServer) $ do
response1 <- mkRequest "#Alice" ["name"]
liftIO $ decode' (simpleBody response1) `shouldBe` Just alice
2016-01-08 17:43:10 +01:00
-- }}}
------------------------------------------------------------------------------
-- * reqBodySpec {{{
------------------------------------------------------------------------------
type ReqBodyApi = ReqBody '[JSON] Person :> Post '[JSON] Person
:<|> "blah" :> ReqBody '[JSON] Person :> Put '[JSON] Integer
2016-01-08 17:43:10 +01:00
reqBodyApi :: Proxy ReqBodyApi
reqBodyApi = Proxy
2016-01-08 17:43:10 +01:00
reqBodySpec :: Spec
reqBodySpec = describe "Servant.API.ReqBody" $ do
2016-01-08 17:43:10 +01:00
let server :: Server ReqBodyApi
server = return :<|> return . age
mkReq method x = THW.request method x
2016-01-08 17:43:10 +01:00
[(hContentType, "application/json;charset=utf-8")]
with (return $ serve reqBodyApi server) $ do
2016-01-08 17:43:10 +01:00
it "passes the argument to the handler" $ do
response <- mkReq methodPost "" (encode alice)
liftIO $ decode' (simpleBody response) `shouldBe` Just alice
2016-01-08 17:43:10 +01:00
it "rejects invalid request bodies with status 400" $ do
mkReq methodPut "/blah" "some invalid body" `shouldRespondWith` 400
2016-01-08 17:43:10 +01:00
it "responds with 415 if the request body media type is unsupported" $ do
THW.request methodPost "/"
2016-01-08 17:43:10 +01:00
[(hContentType, "application/nonsense")] "" `shouldRespondWith` 415
2016-01-08 17:43:10 +01:00
-- }}}
------------------------------------------------------------------------------
-- * headerSpec {{{
------------------------------------------------------------------------------
type HeaderApi a = Header "MyHeader" a :> Delete '[JSON] NoContent
headerApi :: Proxy a -> Proxy (HeaderApi a)
headerApi _ = Proxy
2015-02-24 14:48:17 +01:00
headerSpec :: Spec
headerSpec = describe "Servant.API.Header" $ do
let expectsInt :: Maybe Int -> Handler NoContent
expectsInt (Just x) = do
when (x /= 5) $ error "Expected 5"
return NoContent
2015-02-24 14:48:17 +01:00
expectsInt Nothing = error "Expected an int"
let expectsString :: Maybe String -> Handler NoContent
expectsString (Just x) = do
when (x /= "more from you") $ error "Expected more from you"
return NoContent
2015-02-24 14:48:17 +01:00
expectsString Nothing = error "Expected a string"
with (return (serve (headerApi (Proxy :: Proxy Int)) expectsInt)) $ do
2016-03-06 21:16:28 +01:00
let delete' x = THW.request methodDelete x [("MyHeader", "5")]
2015-02-24 14:48:17 +01:00
it "passes the header to the handler (Int)" $
delete' "/" "" `shouldRespondWith` 200
2015-02-24 14:48:17 +01:00
with (return (serve (headerApi (Proxy :: Proxy String)) expectsString)) $ do
2016-03-06 21:16:28 +01:00
let delete' x = THW.request methodDelete x [("MyHeader", "more from you")]
2015-02-24 14:48:17 +01:00
it "passes the header to the handler (String)" $
delete' "/" "" `shouldRespondWith` 200
2015-02-24 14:48:17 +01:00
with (return (serve (headerApi (Proxy :: Proxy Int)) expectsInt)) $ do
let delete' x = THW.request methodDelete x [("MyHeader", "not a number")]
it "checks for parse errors" $
delete' "/" "" `shouldRespondWith` 400
2016-01-08 17:43:10 +01:00
-- }}}
------------------------------------------------------------------------------
-- * rawSpec {{{
------------------------------------------------------------------------------
2014-12-10 16:10:57 +01:00
type RawApi = "foo" :> Raw
2016-01-08 17:43:10 +01:00
2014-12-10 16:10:57 +01:00
rawApi :: Proxy RawApi
rawApi = Proxy
2016-01-08 17:43:10 +01:00
rawApplication :: Show a => (Request -> a) -> Tagged m Application
2020-10-31 20:45:46 +01:00
rawApplication f = Tagged $ \request_ sendResponse ->
sendResponse $ 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
2014-12-10 16:10:57 +01:00
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
2014-12-10 16:10:57 +01:00
response <- Network.Wai.Test.request defaultRequest{
pathInfo = ["foo", "bar"]
}
liftIO $ do
simpleBody response `shouldBe` cs (show ["bar" :: String])
2016-01-08 17:43:10 +01:00
-- }}}
------------------------------------------------------------------------------
-- * alternativeSpec {{{
------------------------------------------------------------------------------
2014-12-10 16:10:57 +01:00
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] NoContent
2014-12-10 16:10:57 +01:00
2016-01-08 17:43:10 +01:00
alternativeApi :: Proxy AlternativeApi
alternativeApi = Proxy
alternativeServer :: Server AlternativeApi
alternativeServer =
2014-12-10 16:10:57 +01:00
return alice
:<|> return jerry
:<|> return "a string"
2015-04-06 16:43:36 +02:00
:<|> return jerry
:<|> return jerry
:<|> return NoContent
2014-12-10 16:10:57 +01:00
2016-01-08 17:43:10 +01:00
alternativeSpec :: Spec
alternativeSpec = do
2014-12-10 16:10:57 +01:00
describe "Servant.API.Alternative" $ do
with (return $ serve alternativeApi alternativeServer) $ 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
2016-01-08 17:43:10 +01:00
-- }}}
------------------------------------------------------------------------------
-- * responseHeaderSpec {{{
------------------------------------------------------------------------------
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
2016-01-08 17:43:10 +01:00
let methods = [methodGet, methodPost, methodPut, methodPatch]
it "includes the headers in the response" $
2016-01-08 17:43:10 +01:00
forM_ methods $ \method ->
THW.request method "/" [] ""
`shouldRespondWith` "\"hi\""{ matchHeaders = ["H1" <:> "5", "H2" <:> "kilroy"]
2016-01-08 17:43:10 +01:00
, matchStatus = 200
}
it "responds with not found for non-existent endpoints" $
2016-01-08 17:43:10 +01:00
forM_ methods $ \method ->
THW.request method "blahblah" [] ""
`shouldRespondWith` 404
it "returns 406 if the Accept header is not supported" $
2016-01-08 17:43:10 +01:00
forM_ methods $ \method ->
THW.request method "" [(hAccept, "crazy/mime")] ""
`shouldRespondWith` 406
-- }}}
------------------------------------------------------------------------------
-- * uverbResponseHeaderSpec {{{
------------------------------------------------------------------------------
type UVerbHeaderResponse = '[
WithStatus 200 (Headers '[Header "H1" Int] String),
WithStatus 404 String ]
type UVerbResponseHeadersApi =
Capture "ok" Bool :> UVerb 'GET '[JSON] UVerbHeaderResponse
uverbResponseHeadersServer :: Server UVerbResponseHeadersApi
uverbResponseHeadersServer True = respond . WithStatus @200 . addHeader @"H1" (5 :: Int) $ ("foo" :: String)
uverbResponseHeadersServer False = respond . WithStatus @404 $ ("bar" :: String)
uverbResponseHeadersSpec :: Spec
uverbResponseHeadersSpec = describe "UVerbResponseHeaders" $ do
with (return $ serve (Proxy :: Proxy UVerbResponseHeadersApi) uverbResponseHeadersServer) $ do
it "includes the headers in the response" $
THW.request methodGet "/true" [] ""
`shouldRespondWith` "\"foo\"" { matchHeaders = ["H1" <:> "5"]
, matchStatus = 200
}
2016-01-08 17:43:10 +01:00
-- }}}
------------------------------------------------------------------------------
-- * miscCombinatorSpec {{{
------------------------------------------------------------------------------
type MiscCombinatorsAPI
= "version" :> HttpVersion :> Get '[JSON] String
:<|> "secure" :> IsSecure :> Get '[JSON] String
:<|> "host" :> RemoteHost :> Get '[JSON] String
2017-05-16 12:18:57 +02:00
:<|> "empty" :> EmptyAPI
miscApi :: Proxy MiscCombinatorsAPI
miscApi = Proxy
miscServ :: Server MiscCombinatorsAPI
miscServ = versionHandler
:<|> secureHandler
:<|> hostHandler
2017-05-16 17:59:41 +02:00
:<|> emptyServer
where versionHandler = return . show
secureHandler Secure = return "secure"
secureHandler NotSecure = return "not secure"
hostHandler = return . show
2016-01-08 17:43:10 +01:00
miscCombinatorSpec :: Spec
miscCombinatorSpec = 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\""
2017-05-16 12:18:57 +02:00
it "Doesn't serve anything from the empty API" $
Test.Hspec.Wai.get "empty" `shouldRespondWith` 404
where go path res = Test.Hspec.Wai.get path `shouldRespondWith` res
-- }}}
------------------------------------------------------------------------------
-- * Basic Authentication {{{
------------------------------------------------------------------------------
type BasicAuthAPI =
BasicAuth "foo" () :> "basic" :> Get '[JSON] Animal
:<|> Raw
basicAuthApi :: Proxy BasicAuthAPI
basicAuthApi = Proxy
2016-04-06 04:59:49 +02:00
basicAuthServer :: Server BasicAuthAPI
basicAuthServer =
const (return jerry) :<|>
2020-10-31 20:45:46 +01:00
(Tagged $ \ _ sendResponse -> sendResponse $ responseLBS imATeapot418 [] "")
basicAuthContext :: Context '[ BasicAuthCheck () ]
basicAuthContext =
2016-04-06 04:59:49 +02:00
let basicHandler = BasicAuthCheck $ \(BasicAuthData usr pass) ->
if usr == "servant" && pass == "server"
2016-04-06 04:59:49 +02:00
then return (Authorized ())
else return Unauthorized
in basicHandler :. EmptyContext
basicAuthSpec :: Spec
basicAuthSpec = do
describe "Servant.API.BasicAuth" $ do
with (return (serveWithContext basicAuthApi basicAuthContext basicAuthServer)) $ do
context "Basic Authentication" $ do
2016-04-06 09:24:30 +02:00
let basicAuthHeaders user password =
[("Authorization", "Basic " <> Base64.encode (user <> ":" <> password))]
it "returns 401 when no credentials given" $ do
get "/basic" `shouldRespondWith` 401
2016-04-06 04:59:49 +02:00
it "returns 403 when invalid credentials given" $ do
2016-04-06 09:24:30 +02:00
THW.request methodGet "/basic" (basicAuthHeaders "servant" "wrong") ""
`shouldRespondWith` 403
it "returns 200 with the right password" $ do
2016-04-06 09:24:30 +02:00
THW.request methodGet "/basic" (basicAuthHeaders "servant" "server") ""
2016-04-06 04:59:49 +02:00
`shouldRespondWith` 200
it "plays nice with subsequent Raw endpoints" $ do
get "/foo" `shouldRespondWith` 418
-- }}}
------------------------------------------------------------------------------
-- * General Authentication {{{
------------------------------------------------------------------------------
type GenAuthAPI = AuthProtect "auth" :> "auth" :> Get '[JSON] Animal
:<|> Raw
2016-04-06 04:59:49 +02:00
genAuthApi :: Proxy GenAuthAPI
genAuthApi = Proxy
2016-04-06 04:59:49 +02:00
genAuthServer :: Server GenAuthAPI
genAuthServer = const (return tweety)
2020-10-31 20:45:46 +01:00
:<|> (Tagged $ \ _ sendResponse -> sendResponse $ responseLBS imATeapot418 [] "")
type instance AuthServerData (AuthProtect "auth") = ()
2016-04-06 04:59:49 +02:00
genAuthContext :: Context '[AuthHandler Request ()]
genAuthContext =
let authHandler = \req -> case lookup "Auth" (requestHeaders req) of
Just "secret" -> return ()
2017-01-16 10:44:25 +01:00
Just _ -> throwError err403
Nothing -> throwError err401
in mkAuthHandler authHandler :. EmptyContext
genAuthSpec :: Spec
genAuthSpec = do
describe "Servant.API.Auth" $ do
with (return (serveWithContext genAuthApi genAuthContext genAuthServer)) $ do
context "Custom Auth Protection" $ do
it "returns 401 when missing headers" $ do
get "/auth" `shouldRespondWith` 401
2016-04-06 04:59:49 +02:00
it "returns 403 on wrong passwords" $ do
THW.request methodGet "/auth" [("Auth","wrong")] "" `shouldRespondWith` 403
it "returns 200 with the right header" $ do
THW.request methodGet "/auth" [("Auth","secret")] "" `shouldRespondWith` 200
it "plays nice with subsequent Raw endpoints" $ do
get "/foo" `shouldRespondWith` 418
2020-10-31 20:45:46 +01:00
-- }}}
------------------------------------------------------------------------------
-- * UVerb {{{
------------------------------------------------------------------------------
newtype PersonResponse = PersonResponse Person
deriving Generic
instance ToJSON PersonResponse
instance HasStatus PersonResponse where
type StatusOf PersonResponse = 200
newtype RedirectResponse = RedirectResponse String
deriving Generic
instance ToJSON RedirectResponse
instance HasStatus RedirectResponse where
type StatusOf RedirectResponse = 301
newtype AnimalResponse = AnimalResponse Animal
deriving Generic
instance ToJSON AnimalResponse
instance HasStatus AnimalResponse where
type StatusOf AnimalResponse = 203
type UVerbApi
= "person" :> Capture "shouldRedirect" Bool :> UVerb 'GET '[JSON] '[PersonResponse, RedirectResponse]
:<|> "animal" :> UVerb 'GET '[JSON] '[AnimalResponse]
uverbSpec :: Spec
uverbSpec = describe "Servant.API.UVerb " $ do
let
joe = Person "joe" 42
mouse = Animal "Mouse" 7
personHandler
:: Bool
-> Handler (Union '[PersonResponse
,RedirectResponse])
personHandler True = respond $ RedirectResponse "over there!"
personHandler False = respond $ PersonResponse joe
animalHandler = respond $ AnimalResponse mouse
server :: Server UVerbApi
server = personHandler :<|> animalHandler
with (pure $ serve (Proxy :: Proxy UVerbApi) server) $ do
context "A route returning either 301/String or 200/Person" $ do
context "when requesting the person" $ do
let theRequest = THW.get "/person/false"
it "returns status 200" $
theRequest `shouldRespondWith` 200
it "returns a person" $ do
response <- theRequest
liftIO $ decode' (simpleBody response) `shouldBe` Just joe
context "requesting the redirect" $
it "returns a message and status 301" $
THW.get "/person/true"
`shouldRespondWith` "\"over there!\"" {matchStatus = 301}
context "a route with a single response type" $ do
let theRequest = THW.get "/animal"
it "should return the defined status code" $
theRequest `shouldRespondWith` 203
it "should return the expected response" $ do
response <- theRequest
liftIO $ decode' (simpleBody response) `shouldBe` Just mouse
2016-01-08 17:43:10 +01:00
-- }}}
------------------------------------------------------------------------------
-- * 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
2016-05-26 20:10:15 +02:00
2019-03-18 17:18:24 +01:00
-- weird animal with non-integer amount of ears
chimera :: Animal
chimera = Animal "Chimera" (-1)
2016-05-26 20:10:15 +02:00
beholder :: Animal
beholder = Animal "Beholder" 0
2016-01-08 17:43:10 +01:00
-- }}}