eeva/servant
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Better servant-server left

Browse Source
This commit is contained in:
Julian K. Arni 2015-05-02 03:38:53 +01:00
parent 5531ada22b
commit a2b8d6ae58
6 changed files with 292 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
servant-server/servant-server.cabal
View File

@ -36,6 +36,7 @@ library
Servant
Servant.Server
Servant.Server.Internal
Servant.Server.Internal.ServantErr
Servant.Utils.StaticFiles
build-depends:
base >= 4.7 && < 5

38
servant-server/src/Servant/Server.hs
View File

@ -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

46
servant-server/src/Servant/Server/Internal.hs
View File

@ -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

229
servant-server/src/Servant/Server/Internal/ServantErr.hs Normal file
View File

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

12
servant-server/test/Servant/ServerSpec.hs
View File

@ -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"

2
servant/src/Servant/API/ResponseHeaders.hs
View File

@ -25,7 +25,7 @@
-- example above).
module Servant.API.ResponseHeaders
( Headers(..)
, addHeader
, AddHeader(addHeader)
, BuildHeadersTo(buildHeadersTo)
, GetHeaders(getHeaders)
, getHeadersHList