154 lines
5.7 KiB
Haskell
154 lines
5.7 KiB
Haskell
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE TypeOperators #-}
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
module Servant.Server.ErrorSpec (spec) where
|
|
|
|
import Data.Aeson (encode)
|
|
import qualified Data.ByteString.Lazy.Char8 as BC
|
|
import Control.Monad.Trans.Either (left)
|
|
import Data.Proxy
|
|
import Network.HTTP.Types (methodGet, methodPost)
|
|
import Test.Hspec
|
|
import Test.Hspec.Wai
|
|
|
|
import Servant
|
|
|
|
|
|
-- 1) Check whether one or more endpoints have the right path. Otherwise return 404.
|
|
-- 2) Check whether the one of those have the right method. Otherwise return
|
|
-- 405. If so, pick the first. We've now commited to calling at most one handler. *
|
|
-- 3) Check whether the Content-Type is known. Otherwise return 415.
|
|
-- 4) Check whether that one deserializes the body. Otherwise return 400. If there
|
|
-- was no Content-Type, try the first one of the API content-type list.
|
|
-- 5) Check whether the request is authorized. Otherwise return a 401.
|
|
-- 6) Check whether the request is forbidden. If so return 403.
|
|
-- 7) Check whether the request has a known Accept. Otherwise return 406.
|
|
-- 8) Check whether Accept-Language, Accept-Charset and Accept-Encoding exist and
|
|
-- match. We can follow the webmachine order here.
|
|
-- 9) Call the handler. Whatever it returns, we return.
|
|
|
|
spec :: Spec
|
|
spec = describe "HTTP Errors" $ do
|
|
errorOrder
|
|
errorRetry
|
|
|
|
------------------------------------------------------------------------------
|
|
-- * Error Order {{{
|
|
|
|
type ErrorOrderApi = "home"
|
|
:> ReqBody '[JSON] Int
|
|
:> Capture "t" Int
|
|
:> Post '[JSON] Int
|
|
|
|
errorOrderApi :: Proxy ErrorOrderApi
|
|
errorOrderApi = Proxy
|
|
|
|
errorOrderServer :: Server ErrorOrderApi
|
|
errorOrderServer = \_ _ -> left err402
|
|
|
|
errorOrder :: Spec
|
|
errorOrder = describe "HTTP error order"
|
|
$ with (return $ serve errorOrderApi errorOrderServer) $ do
|
|
let badContentType = ("Content-Type", "text/plain")
|
|
badAccept = ("Accept", "text/plain")
|
|
badMethod = methodGet
|
|
badUrl = "home/nonexistent"
|
|
badBody = "nonsense"
|
|
goodContentType = ("Content-Type", "application/json")
|
|
goodAccept = ("Accept", "application/json")
|
|
goodMethod = methodPost
|
|
goodUrl = "home/5"
|
|
goodBody = encode (5 :: Int)
|
|
|
|
it "has 404 as its highest priority error" $ do
|
|
request badMethod badUrl [badContentType, badAccept] badBody
|
|
`shouldRespondWith` 404
|
|
|
|
it "has 405 as its second highest priority error" $ do
|
|
request badMethod goodUrl [badContentType, badAccept] badBody
|
|
`shouldRespondWith` 405
|
|
|
|
it "has 415 as its third highest priority error" $ do
|
|
request goodMethod goodUrl [badContentType, badAccept] badBody
|
|
`shouldRespondWith` 415
|
|
|
|
it "has 400 as its fourth highest priority error" $ do
|
|
request goodMethod goodUrl [goodContentType, badAccept] badBody
|
|
`shouldRespondWith` 400
|
|
|
|
it "has 406 as its fifth highest priority error" $ do
|
|
request goodMethod goodUrl [goodContentType, badAccept] goodBody
|
|
`shouldRespondWith` 406
|
|
|
|
it "returns handler errors as its lower priority errors" $ do
|
|
request goodMethod goodUrl [goodContentType, goodAccept] goodBody
|
|
`shouldRespondWith` 402
|
|
|
|
-- }}}
|
|
------------------------------------------------------------------------------
|
|
-- * Error Retry {{{
|
|
|
|
type ErrorRetryApi
|
|
= "a" :> ReqBody '[JSON] Int :> Post '[JSON] Int -- 0
|
|
:<|> "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 '[PlainText] Int -- 4
|
|
:<|> ReqBody '[JSON] Int :> Get '[JSON] Int -- 5
|
|
:<|> ReqBody '[JSON] Int :> Get '[JSON] Int -- 6
|
|
|
|
errorRetryApi :: Proxy ErrorRetryApi
|
|
errorRetryApi = Proxy
|
|
|
|
errorRetryServer :: Server ErrorRetryApi
|
|
errorRetryServer
|
|
= (\_ -> return 0)
|
|
:<|> (\_ -> return 1)
|
|
:<|> (\_ -> return 2)
|
|
:<|> (\_ -> return 3)
|
|
:<|> (\_ -> return 4)
|
|
:<|> (\_ -> return 5)
|
|
:<|> (\_ -> return 6)
|
|
|
|
errorRetry :: Spec
|
|
errorRetry = describe "Handler search"
|
|
$ with (return $ serve errorRetryApi errorRetryServer) $ do
|
|
let plainCT = ("Content-Type", "text/plain")
|
|
plainAccept = ("Accept", "text/plain")
|
|
jsonCT = ("Content-Type", "application/json")
|
|
jsonAccept = ("Accept", "application/json")
|
|
jsonBody = encode (1797 :: Int)
|
|
|
|
it "should continue when URLs don't match" $ do
|
|
request methodPost "" [jsonCT, jsonAccept] jsonBody
|
|
`shouldRespondWith` 201 { matchBody = Just $ encode (5 :: Int) }
|
|
|
|
it "should continue when methods don't match" $ do
|
|
request methodGet "a" [jsonCT, jsonAccept] jsonBody
|
|
`shouldRespondWith` 200 { matchBody = Just $ encode (4 :: Int) }
|
|
|
|
it "should not continue when Content-Types don't match" $ do
|
|
request methodPost "a" [plainCT, jsonAccept] jsonBody
|
|
`shouldRespondWith` 415
|
|
|
|
it "should not continue when body can't be deserialized" $ do
|
|
request methodPost "a" [jsonCT, jsonAccept] (encode ("nonsense" :: String))
|
|
`shouldRespondWith` 400
|
|
|
|
it "should not continue when Accepts don't match" $ do
|
|
request methodPost "a" [jsonCT, plainAccept] jsonBody
|
|
`shouldRespondWith` 406
|
|
|
|
-- }}}
|
|
------------------------------------------------------------------------------
|
|
-- * Instances {{{
|
|
|
|
instance MimeUnrender PlainText Int where
|
|
mimeUnrender _ = Right . read . BC.unpack
|
|
|
|
instance MimeRender PlainText Int where
|
|
mimeRender _ = BC.pack . show
|
|
-- }}}
|