git.iko.soy/typeable/servant
on master help sign in
Better servant-server left
commita2b8d6ae58a9f62078d80238341942d0263a3f28 authorJulian K. Arni <jkarni@gmail.com> dateSat 2 May 2015, 03:38 (11 years ago) parent5531ada
6 files changed+292−36
compare with master
unifiedsplit
servant-server/servant-server.cabal+1 servant-server/src/Servant/Server.hs+38 servant-server/src/Servant/Server/Internal.hs+17−29 servant-server/src/Servant/Server/Internal/ServantErr.hs+229 servant-server/test/Servant/ServerSpec.hs+6−6 servant/src/Servant/API/ResponseHeaders.hs+1−1
servant-server/servant-server.cabal+1
@@ -36,6 +36,7 @@ library
3636 Servant
3737 Servant.Server
3838 Servant.Server.Internal
39+ Servant.Server.Internal.ServantErr
3940 Servant.Utils.StaticFiles
4041 build-depends:
4142 base >= 4.7 && < 5
servant-server/src/Servant/Server.hs+38
@@ -15,12 +15,50 @@ module Servant.Server
1515 HasServer(..)
1616 , Server
1717 , ServerT
18+
19+ -- * Default error type
20+ , ServantErr(..)
21+ -- ** 3XX
22+ , err300
23+ , err301
24+ , err302
25+ , err303
26+ , err304
27+ , err305
28+ , err307
29+ -- ** 4XX
30+ , err400
31+ , err401
32+ , err402
33+ , err403
34+ , err404
35+ , err405
36+ , err406
37+ , err407
38+ , err409
39+ , err410
40+ , err411
41+ , err412
42+ , err413
43+ , err414
44+ , err415
45+ , err416
46+ , err417
47+ -- * 5XX
48+ , err500
49+ , err501
50+ , err502
51+ , err503
52+ , err504
53+ , err505
54+
1855 ) where
1956
2057import Data.Proxy (Proxy)
2158import Network.Wai (Application)
2259import Servant.API (Canonicalize, canonicalize)
2360import Servant.Server.Internal
61+import Servant.Server.Internal.ServantErr
2462
2563
2664-- * Implementing Servers
servant-server/src/Servant/Server/Internal.hs+17−29
@@ -50,6 +50,8 @@ import Servant.API.ResponseHeaders (Headers, getResponse, GetHeaders,
5050 getHeaders)
5151import Servant.Common.Text (FromText, fromText)
5252
53+import Servant.Server.Internal.ServantErr
54+
5355data ReqBodyState = Uncalled
5456 | Called !B.ByteString
5557 | Done !B.ByteString
@@ -180,7 +182,7 @@ class HasServer layout where
180182 route :: Proxy layout -> Server' layout -> RoutingApplication
181183
182184type Server layout = Server' (Canonicalize layout)
183−type Server' layout = ServerT' layout (EitherT (Int, String) IO)
185+type Server' layout = ServerT' layout (EitherT ServantErr IO)
184186type ServerT layout m = ServerT' (Canonicalize layout) m
185187
186188-- * Instances
@@ -266,10 +268,8 @@ instance HasServer Delete where
266268 | pathIsEmpty request && requestMethod request == methodDelete = do
267269 e <- runEitherT action
268270 respond $ succeedWith $ case e of
269− Right () ->
270− responseLBS status204 [] ""
271− Left (status, message) ->
272− responseLBS (mkStatus status (cs message)) [] (cs message)
271+ Right () -> responseLBS status204 [] ""
272+ Left err -> responseServantErr err
273273 | pathIsEmpty request && requestMethod request /= methodDelete =
274274 respond $ failWith WrongMethod
275275 | otherwise = respond $ failWith NotFound
@@ -305,8 +305,7 @@ instance
305305 Nothing -> failWith UnsupportedMediaType
306306 Just (contentT, body) -> succeedWith $
307307 responseLBS ok200 [ ("Content-Type" , cs contentT)] body
308− Left (status, message) -> succeedWith $
309− responseLBS (mkStatus status (cs message)) [] (cs message)
308+ Left err -> succeedWith $ responseServantErr err
310309 | pathIsEmpty request && requestMethod request /= methodGet =
311310 respond $ failWith WrongMethod
312311 | otherwise = respond $ failWith NotFound
@@ -325,8 +324,7 @@ instance
325324 e <- runEitherT action
326325 respond . succeedWith $ case e of
327326 Right () -> responseLBS noContent204 [] ""
328− Left (status, message) ->
329− responseLBS (mkStatus status (cs message)) [] (cs message)
327+ Left err -> responseServantErr err
330328 | pathIsEmpty request && requestMethod request /= methodGet =
331329 respond $ failWith WrongMethod
332330 | otherwise = respond $ failWith NotFound
@@ -352,8 +350,7 @@ instance
352350 Nothing -> failWith UnsupportedMediaType
353351 Just (contentT, body) -> succeedWith $
354352 responseLBS ok200 ( ("Content-Type" , cs contentT) : headers) body
355− Left (status, message) -> succeedWith $
356− responseLBS (mkStatus status (cs message)) [] (cs message)
353+ Left err -> succeedWith $ responseServantErr err
357354 | pathIsEmpty request && requestMethod request /= methodGet =
358355 respond $ failWith WrongMethod
359356 | otherwise = respond $ failWith NotFound
@@ -422,8 +419,7 @@ instance
422419 Nothing -> failWith UnsupportedMediaType
423420 Just (contentT, body) -> succeedWith $
424421 responseLBS status201 [ ("Content-Type" , cs contentT)] body
425− Left (status, message) -> succeedWith $
426− responseLBS (mkStatus status (cs message)) [] (cs message)
422+ Left err -> succeedWith $ responseServantErr err
427423 | pathIsEmpty request && requestMethod request /= methodPost =
428424 respond $ failWith WrongMethod
429425 | otherwise = respond $ failWith NotFound
@@ -441,8 +437,7 @@ instance
441437 e <- runEitherT action
442438 respond . succeedWith $ case e of
443439 Right () -> responseLBS noContent204 [] ""
444− Left (status, message) ->
445− responseLBS (mkStatus status (cs message)) [] (cs message)
440+ Left err -> responseServantErr err
446441 | pathIsEmpty request && requestMethod request /= methodPost =
447442 respond $ failWith WrongMethod
448443 | otherwise = respond $ failWith NotFound
@@ -468,8 +463,7 @@ instance
468463 Nothing -> failWith UnsupportedMediaType
469464 Just (contentT, body) -> succeedWith $
470465 responseLBS status201 ( ("Content-Type" , cs contentT) : headers) body
471− Left (status, message) -> succeedWith $
472− responseLBS (mkStatus status (cs message)) [] (cs message)
466+ Left err -> succeedWith $ responseServantErr err
473467 | pathIsEmpty request && requestMethod request /= methodPost =
474468 respond $ failWith WrongMethod
475469 | otherwise = respond $ failWith NotFound
@@ -505,8 +499,7 @@ instance
505499 Nothing -> failWith UnsupportedMediaType
506500 Just (contentT, body) -> succeedWith $
507501 responseLBS status200 [ ("Content-Type" , cs contentT)] body
508− Left (status, message) -> succeedWith $
509− responseLBS (mkStatus status (cs message)) [] (cs message)
502+ Left err -> succeedWith $ responseServantErr err
510503 | pathIsEmpty request && requestMethod request /= methodPut =
511504 respond $ failWith WrongMethod
512505 | otherwise = respond $ failWith NotFound
@@ -524,8 +517,7 @@ instance
524517 e <- runEitherT action
525518 respond . succeedWith $ case e of
526519 Right () -> responseLBS noContent204 [] ""
527− Left (status, message) ->
528− responseLBS (mkStatus status (cs message)) [] (cs message)
520+ Left err -> responseServantErr err
529521 | pathIsEmpty request && requestMethod request /= methodPut =
530522 respond $ failWith WrongMethod
531523 | otherwise = respond $ failWith NotFound
@@ -551,8 +543,7 @@ instance
551543 Nothing -> failWith UnsupportedMediaType
552544 Just (contentT, body) -> succeedWith $
553545 responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body
554− Left (status, message) -> succeedWith $
555− responseLBS (mkStatus status (cs message)) [] (cs message)
546+ Left err -> succeedWith $ responseServantErr err
556547 | pathIsEmpty request && requestMethod request /= methodPut =
557548 respond $ failWith WrongMethod
558549 | otherwise = respond $ failWith NotFound
@@ -586,8 +577,7 @@ instance
586577 Nothing -> failWith UnsupportedMediaType
587578 Just (contentT, body) -> succeedWith $
588579 responseLBS status200 [ ("Content-Type" , cs contentT)] body
589− Left (status, message) -> succeedWith $
590− responseLBS (mkStatus status (cs message)) [] (cs message)
580+ Left err -> succeedWith $ responseServantErr err
591581 | pathIsEmpty request && requestMethod request /= methodPatch =
592582 respond $ failWith WrongMethod
593583 | otherwise = respond $ failWith NotFound
@@ -605,8 +595,7 @@ instance
605595 e <- runEitherT action
606596 respond . succeedWith $ case e of
607597 Right () -> responseLBS noContent204 [] ""
608− Left (status, message) ->
609− responseLBS (mkStatus status (cs message)) [] (cs message)
598+ Left err -> responseServantErr err
610599 | pathIsEmpty request && requestMethod request /= methodPatch =
611600 respond $ failWith WrongMethod
612601 | otherwise = respond $ failWith NotFound
@@ -632,8 +621,7 @@ instance
632621 Nothing -> failWith UnsupportedMediaType
633622 Just (contentT, body) -> succeedWith $
634623 responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body
635− Left (status, message) -> succeedWith $
636− responseLBS (mkStatus status (cs message)) [] (cs message)
624+ Left err -> succeedWith $ responseServantErr err
637625 | pathIsEmpty request && requestMethod request /= methodPatch =
638626 respond $ failWith WrongMethod
639627 | otherwise = respond $ failWith NotFound
servant-server/src/Servant/Server/Internal/ServantErr.hsnew file+229
@@ -0,0 +1,229 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE RecordWildCards #-}
3+module Servant.Server.Internal.ServantErr where
4+
5+import qualified Data.ByteString.Char8 as BS
6+import qualified Data.ByteString.Lazy as LBS
7+import qualified Network.HTTP.Types as HTTP
8+import Network.Wai (responseLBS, Response)
9+
10+data ServantErr = ServantErr { errHTTPCode :: Int
11+ , errReasonPhrase :: String
12+ , errBody :: LBS.ByteString
13+ , errHeaders :: [HTTP.Header]
14+ } deriving (Show, Eq)
15+
16+responseServantErr :: ServantErr -> Response
17+responseServantErr ServantErr{..} = responseLBS status errHeaders errBody
18+ where
19+ status = HTTP.mkStatus errHTTPCode (BS.pack errReasonPhrase)
20+
21+err300 :: ServantErr
22+err300 = ServantErr { errHTTPCode = 300
23+ , errReasonPhrase = "Multiple Choices"
24+ , errBody = ""
25+ , errHeaders = []
26+ }
27+
28+err301 :: ServantErr
29+err301 = ServantErr { errHTTPCode = 301
30+ , errReasonPhrase = "Moved Permanently"
31+ , errBody = ""
32+ , errHeaders = []
33+ }
34+
35+err302 :: ServantErr
36+err302 = ServantErr { errHTTPCode = 302
37+ , errReasonPhrase = "Found"
38+ , errBody = ""
39+ , errHeaders = []
40+ }
41+
42+err303 :: ServantErr
43+err303 = ServantErr { errHTTPCode = 303
44+ , errReasonPhrase = "See Other"
45+ , errBody = ""
46+ , errHeaders = []
47+ }
48+
49+err304 :: ServantErr
50+err304 = ServantErr { errHTTPCode = 304
51+ , errReasonPhrase = "Not Modified"
52+ , errBody = ""
53+ , errHeaders = []
54+ }
55+
56+err305 :: ServantErr
57+err305 = ServantErr { errHTTPCode = 305
58+ , errReasonPhrase = "Use Proxy"
59+ , errBody = ""
60+ , errHeaders = []
61+ }
62+
63+err307 :: ServantErr
64+err307 = ServantErr { errHTTPCode = 307
65+ , errReasonPhrase = "Temporary Redirect"
66+ , errBody = ""
67+ , errHeaders = []
68+ }
69+
70+err400 :: ServantErr
71+err400 = ServantErr { errHTTPCode = 400
72+ , errReasonPhrase = "Bad Request"
73+ , errBody = ""
74+ , errHeaders = []
75+ }
76+
77+err401 :: ServantErr
78+err401 = ServantErr { errHTTPCode = 401
79+ , errReasonPhrase = "Unauthorized"
80+ , errBody = ""
81+ , errHeaders = []
82+ }
83+
84+err402 :: ServantErr
85+err402 = ServantErr { errHTTPCode = 402
86+ , errReasonPhrase = "Payment Required"
87+ , errBody = ""
88+ , errHeaders = []
89+ }
90+
91+err403 :: ServantErr
92+err403 = ServantErr { errHTTPCode = 403
93+ , errReasonPhrase = "Forbidden"
94+ , errBody = ""
95+ , errHeaders = []
96+ }
97+
98+err404 :: ServantErr
99+err404 = ServantErr { errHTTPCode = 404
100+ , errReasonPhrase = "Not Found"
101+ , errBody = ""
102+ , errHeaders = []
103+ }
104+
105+err405 :: ServantErr
106+err405 = ServantErr { errHTTPCode = 405
107+ , errReasonPhrase = "Method Not Allowed"
108+ , errBody = ""
109+ , errHeaders = []
110+ }
111+
112+err406 :: ServantErr
113+err406 = ServantErr { errHTTPCode = 406
114+ , errReasonPhrase = "Not Acceptable"
115+ , errBody = ""
116+ , errHeaders = []
117+ }
118+
119+err407 :: ServantErr
120+err407 = ServantErr { errHTTPCode = 407
121+ , errReasonPhrase = "Proxy Authentication Required"
122+ , errBody = ""
123+ , errHeaders = []
124+ }
125+
126+err409 :: ServantErr
127+err409 = ServantErr { errHTTPCode = 409
128+ , errReasonPhrase = "Conflict"
129+ , errBody = ""
130+ , errHeaders = []
131+ }
132+
133+err410 :: ServantErr
134+err410 = ServantErr { errHTTPCode = 410
135+ , errReasonPhrase = "Gone"
136+ , errBody = ""
137+ , errHeaders = []
138+ }
139+
140+err411 :: ServantErr
141+err411 = ServantErr { errHTTPCode = 411
142+ , errReasonPhrase = "Length Required"
143+ , errBody = ""
144+ , errHeaders = []
145+ }
146+
147+err412 :: ServantErr
148+err412 = ServantErr { errHTTPCode = 412
149+ , errReasonPhrase = "Precondition Failed"
150+ , errBody = ""
151+ , errHeaders = []
152+ }
153+
154+err413 :: ServantErr
155+err413 = ServantErr { errHTTPCode = 413
156+ , errReasonPhrase = "Request Entity Too Large"
157+ , errBody = ""
158+ , errHeaders = []
159+ }
160+
161+err414 :: ServantErr
162+err414 = ServantErr { errHTTPCode = 414
163+ , errReasonPhrase = "Request-URI Too Large"
164+ , errBody = ""
165+ , errHeaders = []
166+ }
167+
168+err415 :: ServantErr
169+err415 = ServantErr { errHTTPCode = 415
170+ , errReasonPhrase = "Unsupported Media Type"
171+ , errBody = ""
172+ , errHeaders = []
173+ }
174+
175+err416 :: ServantErr
176+err416 = ServantErr { errHTTPCode = 416
177+ , errReasonPhrase = "Request range not satisfiable"
178+ , errBody = ""
179+ , errHeaders = []
180+ }
181+
182+err417 :: ServantErr
183+err417 = ServantErr { errHTTPCode = 417
184+ , errReasonPhrase = "Expectation Failed"
185+ , errBody = ""
186+ , errHeaders = []
187+ }
188+
189+err500 :: ServantErr
190+err500 = ServantErr { errHTTPCode = 500
191+ , errReasonPhrase = "Internal Server Error"
192+ , errBody = ""
193+ , errHeaders = []
194+ }
195+
196+err501 :: ServantErr
197+err501 = ServantErr { errHTTPCode = 501
198+ , errReasonPhrase = "Not Implemented"
199+ , errBody = ""
200+ , errHeaders = []
201+ }
202+
203+err502 :: ServantErr
204+err502 = ServantErr { errHTTPCode = 502
205+ , errReasonPhrase = "Bad Gateway"
206+ , errBody = ""
207+ , errHeaders = []
208+ }
209+
210+err503 :: ServantErr
211+err503 = ServantErr { errHTTPCode = 503
212+ , errReasonPhrase = "Service Unavailable"
213+ , errBody = ""
214+ , errHeaders = []
215+ }
216+
217+err504 :: ServantErr
218+err504 = ServantErr { errHTTPCode = 504
219+ , errReasonPhrase = "Gateway Time-out"
220+ , errBody = ""
221+ , errHeaders = []
222+ }
223+
224+err505 :: ServantErr
225+err505 = ServantErr { errHTTPCode = 505
226+ , errReasonPhrase = "HTTP Version not supported"
227+ , errBody = ""
228+ , errHeaders = []
229+ }
servant-server/test/Servant/ServerSpec.hs+6−6
@@ -35,13 +35,13 @@ import Test.Hspec.Wai (get, liftIO, matchHeaders,
3535 shouldRespondWith, with, (<:>))
3636
3737import Servant.API ((:<|>) (..), (:>),
38− AddHeader (addHeader), Capture,
38+ addHeader, Capture,
3939 Delete, Get, Header (..), Headers,
4040 JSON, MatrixFlag, MatrixParam,
4141 MatrixParams, Patch, PlainText,
4242 Post, Put, QueryFlag, QueryParam,
4343 QueryParams, Raw, ReqBody)
44−import Servant.Server (Server, serve)
44+import Servant.Server (Server, serve, ServantErr(..), err404)
4545import Servant.Server.Internal (RouteMismatch (..))
4646
4747
@@ -96,11 +96,11 @@ spec = do
9696type CaptureApi = Capture "legs" Integer :> Get '[JSON] Animal
9797captureApi :: Proxy CaptureApi
9898captureApi = Proxy
99−captureServer :: Integer -> EitherT (Int, String) IO Animal
99+captureServer :: Integer -> EitherT ServantErr IO Animal
100100captureServer legs = case legs of
101101 4 -> return jerry
102102 2 -> return tweety
103− _ -> left (404, "not found")
103+ _ -> left err404
104104
105105captureSpec :: Spec
106106captureSpec = do
@@ -450,11 +450,11 @@ headerApi = Proxy
450450headerSpec :: Spec
451451headerSpec = describe "Servant.API.Header" $ do
452452
453− let expectsInt :: Maybe Int -> EitherT (Int,String) IO ()
453+ let expectsInt :: Maybe Int -> EitherT ServantErr IO ()
454454 expectsInt (Just x) = when (x /= 5) $ error "Expected 5"
455455 expectsInt Nothing = error "Expected an int"
456456
457− let expectsString :: Maybe String -> EitherT (Int,String) IO ()
457+ let expectsString :: Maybe String -> EitherT ServantErr IO ()
458458 expectsString (Just x) = when (x /= "more from you") $ error "Expected more from you"
459459 expectsString Nothing = error "Expected a string"
460460
servant/src/Servant/API/ResponseHeaders.hs+1−1
@@ -25,7 +25,7 @@
2525-- example above).
2626module Servant.API.ResponseHeaders
2727 ( Headers(..)
28− , addHeader
28+ , AddHeader(addHeader)
2929 , BuildHeadersTo(buildHeadersTo)
3030 , GetHeaders(getHeaders)
3131 , getHeadersHList