@@ -2,6 +2,7 @@
22{-# LANGUAGE DataKinds #-}
33{-# LANGUAGE FlexibleContexts #-}
44{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
56{-# LANGUAGE OverloadedStrings #-}
67{-# LANGUAGE PolyKinds #-}
78{-# LANGUAGE ScopedTypeVariables #-}
@@ -11,17 +12,20 @@
1112{-# LANGUAGE OverlappingInstances #-}
1213#endif
1314
14−module Servant.Server.Internal where
15+module Servant.Server.Internal
16+ ( module Servant.Server.Internal
17+ , module Servant.Server.Internal.PathInfo
18+ , module Servant.Server.Internal.Router
19+ , module Servant.Server.Internal.RoutingApplication
20+ , module Servant.Server.Internal.ServantErr
21+ ) where
1522
1623#if !MIN_VERSION_base(4,8,0)
1724import Control.Applicative ((<$>))
18−import Data.Monoid (Monoid, mappend, mempty)
1925#endif
20−import Control.Monad.Trans.Either (EitherT, runEitherT)
26+import Control.Monad.Trans.Either (EitherT)
2127import qualified Data.ByteString as B
22−import qualified Data.ByteString.Lazy as BL
23−import Data.IORef (newIORef, readIORef, writeIORef)
24−import Data.List (unfoldr)
28+import qualified Data.Map as M
2529import Data.Maybe (catMaybes, fromMaybe)
2630import Data.String (fromString)
2731import Data.String.Conversions (cs, (<>))
@@ -31,12 +35,9 @@ import Data.Text.Encoding (decodeUtf8, encodeUtf8)
3135import Data.Typeable
3236import GHC.TypeLits (KnownSymbol, symbolVal)
3337import Network.HTTP.Types hiding (Header, ResponseHeaders)
34−import Network.Wai (Application, Request, Response,
35− ResponseReceived, lazyRequestBody,
36− pathInfo, rawQueryString,
37− requestBody, requestHeaders,
38− requestMethod, responseLBS,
39− strictRequestBody)
38+import Network.Wai (Application, lazyRequestBody,
39+ rawQueryString, requestHeaders,
40+ requestMethod, responseLBS)
4041import Servant.API ((:<|>) (..), (:>), Capture,
4142 Delete, Get, Header,
4243 MatrixFlag, MatrixParam, MatrixParams,
@@ -50,136 +51,15 @@ import Servant.API.ResponseHeaders (Headers, getResponse, GetHeaders,
5051 getHeaders)
5152import Servant.Common.Text (FromText, fromText)
5253
54+import Servant.Server.Internal.PathInfo
55+import Servant.Server.Internal.Router
56+import Servant.Server.Internal.RoutingApplication
5357import Servant.Server.Internal.ServantErr
5458
55−data ReqBodyState = Uncalled
56− | Called !B.ByteString
57− | Done !B.ByteString
58−
59−
60−toApplication :: RoutingApplication -> Application
61−toApplication ra request respond = do
62− reqBodyRef <- newIORef Uncalled
63− -- We may need to consume the requestBody more than once. In order to
64− -- maintain the illusion that 'requestBody' works as expected,
65− -- 'ReqBodyState' is introduced, and the complete body is memoized and
66− -- returned as many times as requested with empty "Done" marker chunks in
67− -- between.
68− -- See https://github.com/haskell-servant/servant/issues/3
69− let memoReqBody = do
70− ior <- readIORef reqBodyRef
71− case ior of
72− Uncalled -> do
73− r <- BL.toStrict <$> strictRequestBody request
74− writeIORef reqBodyRef $ Done r
75− return r
76− Called bs -> do
77− writeIORef reqBodyRef $ Done bs
78− return bs
79− Done bs -> do
80− writeIORef reqBodyRef $ Called bs
81− return B.empty
82−
83− ra request{ requestBody = memoReqBody } (routingRespond . routeResult)
84− where
85− routingRespond :: Either RouteMismatch Response -> IO ResponseReceived
86− routingRespond (Left NotFound) =
87− respond $ responseLBS notFound404 [] "not found"
88− routingRespond (Left WrongMethod) =
89− respond $ responseLBS methodNotAllowed405 [] "method not allowed"
90− routingRespond (Left (InvalidBody err)) =
91− respond $ responseLBS badRequest400 [] $ fromString $ "invalid request body: " ++ err
92− routingRespond (Left UnsupportedMediaType) =
93− respond $ responseLBS unsupportedMediaType415 [] "unsupported media type"
94− routingRespond (Left (HttpError status body)) =
95− respond $ responseLBS status [] $ fromMaybe (BL.fromStrict $ statusMessage status) body
96− routingRespond (Right response) =
97− respond response
98−
99−-- Note that the ordering of the constructors has great significance! It
100−-- determines the Ord instance and, consequently, the monoid instance.
101−-- * Route mismatch
102−data RouteMismatch =
103− NotFound -- ^ the usual "not found" error
104− | WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error
105− | UnsupportedMediaType -- ^ request body has unsupported media type
106− | InvalidBody String -- ^ an even more informative "your json request body wasn't valid" error
107− | HttpError Status (Maybe BL.ByteString) -- ^ an even even more informative arbitrary HTTP response code error.
108− deriving (Eq, Ord, Show)
109−
110−instance Monoid RouteMismatch where
111− mempty = NotFound
112− -- The following isn't great, since it picks @InvalidBody@ based on
113− -- alphabetical ordering, but any choice would be arbitrary.
114− --
115− -- "As one judge said to the other, 'Be just and if you can't be just, be
116− -- arbitrary'" -- William Burroughs
117− mappend = max
118−
119−
120−-- | A wrapper around @'Either' 'RouteMismatch' a@.
121−newtype RouteResult a =
122− RR { routeResult :: Either RouteMismatch a }
123− deriving (Eq, Show)
124−
125−failWith :: RouteMismatch -> RouteResult a
126−failWith = RR . Left
127−
128−succeedWith :: a -> RouteResult a
129−succeedWith = RR . Right
130−
131−isMismatch :: RouteResult a -> Bool
132−isMismatch (RR (Left _)) = True
133−isMismatch _ = False
134−
135−-- | Like `null . pathInfo`, but works with redundant trailing slashes.
136−pathIsEmpty :: Request -> Bool
137−pathIsEmpty = f . processedPathInfo
138− where
139− f [] = True
140− f [""] = True
141− f _ = False
142−
143−-- | If we get a `Right`, it has precedence over everything else.
144−--
145−-- This in particular means that if we could get several 'Right's,
146−-- only the first we encounter would be taken into account.
147−instance Monoid (RouteResult a) where
148− mempty = RR $ Left mempty
149−
150− RR (Left x) `mappend` RR (Left y) = RR $ Left (x <> y)
151− RR (Left _) `mappend` RR (Right y) = RR $ Right y
152− r `mappend` _ = r
153−
154−type RoutingApplication =
155− Request -- ^ the request, the field 'pathInfo' may be modified by url routing
156− -> (RouteResult Response -> IO ResponseReceived) -> IO ResponseReceived
157−
158−splitMatrixParameters :: Text -> (Text, Text)
159−splitMatrixParameters = T.break (== ';')
160−
161−parsePathInfo :: Request -> [Text]
162−parsePathInfo = filter (/= "") . mergePairs . map splitMatrixParameters . pathInfo
163− where mergePairs = concat . unfoldr pairToList
164− pairToList [] = Nothing
165− pairToList ((a, b):xs) = Just ([a, b], xs)
166−
167−-- | Returns a processed pathInfo from the request.
168−--
169−-- In order to handle matrix parameters in the request correctly, the raw pathInfo needs to be
170−-- processed, so routing works as intended. Therefor this function should be used to access
171−-- the pathInfo for routing purposes.
172−processedPathInfo :: Request -> [Text]
173−processedPathInfo r =
174− case pinfo of
175− (x:xs) | T.head x == ';' -> xs
176− _ -> pinfo
177− where pinfo = parsePathInfo r
178−
17959class HasServer layout where
18060 type ServerT layout (m :: * -> *) :: *
18161
182− route :: Proxy layout -> Server layout -> RoutingApplication
62+ route :: Proxy layout -> IO (RouteResult (Server layout)) -> Router
18363
18464type Server layout = ServerT layout (EitherT ServantErr IO)
18565
@@ -200,12 +80,8 @@ instance (HasServer a, HasServer b) => HasServer (a :<|> b) where
20080
20181 type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m
20282
203− route Proxy (a :<|> b) request respond =
204− route pa a request $ \mResponse ->
205− if isMismatch mResponse
206− then route pb b request $ \mResponse' -> respond (mResponse <> mResponse')
207− else respond mResponse
208−
83+ route Proxy server = choice (route pa (extractL <$> server))
84+ (route pb (extractR <$> server))
20985 where pa = Proxy :: Proxy a
21086 pb = Proxy :: Proxy b
21187
@@ -227,7 +103,7 @@ captured _ = fromText
227103-- >
228104-- > server :: Server MyApi
229105-- > server = getBook
230−-- > where getBook :: Text -> EitherT (Int, String) IO Book
106+-- > where getBook :: Text -> EitherT ServantErr IO Book
231107-- > getBook isbn = ...
232108instance (KnownSymbol capture, FromText a, HasServer sublayout)
233109 => HasServer (Capture capture a :> sublayout) where
@@ -235,25 +111,72 @@ instance (KnownSymbol capture, FromText a, HasServer sublayout)
235111 type ServerT (Capture capture a :> sublayout) m =
236112 a -> ServerT sublayout m
237113
238− route Proxy subserver request respond = case processedPathInfo request of
239− (first : rest)
240− -> case captured captureProxy first of
241− Nothing -> respond $ failWith NotFound
242− Just v -> route (Proxy :: Proxy sublayout) (subserver v) request{
243− pathInfo = rest
244− } respond
245− _ -> respond $ failWith NotFound
246−
114+ route Proxy subserver =
115+ DynamicRouter $ \ first ->
116+ route (Proxy :: Proxy sublayout)
117+ (case captured captureProxy first of
118+ Nothing -> return $ failWith NotFound
119+ Just v -> feedTo subserver v)
247120 where captureProxy = Proxy :: Proxy (Capture capture a)
248121
249122
123+methodRouter :: (AllCTRender ctypes a)
124+ => Method -> Proxy ctypes -> Status
125+ -> IO (RouteResult (EitherT ServantErr IO a))
126+ -> Router
127+methodRouter method proxy status action = LeafRouter route'
128+ where
129+ route' request respond
130+ | pathIsEmpty request && requestMethod request == method = do
131+ runAction action respond $ \ output -> do
132+ let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
133+ case handleAcceptH proxy (AcceptHeader accH) output of
134+ Nothing -> failWith UnsupportedMediaType
135+ Just (contentT, body) -> succeedWith $
136+ responseLBS status [ ("Content-Type" , cs contentT)] body
137+ | pathIsEmpty request && requestMethod request /= method =
138+ respond $ failWith WrongMethod
139+ | otherwise = respond $ failWith NotFound
140+
141+methodRouterHeaders :: (GetHeaders (Headers h v), AllCTRender ctypes v)
142+ => Method -> Proxy ctypes -> Status
143+ -> IO (RouteResult (EitherT ServantErr IO (Headers h v)))
144+ -> Router
145+methodRouterHeaders method proxy status action = LeafRouter route'
146+ where
147+ route' request respond
148+ | pathIsEmpty request && requestMethod request == method = do
149+ runAction action respond $ \ output -> do
150+ let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
151+ headers = getHeaders output
152+ case handleAcceptH proxy (AcceptHeader accH) (getResponse output) of
153+ Nothing -> failWith UnsupportedMediaType
154+ Just (contentT, body) -> succeedWith $
155+ responseLBS status ( ("Content-Type" , cs contentT) : headers) body
156+ | pathIsEmpty request && requestMethod request /= method =
157+ respond $ failWith WrongMethod
158+ | otherwise = respond $ failWith NotFound
159+
160+methodRouterEmpty :: Method
161+ -> IO (RouteResult (EitherT ServantErr IO ()))
162+ -> Router
163+methodRouterEmpty method action = LeafRouter route'
164+ where
165+ route' request respond
166+ | pathIsEmpty request && requestMethod request == method = do
167+ runAction action respond $ \ () ->
168+ succeedWith $ responseLBS noContent204 [] ""
169+ | pathIsEmpty request && requestMethod request /= method =
170+ respond $ failWith WrongMethod
171+ | otherwise = respond $ failWith NotFound
172+
250173-- | If you have a 'Delete' endpoint in your API,
251174-- the handler for this endpoint is meant to delete
252175-- a resource.
253176--
254177-- The code of the handler will, just like
255178-- for 'Servant.API.Get.Get', 'Servant.API.Post.Post' and
256−-- 'Servant.API.Put.Put', run in @EitherT (Int, String) IO ()@.
179+-- 'Servant.API.Put.Put', run in @EitherT ServantErr IO ()@.
257180-- The 'Int' represents the status code and the 'String' a message
258181-- to be returned. You can use 'Control.Monad.Trans.Either.left' to
259182-- painlessly error out if the conditions for a successful deletion
@@ -267,20 +190,7 @@ instance
267190
268191 type ServerT (Delete ctypes a) m = m a
269192
270− route Proxy action request respond
271− | pathIsEmpty request && requestMethod request == methodDelete = do
272− e <- runEitherT action
273− respond $ case e of
274− Right output -> do
275− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
276− case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
277− Nothing -> failWith UnsupportedMediaType
278− Just (contentT, body) -> succeedWith $
279− responseLBS status200 [ ("Content-Type" , cs contentT)] body
280− Left err -> succeedWith $ responseServantErr err
281− | pathIsEmpty request && requestMethod request /= methodDelete =
282− respond $ failWith WrongMethod
283− | otherwise = respond $ failWith NotFound
193+ route Proxy = methodRouter methodDelete (Proxy :: Proxy ctypes) ok200
284194
285195instance
286196#if MIN_VERSION_base(4,8,0)
@@ -290,15 +200,7 @@ instance
290200
291201 type ServerT (Delete ctypes ()) m = m ()
292202
293− route Proxy action request respond
294− | pathIsEmpty request && requestMethod request == methodDelete = do
295− e <- runEitherT action
296− respond . succeedWith $ case e of
297− Right () -> responseLBS noContent204 [] ""
298− Left err -> responseServantErr err
299− | pathIsEmpty request && requestMethod request /= methodDelete =
300− respond $ failWith WrongMethod
301− | otherwise = respond $ failWith NotFound
203+ route Proxy = methodRouterEmpty methodDelete
302204
303205-- Add response headers
304206instance
@@ -310,26 +212,12 @@ instance
310212
311213 type ServerT (Delete ctypes (Headers h v)) m = m (Headers h v)
312214
313− route Proxy action request respond
314− | pathIsEmpty request && requestMethod request == methodDelete = do
315− e <- runEitherT action
316− respond $ case e of
317− Right output -> do
318− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
319− headers = getHeaders output
320− case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of
321− Nothing -> failWith UnsupportedMediaType
322− Just (contentT, body) -> succeedWith $
323− responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body
324− Left err -> succeedWith $ responseServantErr err
325− | pathIsEmpty request && requestMethod request /= methodDelete =
326− respond $ failWith WrongMethod
327− | otherwise = respond $ failWith NotFound
215+ route Proxy = methodRouterHeaders methodDelete (Proxy :: Proxy ctypes) ok200
328216
329217-- | When implementing the handler for a 'Get' endpoint,
330218-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Post.Post'
331219-- and 'Servant.API.Put.Put', the handler code runs in the
332−-- @EitherT (Int, String) IO@ monad, where the 'Int' represents
220+-- @EitherT ServantErr IO@ monad, where the 'Int' represents
333221-- the status code and the 'String' a message, returned in case of
334222-- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'
335223-- to quickly fail if some conditions are not met.
@@ -347,20 +235,7 @@ instance
347235
348236 type ServerT (Get ctypes a) m = m a
349237
350− route Proxy action request respond
351− | pathIsEmpty request && requestMethod request == methodGet = do
352− e <- runEitherT action
353− respond $ case e of
354− Right output -> do
355− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
356− case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
357− Nothing -> failWith UnsupportedMediaType
358− Just (contentT, body) -> succeedWith $
359− responseLBS ok200 [ ("Content-Type" , cs contentT)] body
360− Left err -> succeedWith $ responseServantErr err
361− | pathIsEmpty request && requestMethod request /= methodGet =
362− respond $ failWith WrongMethod
363− | otherwise = respond $ failWith NotFound
238+ route Proxy = methodRouter methodGet (Proxy :: Proxy ctypes) ok200
364239
365240-- '()' ==> 204 No Content
366241instance
@@ -371,15 +246,7 @@ instance
371246
372247 type ServerT (Get ctypes ()) m = m ()
373248
374− route Proxy action request respond
375− | pathIsEmpty request && requestMethod request == methodGet = do
376− e <- runEitherT action
377− respond . succeedWith $ case e of
378− Right () -> responseLBS noContent204 [] ""
379− Left err -> responseServantErr err
380− | pathIsEmpty request && requestMethod request /= methodGet =
381− respond $ failWith WrongMethod
382− | otherwise = respond $ failWith NotFound
249+ route Proxy = methodRouterEmpty methodGet
383250
384251-- Add response headers
385252instance
@@ -391,21 +258,7 @@ instance
391258
392259 type ServerT (Get ctypes (Headers h v)) m = m (Headers h v)
393260
394− route Proxy action request respond
395− | pathIsEmpty request && requestMethod request == methodGet = do
396− e <- runEitherT action
397− respond $ case e of
398− Right output -> do
399− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
400− headers = getHeaders output
401− case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of
402− Nothing -> failWith UnsupportedMediaType
403− Just (contentT, body) -> succeedWith $
404− responseLBS ok200 ( ("Content-Type" , cs contentT) : headers) body
405− Left err -> succeedWith $ responseServantErr err
406− | pathIsEmpty request && requestMethod request /= methodGet =
407− respond $ failWith WrongMethod
408− | otherwise = respond $ failWith NotFound
261+ route Proxy = methodRouterHeaders methodGet (Proxy :: Proxy ctypes) ok200
409262
410263-- | If you use 'Header' in one of the endpoints for your API,
411264-- this automatically requires your server-side handler to be a function
@@ -425,7 +278,7 @@ instance
425278-- >
426279-- > server :: Server MyApi
427280-- > server = viewReferer
428−-- > where viewReferer :: Referer -> EitherT (Int, String) IO referer
281+-- > where viewReferer :: Referer -> EitherT ServantErr IO referer
429282-- > viewReferer referer = return referer
430283instance (KnownSymbol sym, FromText a, HasServer sublayout)
431284 => HasServer (Header sym a :> sublayout) where
@@ -433,16 +286,15 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
433286 type ServerT (Header sym a :> sublayout) m =
434287 Maybe a -> ServerT sublayout m
435288
436− route Proxy subserver request respond = do
289+ route Proxy subserver = WithRequest $ \ request ->
437290 let mheader = fromText . decodeUtf8 =<< lookup str (requestHeaders request)
438− route (Proxy :: Proxy sublayout) (subserver mheader) request respond
439−
440− where str = fromString $ symbolVal (Proxy :: Proxy sym)
291+ in route (Proxy :: Proxy sublayout) (feedTo subserver mheader)
292+ where str = fromString $ symbolVal (Proxy :: Proxy sym)
441293
442294-- | When implementing the handler for a 'Post' endpoint,
443295-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'
444296-- and 'Servant.API.Put.Put', the handler code runs in the
445−-- @EitherT (Int, String) IO@ monad, where the 'Int' represents
297+-- @EitherT ServantErr IO@ monad, where the 'Int' represents
446298-- the status code and the 'String' a message, returned in case of
447299-- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'
448300-- to quickly fail if some conditions are not met.
@@ -461,20 +313,7 @@ instance
461313
462314 type ServerT (Post ctypes a) m = m a
463315
464− route Proxy action request respond
465− | pathIsEmpty request && requestMethod request == methodPost = do
466− e <- runEitherT action
467− respond $ case e of
468− Right output -> do
469− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
470− case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
471− Nothing -> failWith UnsupportedMediaType
472− Just (contentT, body) -> succeedWith $
473− responseLBS status201 [ ("Content-Type" , cs contentT)] body
474− Left err -> succeedWith $ responseServantErr err
475− | pathIsEmpty request && requestMethod request /= methodPost =
476− respond $ failWith WrongMethod
477− | otherwise = respond $ failWith NotFound
316+ route Proxy = methodRouter methodPost (Proxy :: Proxy ctypes) created201
478317
479318instance
480319#if MIN_VERSION_base(4,8,0)
@@ -484,15 +323,7 @@ instance
484323
485324 type ServerT (Post ctypes ()) m = m ()
486325
487− route Proxy action request respond
488− | pathIsEmpty request && requestMethod request == methodPost = do
489− e <- runEitherT action
490− respond . succeedWith $ case e of
491− Right () -> responseLBS noContent204 [] ""
492− Left err -> responseServantErr err
493− | pathIsEmpty request && requestMethod request /= methodPost =
494− respond $ failWith WrongMethod
495− | otherwise = respond $ failWith NotFound
326+ route Proxy = methodRouterEmpty methodPost
496327
497328-- Add response headers
498329instance
@@ -504,26 +335,12 @@ instance
504335
505336 type ServerT (Post ctypes (Headers h v)) m = m (Headers h v)
506337
507− route Proxy action request respond
508− | pathIsEmpty request && requestMethod request == methodPost = do
509− e <- runEitherT action
510− respond $ case e of
511− Right output -> do
512− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
513− headers = getHeaders output
514− case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of
515− Nothing -> failWith UnsupportedMediaType
516− Just (contentT, body) -> succeedWith $
517− responseLBS status201 ( ("Content-Type" , cs contentT) : headers) body
518− Left err -> succeedWith $ responseServantErr err
519− | pathIsEmpty request && requestMethod request /= methodPost =
520− respond $ failWith WrongMethod
521− | otherwise = respond $ failWith NotFound
338+ route Proxy = methodRouterHeaders methodPost (Proxy :: Proxy ctypes) created201
522339
523340-- | When implementing the handler for a 'Put' endpoint,
524341-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'
525342-- and 'Servant.API.Post.Post', the handler code runs in the
526−-- @EitherT (Int, String) IO@ monad, where the 'Int' represents
343+-- @EitherT ServantErr IO@ monad, where the 'Int' represents
527344-- the status code and the 'String' a message, returned in case of
528345-- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'
529346-- to quickly fail if some conditions are not met.
@@ -541,20 +358,7 @@ instance
541358
542359 type ServerT (Put ctypes a) m = m a
543360
544− route Proxy action request respond
545− | pathIsEmpty request && requestMethod request == methodPut = do
546− e <- runEitherT action
547− respond $ case e of
548− Right output -> do
549− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
550− case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
551− Nothing -> failWith UnsupportedMediaType
552− Just (contentT, body) -> succeedWith $
553− responseLBS status200 [ ("Content-Type" , cs contentT)] body
554− Left err -> succeedWith $ responseServantErr err
555− | pathIsEmpty request && requestMethod request /= methodPut =
556− respond $ failWith WrongMethod
557− | otherwise = respond $ failWith NotFound
361+ route Proxy = methodRouter methodPut (Proxy :: Proxy ctypes) ok200
558362
559363instance
560364#if MIN_VERSION_base(4,8,0)
@@ -564,15 +368,7 @@ instance
564368
565369 type ServerT (Put ctypes ()) m = m ()
566370
567− route Proxy action request respond
568− | pathIsEmpty request && requestMethod request == methodPut = do
569− e <- runEitherT action
570− respond . succeedWith $ case e of
571− Right () -> responseLBS noContent204 [] ""
572− Left err -> responseServantErr err
573− | pathIsEmpty request && requestMethod request /= methodPut =
574− respond $ failWith WrongMethod
575− | otherwise = respond $ failWith NotFound
371+ route Proxy = methodRouterEmpty methodPut
576372
577373-- Add response headers
578374instance
@@ -584,26 +380,12 @@ instance
584380
585381 type ServerT (Put ctypes (Headers h v)) m = m (Headers h v)
586382
587− route Proxy action request respond
588− | pathIsEmpty request && requestMethod request == methodPut = do
589− e <- runEitherT action
590− respond $ case e of
591− Right output -> do
592− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
593− headers = getHeaders output
594− case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of
595− Nothing -> failWith UnsupportedMediaType
596− Just (contentT, body) -> succeedWith $
597− responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body
598− Left err -> succeedWith $ responseServantErr err
599− | pathIsEmpty request && requestMethod request /= methodPut =
600− respond $ failWith WrongMethod
601− | otherwise = respond $ failWith NotFound
383+ route Proxy = methodRouterHeaders methodPut (Proxy :: Proxy ctypes) ok200
602384
603385-- | When implementing the handler for a 'Patch' endpoint,
604386-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'
605387-- and 'Servant.API.Put.Put', the handler code runs in the
606−-- @EitherT (Int, String) IO@ monad, where the 'Int' represents
388+-- @EitherT ServantErr IO@ monad, where the 'Int' represents
607389-- the status code and the 'String' a message, returned in case of
608390-- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'
609391-- to quickly fail if some conditions are not met.
@@ -619,20 +401,7 @@ instance
619401
620402 type ServerT (Patch ctypes a) m = m a
621403
622− route Proxy action request respond
623− | pathIsEmpty request && requestMethod request == methodPatch = do
624− e <- runEitherT action
625− respond $ case e of
626− Right output -> do
627− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
628− case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
629− Nothing -> failWith UnsupportedMediaType
630− Just (contentT, body) -> succeedWith $
631− responseLBS status200 [ ("Content-Type" , cs contentT)] body
632− Left err -> succeedWith $ responseServantErr err
633− | pathIsEmpty request && requestMethod request /= methodPatch =
634− respond $ failWith WrongMethod
635− | otherwise = respond $ failWith NotFound
404+ route Proxy = methodRouter methodPatch (Proxy :: Proxy ctypes) ok200
636405
637406instance
638407#if MIN_VERSION_base(4,8,0)
@@ -642,15 +411,7 @@ instance
642411
643412 type ServerT (Patch ctypes ()) m = m ()
644413
645− route Proxy action request respond
646− | pathIsEmpty request && requestMethod request == methodPatch = do
647− e <- runEitherT action
648− respond . succeedWith $ case e of
649− Right () -> responseLBS noContent204 [] ""
650− Left err -> responseServantErr err
651− | pathIsEmpty request && requestMethod request /= methodPatch =
652− respond $ failWith WrongMethod
653− | otherwise = respond $ failWith NotFound
414+ route Proxy = methodRouterEmpty methodPatch
654415
655416-- Add response headers
656417instance
@@ -662,21 +423,7 @@ instance
662423
663424 type ServerT (Patch ctypes (Headers h v)) m = m (Headers h v)
664425
665− route Proxy action request respond
666− | pathIsEmpty request && requestMethod request == methodPatch = do
667− e <- runEitherT action
668− respond $ case e of
669− Right outpatch -> do
670− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
671− headers = getHeaders outpatch
672− case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse outpatch) of
673− Nothing -> failWith UnsupportedMediaType
674− Just (contentT, body) -> succeedWith $
675− responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body
676− Left err -> succeedWith $ responseServantErr err
677− | pathIsEmpty request && requestMethod request /= methodPatch =
678− respond $ failWith WrongMethod
679− | otherwise = respond $ failWith NotFound
426+ route Proxy = methodRouterHeaders methodPatch (Proxy :: Proxy ctypes) ok200
680427
681428-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,
682429-- this automatically requires your server-side handler to be a function
@@ -696,7 +443,7 @@ instance
696443-- >
697444-- > server :: Server MyApi
698445-- > server = getBooksBy
699−-- > where getBooksBy :: Maybe Text -> EitherT (Int, String) IO [Book]
446+-- > where getBooksBy :: Maybe Text -> EitherT ServantErr IO [Book]
700447-- > getBooksBy Nothing = ...return all books...
701448-- > getBooksBy (Just author) = ...return books by the given author...
702449instance (KnownSymbol sym, FromText a, HasServer sublayout)
@@ -705,7 +452,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
705452 type ServerT (QueryParam sym a :> sublayout) m =
706453 Maybe a -> ServerT sublayout m
707454
708− route Proxy subserver request respond = do
455+ route Proxy subserver = WithRequest $ \ request ->
709456 let querytext = parseQueryText $ rawQueryString request
710457 param =
711458 case lookup paramname querytext of
@@ -713,9 +460,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
713460 Just Nothing -> Nothing -- param present with no value -> Nothing
714461 Just (Just v) -> fromText v -- if present, we try to convert to
715462 -- the right type
716−
717− route (Proxy :: Proxy sublayout) (subserver param) request respond
718−
463+ in route (Proxy :: Proxy sublayout) (feedTo subserver param)
719464 where paramname = cs $ symbolVal (Proxy :: Proxy sym)
720465
721466-- | If you use @'QueryParams' "authors" Text@ in one of the endpoints for your API,
@@ -735,7 +480,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
735480-- >
736481-- > server :: Server MyApi
737482-- > server = getBooksBy
738−-- > where getBooksBy :: [Text] -> EitherT (Int, String) IO [Book]
483+-- > where getBooksBy :: [Text] -> EitherT ServantErr IO [Book]
739484-- > getBooksBy authors = ...return all books by these authors...
740485instance (KnownSymbol sym, FromText a, HasServer sublayout)
741486 => HasServer (QueryParams sym a :> sublayout) where
@@ -743,16 +488,14 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
743488 type ServerT (QueryParams sym a :> sublayout) m =
744489 [a] -> ServerT sublayout m
745490
746− route Proxy subserver request respond = do
491+ route Proxy subserver = WithRequest $ \ request ->
747492 let querytext = parseQueryText $ rawQueryString request
748493 -- if sym is "foo", we look for query string parameters
749494 -- named "foo" or "foo[]" and call fromText on the
750495 -- corresponding values
751496 parameters = filter looksLikeParam querytext
752497 values = catMaybes $ map (convert . snd) parameters
753−
754− route (Proxy :: Proxy sublayout) (subserver values) request respond
755−
498+ in route (Proxy :: Proxy sublayout) (feedTo subserver values)
756499 where paramname = cs $ symbolVal (Proxy :: Proxy sym)
757500 looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")
758501 convert Nothing = Nothing
@@ -768,7 +511,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
768511-- >
769512-- > server :: Server MyApi
770513-- > server = getBooks
771−-- > where getBooks :: Bool -> EitherT (Int, String) IO [Book]
514+-- > where getBooks :: Bool -> EitherT ServantErr IO [Book]
772515-- > getBooks onlyPublished = ...return all books, or only the ones that are already published, depending on the argument...
773516instance (KnownSymbol sym, HasServer sublayout)
774517 => HasServer (QueryFlag sym :> sublayout) where
@@ -776,15 +519,13 @@ instance (KnownSymbol sym, HasServer sublayout)
776519 type ServerT (QueryFlag sym :> sublayout) m =
777520 Bool -> ServerT sublayout m
778521
779− route Proxy subserver request respond = do
522+ route Proxy subserver = WithRequest $ \ request ->
780523 let querytext = parseQueryText $ rawQueryString request
781524 param = case lookup paramname querytext of
782525 Just Nothing -> True -- param is there, with no value
783526 Just (Just v) -> examine v -- param with a value
784527 Nothing -> False -- param not in the query string
785−
786− route (Proxy :: Proxy sublayout) (subserver param) request respond
787−
528+ in route (Proxy :: Proxy sublayout) (feedTo subserver param)
788529 where paramname = cs $ symbolVal (Proxy :: Proxy sym)
789530 examine v | v == "true" || v == "1" || v == "" = True
790531 | otherwise = False
@@ -810,7 +551,7 @@ parseMatrixText = parseQueryText
810551-- >
811552-- > server :: Server MyApi
812553-- > server = getBooksBy
813−-- > where getBooksBy :: Maybe Text -> EitherT (Int, String) IO [Book]
554+-- > where getBooksBy :: Maybe Text -> EitherT ServantErr IO [Book]
814555-- > getBooksBy Nothing = ...return all books...
815556-- > getBooksBy (Just author) = ...return books by the given author...
816557instance (KnownSymbol sym, FromText a, HasServer sublayout)
@@ -819,16 +560,17 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
819560 type ServerT (MatrixParam sym a :> sublayout) m =
820561 Maybe a -> ServerT sublayout m
821562
822− route Proxy subserver request respond = case parsePathInfo request of
823− (first : _)
824− -> do let querytext = parseMatrixText . encodeUtf8 $ T.tail first
825− param = case lookup paramname querytext of
826− Nothing -> Nothing -- param absent from the query string
827− Just Nothing -> Nothing -- param present with no value -> Nothing
828− Just (Just v) -> fromText v -- if present, we try to convert to
829− -- the right type
830− route (Proxy :: Proxy sublayout) (subserver param) request respond
831− _ -> route (Proxy :: Proxy sublayout) (subserver Nothing) request respond
563+ route Proxy subserver = WithRequest $ \ request ->
564+ case parsePathInfo request of
565+ (first : _)
566+ -> do let querytext = parseMatrixText . encodeUtf8 $ T.tail first
567+ param = case lookup paramname querytext of
568+ Nothing -> Nothing -- param absent from the query string
569+ Just Nothing -> Nothing -- param present with no value -> Nothing
570+ Just (Just v) -> fromText v -- if present, we try to convert to
571+ -- the right type
572+ route (Proxy :: Proxy sublayout) (feedTo subserver param)
573+ _ -> route (Proxy :: Proxy sublayout) (feedTo subserver Nothing)
832574
833575 where paramname = cs $ symbolVal (Proxy :: Proxy sym)
834576
@@ -849,7 +591,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
849591-- >
850592-- > server :: Server MyApi
851593-- > server = getBooksBy
852−-- > where getBooksBy :: [Text] -> EitherT (Int, String) IO [Book]
594+-- > where getBooksBy :: [Text] -> EitherT ServantErr IO [Book]
853595-- > getBooksBy authors = ...return all books by these authors...
854596instance (KnownSymbol sym, FromText a, HasServer sublayout)
855597 => HasServer (MatrixParams sym a :> sublayout) where
@@ -857,16 +599,17 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
857599 type ServerT (MatrixParams sym a :> sublayout) m =
858600 [a] -> ServerT sublayout m
859601
860− route Proxy subserver request respond = case parsePathInfo request of
861− (first : _)
862− -> do let matrixtext = parseMatrixText . encodeUtf8 $ T.tail first
863− -- if sym is "foo", we look for matrix parameters
864− -- named "foo" or "foo[]" and call fromText on the
865− -- corresponding values
866− parameters = filter looksLikeParam matrixtext
867− values = catMaybes $ map (convert . snd) parameters
868− route (Proxy :: Proxy sublayout) (subserver values) request respond
869− _ -> route (Proxy :: Proxy sublayout) (subserver []) request respond
602+ route Proxy subserver = WithRequest $ \ request ->
603+ case parsePathInfo request of
604+ (first : _)
605+ -> do let matrixtext = parseMatrixText . encodeUtf8 $ T.tail first
606+ -- if sym is "foo", we look for matrix parameters
607+ -- named "foo" or "foo[]" and call fromText on the
608+ -- corresponding values
609+ parameters = filter looksLikeParam matrixtext
610+ values = catMaybes $ map (convert . snd) parameters
611+ route (Proxy :: Proxy sublayout) (feedTo subserver values)
612+ _ -> route (Proxy :: Proxy sublayout) (feedTo subserver [])
870613
871614 where paramname = cs $ symbolVal (Proxy :: Proxy sym)
872615 looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")
@@ -883,7 +626,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
883626-- >
884627-- > server :: Server MyApi
885628-- > server = getBooks
886−-- > where getBooks :: Bool -> EitherT (Int, String) IO [Book]
629+-- > where getBooks :: Bool -> EitherT ServantErr IO [Book]
887630-- > getBooks onlyPublished = ...return all books, or only the ones that are already published, depending on the argument...
888631instance (KnownSymbol sym, HasServer sublayout)
889632 => HasServer (MatrixFlag sym :> sublayout) where
@@ -891,17 +634,18 @@ instance (KnownSymbol sym, HasServer sublayout)
891634 type ServerT (MatrixFlag sym :> sublayout) m =
892635 Bool -> ServerT sublayout m
893636
894− route Proxy subserver request respond = case parsePathInfo request of
895− (first : _)
896− -> do let matrixtext = parseMatrixText . encodeUtf8 $ T.tail first
897− param = case lookup paramname matrixtext of
898− Just Nothing -> True -- param is there, with no value
899− Just (Just v) -> examine v -- param with a value
900− Nothing -> False -- param not in the query string
901−
902− route (Proxy :: Proxy sublayout) (subserver param) request respond
903−
904− _ -> route (Proxy :: Proxy sublayout) (subserver False) request respond
637+ route Proxy subserver = WithRequest $ \ request ->
638+ case parsePathInfo request of
639+ (first : _)
640+ -> do let matrixtext = parseMatrixText . encodeUtf8 $ T.tail first
641+ param = case lookup paramname matrixtext of
642+ Just Nothing -> True -- param is there, with no value
643+ Just (Just v) -> examine v -- param with a value
644+ Nothing -> False -- param not in the query string
645+
646+ route (Proxy :: Proxy sublayout) (feedTo subserver param)
647+
648+ _ -> route (Proxy :: Proxy sublayout) (feedTo subserver False)
905649
906650 where paramname = cs $ symbolVal (Proxy :: Proxy sym)
907651 examine v | v == "true" || v == "1" || v == "" = True
@@ -919,8 +663,11 @@ instance HasServer Raw where
919663
920664 type ServerT Raw m = Application
921665
922− route Proxy rawApplication request respond =
923− rawApplication request (respond . succeedWith)
666+ route Proxy rawApplication = LeafRouter $ \ request respond -> do
667+ r <- rawApplication
668+ case r of
669+ RR (Left err) -> respond $ failWith err
670+ RR (Right app) -> app request (respond . succeedWith)
924671
925672-- | If you use 'ReqBody' in one of the endpoints for your API,
926673-- this automatically requires your server-side handler to be a function
@@ -940,7 +687,7 @@ instance HasServer Raw where
940687-- >
941688-- > server :: Server MyApi
942689-- > server = postBook
943−-- > where postBook :: Book -> EitherT (Int, String) IO Book
690+-- > where postBook :: Book -> EitherT ServantErr IO Book
944691-- > postBook book = ...insert into your db...
945692instance ( AllCTUnrender list a, HasServer sublayout
946693 ) => HasServer (ReqBody list a :> sublayout) where
@@ -948,19 +695,20 @@ instance ( AllCTUnrender list a, HasServer sublayout
948695 type ServerT (ReqBody list a :> sublayout) m =
949696 a -> ServerT sublayout m
950697
951− route Proxy subserver request respond = do
952− -- See HTTP RFC 2616, section 7.2.1
953− -- http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1
954− -- See also "W3C Internet Media Type registration, consistency of use"
955− -- http://www.w3.org/2001/tag/2002/0129-mime
956− let contentTypeH = fromMaybe "application/octet-stream"
957− $ lookup hContentType $ requestHeaders request
958− mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH)
959− <$> lazyRequestBody request
960− case mrqbody of
961− Nothing -> respond . failWith $ UnsupportedMediaType
962− Just (Left e) -> respond . failWith $ InvalidBody e
963− Just (Right v) -> route (Proxy :: Proxy sublayout) (subserver v) request respond
698+ route Proxy subserver = WithRequest $ \ request ->
699+ route (Proxy :: Proxy sublayout) $ do
700+ -- See HTTP RFC 2616, section 7.2.1
701+ -- http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1
702+ -- See also "W3C Internet Media Type registration, consistency of use"
703+ -- http://www.w3.org/2001/tag/2002/0129-mime
704+ let contentTypeH = fromMaybe "application/octet-stream"
705+ $ lookup hContentType $ requestHeaders request
706+ mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH)
707+ <$> lazyRequestBody request
708+ case mrqbody of
709+ Nothing -> return $ failWith $ UnsupportedMediaType
710+ Just (Left e) -> return $ failWith $ InvalidBody e
711+ Just (Right v) -> feedTo subserver v
964712
965713-- | Make sure the incoming request starts with @"/path"@, strip it and
966714-- pass the rest of the request path to @sublayout@.
@@ -968,14 +716,9 @@ instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout
968716
969717 type ServerT (path :> sublayout) m = ServerT sublayout m
970718
971− route Proxy subserver request respond = case processedPathInfo request of
972− (first : rest)
973− | first == cs (symbolVal proxyPath)
974− -> route (Proxy :: Proxy sublayout) subserver request{
975− pathInfo = rest
976− } respond
977− _ -> respond $ failWith NotFound
978−
719+ route Proxy subserver = StaticRouter $
720+ M.singleton (cs (symbolVal proxyPath))
721+ (route (Proxy :: Proxy sublayout) subserver)
979722 where proxyPath = Proxy :: Proxy path
980723
981724ct_wildcard :: B.ByteString