servant-server-0.18: test/Servant/Server/ErrorSpec.hs
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Servant.Server.ErrorSpec (spec) where
import Control.Monad
(when)
import Data.Aeson
(encode)
import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString.Lazy.Char8 as BCL
import Data.Monoid
((<>))
import Data.Proxy
import Data.String.Conversions
(cs)
import Network.HTTP.Types
(hAccept, hAuthorization, hContentType, methodGet, methodPost,
methodPut)
import Safe
(readMay)
import Test.Hspec
import Test.Hspec.Wai
import Servant
spec :: Spec
spec = describe "HTTP Errors" $ do
errorOrderSpec
prioErrorsSpec
errorRetrySpec
errorChoiceSpec
customFormattersSpec
-- * Auth machinery (reused throughout)
-- | 'BasicAuthCheck' holds the handler we'll use to verify a username and password.
errorOrderAuthCheck :: BasicAuthCheck ()
errorOrderAuthCheck =
let check (BasicAuthData username password) =
if username == "servant" && password == "server"
then return (Authorized ())
else return Unauthorized
in BasicAuthCheck check
------------------------------------------------------------------------------
-- * Error Order {{{
type ErrorOrderApi = "home"
:> BasicAuth "error-realm" ()
:> ReqBody '[JSON] Int
:> Capture "t" Int
:> QueryParam "param" Int
:> Post '[JSON] Int
errorOrderApi :: Proxy ErrorOrderApi
errorOrderApi = Proxy
errorOrderServer :: Server ErrorOrderApi
errorOrderServer = \_ _ _ _ -> throwError err402
-- On error priorities:
--
-- We originally had
--
-- 404, 405, 401, 415, 400, 406, 402
--
-- but we changed this to
--
-- 404, 405, 401, 406, 415, 400, 402
--
-- for servant-0.7.
--
-- This change is due to the body check being irreversible (to support
-- streaming). Any check done after the body check has to be made fatal,
-- breaking modularity. We've therefore moved the accept check before
-- the body check, to allow it being recoverable and modular, and this
-- goes along with promoting the error priority of 406.
errorOrderSpec :: Spec
errorOrderSpec =
describe "HTTP error order" $
with (return $ serveWithContext errorOrderApi
(errorOrderAuthCheck :. EmptyContext)
errorOrderServer
) $ do
let badContentType = (hContentType, "text/plain")
badAccept = (hAccept, "text/plain")
badMethod = methodGet
badUrl = "nonexistent"
badBody = "nonsense"
badAuth = (hAuthorization, "Basic foofoofoo")
goodContentType = (hContentType, "application/json")
goodAccept = (hAccept, "application/json")
goodMethod = methodPost
goodUrl = "home/2?param=55"
badParams = goodUrl <> "?param=foo"
goodBody = encode (5 :: Int)
-- username:password = servant:server
goodAuth = (hAuthorization, "Basic c2VydmFudDpzZXJ2ZXI=")
it "has 404 as its highest priority error" $ do
request badMethod badUrl [badAuth, badContentType, badAccept] badBody
`shouldRespondWith` 404
it "has 405 as its second highest priority error" $ do
request badMethod badParams [badAuth, badContentType, badAccept] badBody
`shouldRespondWith` 405
it "has 401 as its third highest priority error (auth)" $ do
request goodMethod badParams [badAuth, badContentType, badAccept] badBody
`shouldRespondWith` 401
it "has 406 as its fourth highest priority error" $ do
request goodMethod badParams [goodAuth, badContentType, badAccept] badBody
`shouldRespondWith` 406
it "has 415 as its fifth highest priority error" $ do
request goodMethod badParams [goodAuth, badContentType, goodAccept] badBody
`shouldRespondWith` 415
it "has 400 as its sixth highest priority error" $ do
badParamsRes <- request goodMethod badParams [goodAuth, goodContentType, goodAccept] goodBody
badBodyRes <- request goodMethod goodUrl [goodAuth, goodContentType, goodAccept] badBody
-- Both bad body and bad params result in 400
return badParamsRes `shouldRespondWith` 400
return badBodyRes `shouldRespondWith` 400
-- Param check should occur before body checks
both <- request goodMethod badParams [goodAuth, goodContentType, goodAccept ] badBody
when (both /= badParamsRes) $ liftIO $
expectationFailure $ "badParams + badBody /= badParams: " ++ show both ++ ", " ++ show badParamsRes
when (both == badBodyRes) $ liftIO $
expectationFailure $ "badParams + badBody == badBody: " ++ show both
it "has handler-level errors as last priority" $ do
request goodMethod goodUrl [goodAuth, goodContentType, goodAccept] goodBody
`shouldRespondWith` 402
type PrioErrorsApi = ReqBody '[JSON] Integer :> "foo" :> Get '[JSON] Integer
prioErrorsApi :: Proxy PrioErrorsApi
prioErrorsApi = Proxy
-- 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
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
++ " " ++ BC.unpack 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 (5 :: Int))
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
-- }}}
------------------------------------------------------------------------------
-- * Error Retry {{{
type ErrorRetryApi
= "a" :> ReqBody '[JSON] Int :> Post '[JSON] Int -- err402
:<|> "a" :> ReqBody '[PlainText] Int :> Post '[JSON] Int -- 1
:<|> "a" :> ReqBody '[JSON] Int :> Post '[PlainText] Int -- 2
:<|> "a" :> ReqBody '[JSON] String :> Post '[JSON] Int -- 3
:<|> "a" :> ReqBody '[JSON] Int :> Get '[JSON] Int -- 4
:<|> "a" :> BasicAuth "bar-realm" ()
:> ReqBody '[JSON] Int :> Get '[PlainText] Int -- 5
:<|> "a" :> ReqBody '[JSON] Int :> Get '[PlainText] Int -- 6
:<|> ReqBody '[JSON] Int :> Get '[JSON] Int -- 7
:<|> ReqBody '[JSON] Int :> Post '[JSON] Int -- 8
errorRetryApi :: Proxy ErrorRetryApi
errorRetryApi = Proxy
errorRetryServer :: Server ErrorRetryApi
errorRetryServer
= (\_ -> throwError err402)
:<|> (\_ -> return 1)
:<|> (\_ -> return 2)
:<|> (\_ -> return 3)
:<|> (\_ -> return 4)
:<|> (\_ _ -> return 5)
:<|> (\_ -> return 6)
:<|> (\_ -> return 7)
:<|> (\_ -> return 8)
errorRetrySpec :: Spec
errorRetrySpec =
describe "Handler search" $
with (return $ serveWithContext errorRetryApi
(errorOrderAuthCheck :. EmptyContext)
errorRetryServer
) $ do
let jsonCT = (hContentType, "application/json")
jsonAccept = (hAccept, "application/json")
jsonBody = encode (1797 :: Int)
it "should continue when URLs don't match" $ do
request methodPost "" [jsonCT, jsonAccept] jsonBody
`shouldRespondWith` 200 { matchBody = mkBody $ encode (8 :: Int) }
it "should continue when methods don't match" $ do
request methodGet "a" [jsonCT, jsonAccept] jsonBody
`shouldRespondWith` 200 { matchBody = mkBody $ encode (4 :: Int) }
where
mkBody b = MatchBody $ \_ b' ->
if b == b'
then Nothing
else Just "body not correct\n"
-- }}}
------------------------------------------------------------------------------
-- * Error Choice {{{
type ErrorChoiceApi
= "path0" :> Get '[JSON] Int -- 0
:<|> "path1" :> Post '[JSON] Int -- 1
:<|> "path2" :> Post '[PlainText] Int -- 2
:<|> "path3" :> ReqBody '[JSON] Int :> Post '[PlainText] Int -- 3
:<|> "path4" :> (ReqBody '[PlainText] Int :> Post '[PlainText] Int -- 4
:<|> ReqBody '[PlainText] Int :> Post '[JSON] Int) -- 5
:<|> "path5" :> (ReqBody '[JSON] Int :> Post '[PlainText] Int -- 6
:<|> ReqBody '[PlainText] Int :> Post '[PlainText] Int) -- 7
errorChoiceApi :: Proxy ErrorChoiceApi
errorChoiceApi = Proxy
errorChoiceServer :: Server ErrorChoiceApi
errorChoiceServer = return 0
:<|> return 1
:<|> return 2
:<|> (\_ -> return 3)
:<|> ((\_ -> return 4) :<|> (\_ -> return 5))
:<|> ((\_ -> return 6) :<|> (\_ -> return 7))
errorChoiceSpec :: Spec
errorChoiceSpec = describe "Multiple handlers return errors"
$ with (return $ serve errorChoiceApi errorChoiceServer) $ do
it "should respond with 404 if no path matches" $ do
request methodGet "" [] "" `shouldRespondWith` 404
it "should respond with 405 if a path but not method matches" $ do
request methodGet "path2" [] "" `shouldRespondWith` 405
it "should respond with the corresponding error if path and method match" $ do
request methodPost "path3" [(hContentType, "text/plain;charset=utf-8")] ""
`shouldRespondWith` 415
request methodPost "path3" [(hContentType, "application/json")] ""
`shouldRespondWith` 400
request methodPost "path4" [(hContentType, "text/plain;charset=utf-8"),
(hAccept, "blah")] "5"
`shouldRespondWith` 406
it "should respond with 415 only if none of the subservers supports the request's content type" $ do
request methodPost "path5" [(hContentType, "text/plain;charset=utf-8")] "1"
`shouldRespondWith` 200
request methodPost "path5" [(hContentType, "application/json")] "1"
`shouldRespondWith` 200
request methodPost "path5" [(hContentType, "application/not-supported")] ""
`shouldRespondWith` 415
-- }}}
------------------------------------------------------------------------------
-- * Custom errors {{{
customFormatter :: ErrorFormatter
customFormatter _ _ err = err400 { errBody = "CUSTOM! " <> cs err }
customFormatters :: ErrorFormatters
customFormatters = defaultErrorFormatters
{ bodyParserErrorFormatter = customFormatter
, urlParseErrorFormatter = customFormatter
, notFoundErrorFormatter = const $ err404 { errBody = "CUSTOM! Not Found" }
}
type CustomFormatterAPI
= "query" :> QueryParam' '[Required, Strict] "param" Int :> Get '[PlainText] String
:<|> "capture" :> Capture "cap" Bool :> Get '[PlainText] String
:<|> "body" :> ReqBody '[JSON] Int :> Post '[PlainText] String
customFormatterAPI :: Proxy CustomFormatterAPI
customFormatterAPI = Proxy
customFormatterServer :: Server CustomFormatterAPI
customFormatterServer = (\_ -> return "query")
:<|> (\_ -> return "capture")
:<|> (\_ -> return "body")
customFormattersSpec :: Spec
customFormattersSpec = describe "Custom errors from combinators"
$ with (return $ serveWithContext customFormatterAPI (customFormatters :. EmptyContext) customFormatterServer) $ do
let startsWithCustom = ResponseMatcher
{ matchStatus = 400
, matchHeaders = []
, matchBody = MatchBody $ \_ body -> if "CUSTOM!" `BCL.isPrefixOf` body
then Nothing
else Just $ show body <> " does not start with \"CUSTOM!\""
}
it "formats query parse error" $ do
request methodGet "query?param=false" [] ""
`shouldRespondWith` startsWithCustom
it "formats query parse error with missing param" $ do
request methodGet "query" [] ""
`shouldRespondWith` startsWithCustom
it "formats capture parse error" $ do
request methodGet "capture/42" [] ""
`shouldRespondWith` startsWithCustom
it "formats body parse error" $ do
request methodPost "body" [(hContentType, "application/json")] "foo"
`shouldRespondWith` startsWithCustom
-- }}}
------------------------------------------------------------------------------
-- * Instances {{{
instance MimeUnrender PlainText Int where
mimeUnrender _ x = maybe (Left "no parse") Right (readMay $ BCL.unpack x)
instance MimeRender PlainText Int where
mimeRender _ = BCL.pack . show
-- }}}