{-# 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) 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) 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)