{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} module Hspec.Router.Error where import Control.Monad (Monad(..)) import Data.Int (Int) import Data.Either (Either(..)) import Data.Maybe (Maybe(..)) import Data.Function (($), (.)) import System.IO (IO) import Text.Show (Show(..)) import Text.Read (readMaybe) import Test.Hspec import Test.Hspec.Wai import Test.Tasty import Test.Tasty import Test.Tasty.Hspec import Data.Semigroup (Semigroup(..)) import qualified Data.ByteString.Lazy as BSL import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL import qualified Network.HTTP.Types as HTTP import qualified Network.Wai.Handler.Warp as Warp import Symantic.HTTP api = segment "good" <.> capture @Int "i" <.> query @Int "param" <.> endpoint @Int @PlainText HTTP.methodPost rtr = runRouter api $ route_good where route_good i qry (RouterEndpointArg respond) = RouterResponse $ \_req res -> do res $ respond status200 [] i srv :: IO () srv = Warp.run 8080 rtr instance MimeSerialize PlainText Int where mimeSerialize _mt = BSL.fromStrict . Text.encodeUtf8 . Text.pack . show instance MimeUnserialize PlainText Int where mimeUnserialize _mt s = case readMaybe $ TL.unpack $ TL.decodeUtf8 s of Just n -> Right n _ -> Left "cannot parse Int" hspec = testSpec "Error order" $ with (return rtr) $ do it "has 404 as its highest priority error" $ do request badMethod badURI [badAuth, badContentType, badAccept] badBody `shouldRespondWith` 404 it "has 405 as its second highest priority error" $ do request badMethod badParam [badAuth, badContentType, badAccept] badBody `shouldRespondWith` 405 it "has 401 as its third highest priority error (auth)" $ do request goodMethod badParam [badAuth, badContentType, badAccept] badBody `shouldRespondWith` 401 it "has 406 as its fourth highest priority error" $ do request goodMethod badParam [goodAuth, badContentType, badAccept] badBody `shouldRespondWith` 406 badContentType = (HTTP.hContentType, "application/json") badAccept = (HTTP.hAccept, "text/plain") badMethod = HTTP.methodGet badURI = "bad" badBody = "bad" badAuth = (HTTP.hAuthorization, "Basic foofoofoo") goodContentType = (HTTP.hContentType, "text/plain") goodAccept = (HTTP.hAccept, "text/plain") goodMethod = HTTP.methodPost goodPath = "good/4" goodURI = goodPath<>"?param=2" badParam = goodPath<>"?param=foo" goodBody = {-encode-} (42::Int) -- username:password = servant:server goodAuth = (HTTP.hAuthorization, "Basic c2VydmFudDpzZXJ2ZXI=") {- {-# 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 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 -- * 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 -- }}} ------------------------------------------------------------------------------ -- * 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 -- }}} -}