From a2b8d6ae58a9f62078d80238341942d0263a3f28 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Sat, 2 May 2015 03:38:53 +0100 Subject: [PATCH] Better servant-server left --- servant-server/servant-server.cabal | 1 + servant-server/src/Servant/Server.hs | 38 +++ servant-server/src/Servant/Server/Internal.hs | 46 ++-- .../src/Servant/Server/Internal/ServantErr.hs | 229 ++++++++++++++++++ servant-server/test/Servant/ServerSpec.hs | 12 +- servant/src/Servant/API/ResponseHeaders.hs | 2 +- 6 files changed, 292 insertions(+), 36 deletions(-) create mode 100644 servant-server/src/Servant/Server/Internal/ServantErr.hs diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index a95abc05..9c094a20 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -36,6 +36,7 @@ library Servant Servant.Server Servant.Server.Internal + Servant.Server.Internal.ServantErr Servant.Utils.StaticFiles build-depends: base >= 4.7 && < 5 diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index 5489de3d..6cef90f5 100644 --- a/servant-server/src/Servant/Server.hs +++ b/servant-server/src/Servant/Server.hs @@ -15,12 +15,50 @@ module Servant.Server HasServer(..) , Server , ServerT + + -- * Default error type + , ServantErr(..) + -- ** 3XX + , err300 + , err301 + , err302 + , err303 + , err304 + , err305 + , err307 + -- ** 4XX + , err400 + , err401 + , err402 + , err403 + , err404 + , err405 + , err406 + , err407 + , err409 + , err410 + , err411 + , err412 + , err413 + , err414 + , err415 + , err416 + , err417 + -- * 5XX + , err500 + , err501 + , err502 + , err503 + , err504 + , err505 + ) where import Data.Proxy (Proxy) import Network.Wai (Application) import Servant.API (Canonicalize, canonicalize) import Servant.Server.Internal +import Servant.Server.Internal.ServantErr -- * Implementing Servers diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 8db3fb92..fad9c66f 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -50,6 +50,8 @@ import Servant.API.ResponseHeaders (Headers, getResponse, GetHeaders, getHeaders) import Servant.Common.Text (FromText, fromText) +import Servant.Server.Internal.ServantErr + data ReqBodyState = Uncalled | Called !B.ByteString | Done !B.ByteString @@ -180,7 +182,7 @@ class HasServer layout where route :: Proxy layout -> Server' layout -> RoutingApplication type Server layout = Server' (Canonicalize layout) -type Server' layout = ServerT' layout (EitherT (Int, String) IO) +type Server' layout = ServerT' layout (EitherT ServantErr IO) type ServerT layout m = ServerT' (Canonicalize layout) m -- * Instances @@ -266,10 +268,8 @@ instance HasServer Delete where | pathIsEmpty request && requestMethod request == methodDelete = do e <- runEitherT action respond $ succeedWith $ case e of - Right () -> - responseLBS status204 [] "" - Left (status, message) -> - responseLBS (mkStatus status (cs message)) [] (cs message) + Right () -> responseLBS status204 [] "" + Left err -> responseServantErr err | pathIsEmpty request && requestMethod request /= methodDelete = respond $ failWith WrongMethod | otherwise = respond $ failWith NotFound @@ -305,8 +305,7 @@ instance Nothing -> failWith UnsupportedMediaType Just (contentT, body) -> succeedWith $ responseLBS ok200 [ ("Content-Type" , cs contentT)] body - Left (status, message) -> succeedWith $ - responseLBS (mkStatus status (cs message)) [] (cs message) + Left err -> succeedWith $ responseServantErr err | pathIsEmpty request && requestMethod request /= methodGet = respond $ failWith WrongMethod | otherwise = respond $ failWith NotFound @@ -325,8 +324,7 @@ instance e <- runEitherT action respond . succeedWith $ case e of Right () -> responseLBS noContent204 [] "" - Left (status, message) -> - responseLBS (mkStatus status (cs message)) [] (cs message) + Left err -> responseServantErr err | pathIsEmpty request && requestMethod request /= methodGet = respond $ failWith WrongMethod | otherwise = respond $ failWith NotFound @@ -352,8 +350,7 @@ instance Nothing -> failWith UnsupportedMediaType Just (contentT, body) -> succeedWith $ responseLBS ok200 ( ("Content-Type" , cs contentT) : headers) body - Left (status, message) -> succeedWith $ - responseLBS (mkStatus status (cs message)) [] (cs message) + Left err -> succeedWith $ responseServantErr err | pathIsEmpty request && requestMethod request /= methodGet = respond $ failWith WrongMethod | otherwise = respond $ failWith NotFound @@ -422,8 +419,7 @@ instance Nothing -> failWith UnsupportedMediaType Just (contentT, body) -> succeedWith $ responseLBS status201 [ ("Content-Type" , cs contentT)] body - Left (status, message) -> succeedWith $ - responseLBS (mkStatus status (cs message)) [] (cs message) + Left err -> succeedWith $ responseServantErr err | pathIsEmpty request && requestMethod request /= methodPost = respond $ failWith WrongMethod | otherwise = respond $ failWith NotFound @@ -441,8 +437,7 @@ instance e <- runEitherT action respond . succeedWith $ case e of Right () -> responseLBS noContent204 [] "" - Left (status, message) -> - responseLBS (mkStatus status (cs message)) [] (cs message) + Left err -> responseServantErr err | pathIsEmpty request && requestMethod request /= methodPost = respond $ failWith WrongMethod | otherwise = respond $ failWith NotFound @@ -468,8 +463,7 @@ instance Nothing -> failWith UnsupportedMediaType Just (contentT, body) -> succeedWith $ responseLBS status201 ( ("Content-Type" , cs contentT) : headers) body - Left (status, message) -> succeedWith $ - responseLBS (mkStatus status (cs message)) [] (cs message) + Left err -> succeedWith $ responseServantErr err | pathIsEmpty request && requestMethod request /= methodPost = respond $ failWith WrongMethod | otherwise = respond $ failWith NotFound @@ -505,8 +499,7 @@ instance Nothing -> failWith UnsupportedMediaType Just (contentT, body) -> succeedWith $ responseLBS status200 [ ("Content-Type" , cs contentT)] body - Left (status, message) -> succeedWith $ - responseLBS (mkStatus status (cs message)) [] (cs message) + Left err -> succeedWith $ responseServantErr err | pathIsEmpty request && requestMethod request /= methodPut = respond $ failWith WrongMethod | otherwise = respond $ failWith NotFound @@ -524,8 +517,7 @@ instance e <- runEitherT action respond . succeedWith $ case e of Right () -> responseLBS noContent204 [] "" - Left (status, message) -> - responseLBS (mkStatus status (cs message)) [] (cs message) + Left err -> responseServantErr err | pathIsEmpty request && requestMethod request /= methodPut = respond $ failWith WrongMethod | otherwise = respond $ failWith NotFound @@ -551,8 +543,7 @@ instance Nothing -> failWith UnsupportedMediaType Just (contentT, body) -> succeedWith $ responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body - Left (status, message) -> succeedWith $ - responseLBS (mkStatus status (cs message)) [] (cs message) + Left err -> succeedWith $ responseServantErr err | pathIsEmpty request && requestMethod request /= methodPut = respond $ failWith WrongMethod | otherwise = respond $ failWith NotFound @@ -586,8 +577,7 @@ instance Nothing -> failWith UnsupportedMediaType Just (contentT, body) -> succeedWith $ responseLBS status200 [ ("Content-Type" , cs contentT)] body - Left (status, message) -> succeedWith $ - responseLBS (mkStatus status (cs message)) [] (cs message) + Left err -> succeedWith $ responseServantErr err | pathIsEmpty request && requestMethod request /= methodPatch = respond $ failWith WrongMethod | otherwise = respond $ failWith NotFound @@ -605,8 +595,7 @@ instance e <- runEitherT action respond . succeedWith $ case e of Right () -> responseLBS noContent204 [] "" - Left (status, message) -> - responseLBS (mkStatus status (cs message)) [] (cs message) + Left err -> responseServantErr err | pathIsEmpty request && requestMethod request /= methodPatch = respond $ failWith WrongMethod | otherwise = respond $ failWith NotFound @@ -632,8 +621,7 @@ instance Nothing -> failWith UnsupportedMediaType Just (contentT, body) -> succeedWith $ responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body - Left (status, message) -> succeedWith $ - responseLBS (mkStatus status (cs message)) [] (cs message) + Left err -> succeedWith $ responseServantErr err | pathIsEmpty request && requestMethod request /= methodPatch = respond $ failWith WrongMethod | otherwise = respond $ failWith NotFound diff --git a/servant-server/src/Servant/Server/Internal/ServantErr.hs b/servant-server/src/Servant/Server/Internal/ServantErr.hs new file mode 100644 index 00000000..b29a0618 --- /dev/null +++ b/servant-server/src/Servant/Server/Internal/ServantErr.hs @@ -0,0 +1,229 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Servant.Server.Internal.ServantErr where + +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Network.HTTP.Types as HTTP +import Network.Wai (responseLBS, Response) + +data ServantErr = ServantErr { errHTTPCode :: Int + , errReasonPhrase :: String + , errBody :: LBS.ByteString + , errHeaders :: [HTTP.Header] + } deriving (Show, Eq) + +responseServantErr :: ServantErr -> Response +responseServantErr ServantErr{..} = responseLBS status errHeaders errBody + where + status = HTTP.mkStatus errHTTPCode (BS.pack errReasonPhrase) + +err300 :: ServantErr +err300 = ServantErr { errHTTPCode = 300 + , errReasonPhrase = "Multiple Choices" + , errBody = "" + , errHeaders = [] + } + +err301 :: ServantErr +err301 = ServantErr { errHTTPCode = 301 + , errReasonPhrase = "Moved Permanently" + , errBody = "" + , errHeaders = [] + } + +err302 :: ServantErr +err302 = ServantErr { errHTTPCode = 302 + , errReasonPhrase = "Found" + , errBody = "" + , errHeaders = [] + } + +err303 :: ServantErr +err303 = ServantErr { errHTTPCode = 303 + , errReasonPhrase = "See Other" + , errBody = "" + , errHeaders = [] + } + +err304 :: ServantErr +err304 = ServantErr { errHTTPCode = 304 + , errReasonPhrase = "Not Modified" + , errBody = "" + , errHeaders = [] + } + +err305 :: ServantErr +err305 = ServantErr { errHTTPCode = 305 + , errReasonPhrase = "Use Proxy" + , errBody = "" + , errHeaders = [] + } + +err307 :: ServantErr +err307 = ServantErr { errHTTPCode = 307 + , errReasonPhrase = "Temporary Redirect" + , errBody = "" + , errHeaders = [] + } + +err400 :: ServantErr +err400 = ServantErr { errHTTPCode = 400 + , errReasonPhrase = "Bad Request" + , errBody = "" + , errHeaders = [] + } + +err401 :: ServantErr +err401 = ServantErr { errHTTPCode = 401 + , errReasonPhrase = "Unauthorized" + , errBody = "" + , errHeaders = [] + } + +err402 :: ServantErr +err402 = ServantErr { errHTTPCode = 402 + , errReasonPhrase = "Payment Required" + , errBody = "" + , errHeaders = [] + } + +err403 :: ServantErr +err403 = ServantErr { errHTTPCode = 403 + , errReasonPhrase = "Forbidden" + , errBody = "" + , errHeaders = [] + } + +err404 :: ServantErr +err404 = ServantErr { errHTTPCode = 404 + , errReasonPhrase = "Not Found" + , errBody = "" + , errHeaders = [] + } + +err405 :: ServantErr +err405 = ServantErr { errHTTPCode = 405 + , errReasonPhrase = "Method Not Allowed" + , errBody = "" + , errHeaders = [] + } + +err406 :: ServantErr +err406 = ServantErr { errHTTPCode = 406 + , errReasonPhrase = "Not Acceptable" + , errBody = "" + , errHeaders = [] + } + +err407 :: ServantErr +err407 = ServantErr { errHTTPCode = 407 + , errReasonPhrase = "Proxy Authentication Required" + , errBody = "" + , errHeaders = [] + } + +err409 :: ServantErr +err409 = ServantErr { errHTTPCode = 409 + , errReasonPhrase = "Conflict" + , errBody = "" + , errHeaders = [] + } + +err410 :: ServantErr +err410 = ServantErr { errHTTPCode = 410 + , errReasonPhrase = "Gone" + , errBody = "" + , errHeaders = [] + } + +err411 :: ServantErr +err411 = ServantErr { errHTTPCode = 411 + , errReasonPhrase = "Length Required" + , errBody = "" + , errHeaders = [] + } + +err412 :: ServantErr +err412 = ServantErr { errHTTPCode = 412 + , errReasonPhrase = "Precondition Failed" + , errBody = "" + , errHeaders = [] + } + +err413 :: ServantErr +err413 = ServantErr { errHTTPCode = 413 + , errReasonPhrase = "Request Entity Too Large" + , errBody = "" + , errHeaders = [] + } + +err414 :: ServantErr +err414 = ServantErr { errHTTPCode = 414 + , errReasonPhrase = "Request-URI Too Large" + , errBody = "" + , errHeaders = [] + } + +err415 :: ServantErr +err415 = ServantErr { errHTTPCode = 415 + , errReasonPhrase = "Unsupported Media Type" + , errBody = "" + , errHeaders = [] + } + +err416 :: ServantErr +err416 = ServantErr { errHTTPCode = 416 + , errReasonPhrase = "Request range not satisfiable" + , errBody = "" + , errHeaders = [] + } + +err417 :: ServantErr +err417 = ServantErr { errHTTPCode = 417 + , errReasonPhrase = "Expectation Failed" + , errBody = "" + , errHeaders = [] + } + +err500 :: ServantErr +err500 = ServantErr { errHTTPCode = 500 + , errReasonPhrase = "Internal Server Error" + , errBody = "" + , errHeaders = [] + } + +err501 :: ServantErr +err501 = ServantErr { errHTTPCode = 501 + , errReasonPhrase = "Not Implemented" + , errBody = "" + , errHeaders = [] + } + +err502 :: ServantErr +err502 = ServantErr { errHTTPCode = 502 + , errReasonPhrase = "Bad Gateway" + , errBody = "" + , errHeaders = [] + } + +err503 :: ServantErr +err503 = ServantErr { errHTTPCode = 503 + , errReasonPhrase = "Service Unavailable" + , errBody = "" + , errHeaders = [] + } + +err504 :: ServantErr +err504 = ServantErr { errHTTPCode = 504 + , errReasonPhrase = "Gateway Time-out" + , errBody = "" + , errHeaders = [] + } + +err505 :: ServantErr +err505 = ServantErr { errHTTPCode = 505 + , errReasonPhrase = "HTTP Version not supported" + , errBody = "" + , errHeaders = [] + } diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 58ef1244..be8f0665 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -35,13 +35,13 @@ import Test.Hspec.Wai (get, liftIO, matchHeaders, shouldRespondWith, with, (<:>)) import Servant.API ((:<|>) (..), (:>), - AddHeader (addHeader), Capture, + addHeader, Capture, Delete, Get, Header (..), Headers, JSON, MatrixFlag, MatrixParam, MatrixParams, Patch, PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw, ReqBody) -import Servant.Server (Server, serve) +import Servant.Server (Server, serve, ServantErr(..), err404) import Servant.Server.Internal (RouteMismatch (..)) @@ -96,11 +96,11 @@ spec = do type CaptureApi = Capture "legs" Integer :> Get '[JSON] Animal captureApi :: Proxy CaptureApi captureApi = Proxy -captureServer :: Integer -> EitherT (Int, String) IO Animal +captureServer :: Integer -> EitherT ServantErr IO Animal captureServer legs = case legs of 4 -> return jerry 2 -> return tweety - _ -> left (404, "not found") + _ -> left err404 captureSpec :: Spec captureSpec = do @@ -450,11 +450,11 @@ headerApi = Proxy headerSpec :: Spec headerSpec = describe "Servant.API.Header" $ do - let expectsInt :: Maybe Int -> EitherT (Int,String) IO () + let expectsInt :: Maybe Int -> EitherT ServantErr IO () expectsInt (Just x) = when (x /= 5) $ error "Expected 5" expectsInt Nothing = error "Expected an int" - let expectsString :: Maybe String -> EitherT (Int,String) IO () + let expectsString :: Maybe String -> EitherT ServantErr IO () expectsString (Just x) = when (x /= "more from you") $ error "Expected more from you" expectsString Nothing = error "Expected a string" diff --git a/servant/src/Servant/API/ResponseHeaders.hs b/servant/src/Servant/API/ResponseHeaders.hs index 26c83d4e..82555467 100644 --- a/servant/src/Servant/API/ResponseHeaders.hs +++ b/servant/src/Servant/API/ResponseHeaders.hs @@ -25,7 +25,7 @@ -- example above). module Servant.API.ResponseHeaders ( Headers(..) - , addHeader + , AddHeader(addHeader) , BuildHeadersTo(buildHeadersTo) , GetHeaders(getHeaders) , getHeadersHList