Better servant-server left

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

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

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

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 = []
+                    }

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"
 

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