git.iko.soy/typeable/servant
on master help sign in
Merge pull request #111 from haskell-servant/improved-routing
d654ccaAlp Mestanogullari
servant-examples/auth-combinator/auth-combinator.hs+9−8
compare with master
unifiedsplit
@@ -28,14 +28,15 @@ data AuthProtected
28instance HasServer rest => HasServer (AuthProtected :> rest) where
28instance HasServer rest => HasServer (AuthProtected :> rest) where
29 type ServerT (AuthProtected :> rest) m = ServerT rest m
29 type ServerT (AuthProtected :> rest) m = ServerT rest m
30
30
31− route Proxy a request respond =
31+ route Proxy a = WithRequest $ \ request ->
32+ route (Proxy :: Proxy rest) $ do
32− case lookup "Cookie" (requestHeaders request) of
33+ case lookup "Cookie" (requestHeaders request) of
33− Nothing -> respond . succeedWith $ responseLBS status401 [] "Missing auth header."
34+ Nothing -> return $ failWith $ HttpError status401 (Just "Missing auth header.")
34− Just v -> do
35+ Just v -> do
35− authGranted <- isGoodCookie v
36+ authGranted <- isGoodCookie v
36− if authGranted
37+ if authGranted
37− then route (Proxy :: Proxy rest) a request respond
38+ then a
38− else respond . succeedWith $ responseLBS status403 [] "Invalid cookie."
39+ else return $ failWith $ HttpError status403 (Just "Invalid cookie.")
39
40
40type PrivateAPI = Get '[JSON] [PrivateData]
41type PrivateAPI = Get '[JSON] [PrivateData]
41
42
servant-server/servant-server.cabal+5−1
@@ -35,14 +35,18 @@ library
35 Servant
35 Servant
36 Servant.Server
36 Servant.Server
37 Servant.Server.Internal
37 Servant.Server.Internal
38− Servant.Server.Internal.ServantErr
39 Servant.Server.Internal.Enter
38 Servant.Server.Internal.Enter
39+ Servant.Server.Internal.PathInfo
40+ Servant.Server.Internal.Router
41+ Servant.Server.Internal.RoutingApplication
42+ Servant.Server.Internal.ServantErr
40 Servant.Utils.StaticFiles
43 Servant.Utils.StaticFiles
41 build-depends:
44 build-depends:
42 base >= 4.7 && < 5
45 base >= 4.7 && < 5
43 , aeson >= 0.7 && < 0.10
46 , aeson >= 0.7 && < 0.10
44 , attoparsec >= 0.12 && < 0.14
47 , attoparsec >= 0.12 && < 0.14
45 , bytestring >= 0.10 && < 0.11
48 , bytestring >= 0.10 && < 0.11
49+ , containers >= 0.5 && < 0.6
46 , either >= 4.3 && < 4.5
50 , either >= 4.3 && < 4.5
47 , http-types >= 0.8 && < 0.9
51 , http-types >= 0.8 && < 0.9
48 , network-uri >= 2.6 && < 2.7
52 , network-uri >= 2.6 && < 2.7
servant-server/src/Servant/Server.hs+1−2
@@ -81,7 +81,6 @@ import Data.Proxy (Proxy)
81import Network.Wai (Application)
81import Network.Wai (Application)
82import Servant.Server.Internal
82import Servant.Server.Internal
83import Servant.Server.Internal.Enter
83import Servant.Server.Internal.Enter
84−import Servant.Server.Internal.ServantErr
85
84
86
85
87-- * Implementing Servers
86-- * Implementing Servers
@@ -108,7 +107,7 @@ import Servant.Server.Internal.ServantErr
108-- > main = Network.Wai.Handler.Warp.run 8080 app
107-- > main = Network.Wai.Handler.Warp.run 8080 app
109--
108--
110serve :: HasServer layout => Proxy layout -> Server layout -> Application
109serve :: HasServer layout => Proxy layout -> Server layout -> Application
111−serve p server = toApplication (route p server)
110+serve p server = toApplication (runRouter (route p (return (RR (Right server)))))
112
111
113
112
114-- Documentation
113-- Documentation
servant-server/src/Servant/Server/Internal.hs+155−412
@@ -2,6 +2,7 @@
2{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5{-# LANGUAGE OverloadedStrings #-}
6{-# LANGUAGE OverloadedStrings #-}
6{-# LANGUAGE PolyKinds #-}
7{-# LANGUAGE PolyKinds #-}
7{-# LANGUAGE ScopedTypeVariables #-}
8{-# LANGUAGE ScopedTypeVariables #-}
@@ -11,17 +12,20 @@
11{-# LANGUAGE OverlappingInstances #-}
12{-# LANGUAGE OverlappingInstances #-}
12#endif
13#endif
13
14
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
15
22
16#if !MIN_VERSION_base(4,8,0)
23#if !MIN_VERSION_base(4,8,0)
17import Control.Applicative ((<$>))
24import Control.Applicative ((<$>))
18−import Data.Monoid (Monoid, mappend, mempty)
19#endif
25#endif
20−import Control.Monad.Trans.Either (EitherT, runEitherT)
26+import Control.Monad.Trans.Either (EitherT)
21import qualified Data.ByteString as B
27import qualified Data.ByteString as B
22−import qualified Data.ByteString.Lazy as BL
28+import qualified Data.Map as M
23−import Data.IORef (newIORef, readIORef, writeIORef)
24−import Data.List (unfoldr)
25import Data.Maybe (catMaybes, fromMaybe)
29import Data.Maybe (catMaybes, fromMaybe)
26import Data.String (fromString)
30import Data.String (fromString)
27import Data.String.Conversions (cs, (<>))
31import Data.String.Conversions (cs, (<>))
@@ -31,12 +35,9 @@ import Data.Text.Encoding (decodeUtf8, encodeUtf8)
31import Data.Typeable
35import Data.Typeable
32import GHC.TypeLits (KnownSymbol, symbolVal)
36import GHC.TypeLits (KnownSymbol, symbolVal)
33import Network.HTTP.Types hiding (Header, ResponseHeaders)
37import Network.HTTP.Types hiding (Header, ResponseHeaders)
34−import Network.Wai (Application, Request, Response,
38+import Network.Wai (Application, lazyRequestBody,
35− ResponseReceived, lazyRequestBody,
36− pathInfo, rawQueryString,
39+ rawQueryString, requestHeaders,
37− requestBody, requestHeaders,
38− requestMethod, responseLBS,
40+ requestMethod, responseLBS)
39− strictRequestBody)
40import Servant.API ((:<|>) (..), (:>), Capture,
41import Servant.API ((:<|>) (..), (:>), Capture,
41 Delete, Get, Header,
42 Delete, Get, Header,
42 MatrixFlag, MatrixParam, MatrixParams,
43 MatrixFlag, MatrixParam, MatrixParams,
@@ -50,136 +51,15 @@ import Servant.API.ResponseHeaders (Headers, getResponse, GetHeaders,
50 getHeaders)
51 getHeaders)
51import Servant.Common.Text (FromText, fromText)
52import Servant.Common.Text (FromText, fromText)
52
53
54+import Servant.Server.Internal.PathInfo
55+import Servant.Server.Internal.Router
56+import Servant.Server.Internal.RoutingApplication
53import Servant.Server.Internal.ServantErr
57import Servant.Server.Internal.ServantErr
54
58
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−
179class HasServer layout where
59class HasServer layout where
180 type ServerT layout (m :: * -> *) :: *
60 type ServerT layout (m :: * -> *) :: *
181
61
182− route :: Proxy layout -> Server layout -> RoutingApplication
62+ route :: Proxy layout -> IO (RouteResult (Server layout)) -> Router
183
63
184type Server layout = ServerT layout (EitherT ServantErr IO)
64type Server layout = ServerT layout (EitherT ServantErr IO)
185
65
@@ -200,12 +80,8 @@ instance (HasServer a, HasServer b) => HasServer (a :<|> b) where
200
80
201 type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m
81 type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m
202
82
203− route Proxy (a :<|> b) request respond =
83+ route Proxy server = choice (route pa (extractL <$> server))
204− route pa a request $ \mResponse ->
84+ (route pb (extractR <$> server))
205− if isMismatch mResponse
206− then route pb b request $ \mResponse' -> respond (mResponse <> mResponse')
207− else respond mResponse
208−
209 where pa = Proxy :: Proxy a
85 where pa = Proxy :: Proxy a
210 pb = Proxy :: Proxy b
86 pb = Proxy :: Proxy b
211
87
@@ -235,18 +111,65 @@ instance (KnownSymbol capture, FromText a, HasServer sublayout)
235 type ServerT (Capture capture a :> sublayout) m =
111 type ServerT (Capture capture a :> sublayout) m =
236 a -> ServerT sublayout m
112 a -> ServerT sublayout m
237
113
238− route Proxy subserver request respond = case processedPathInfo request of
114+ route Proxy subserver =
239− (first : rest)
115+ DynamicRouter $ \ first ->
116+ route (Proxy :: Proxy sublayout)
240− -> case captured captureProxy first of
117+ (case captured captureProxy first of
241− Nothing -> respond $ failWith NotFound
118+ Nothing -> return $ failWith NotFound
242− Just v -> route (Proxy :: Proxy sublayout) (subserver v) request{
119+ Just v -> feedTo subserver v)
243− pathInfo = rest
244− } respond
245− _ -> respond $ failWith NotFound
246−
247 where captureProxy = Proxy :: Proxy (Capture capture a)
120 where captureProxy = Proxy :: Proxy (Capture capture a)
248
121
249
122
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+
250-- | If you have a 'Delete' endpoint in your API,
173-- | If you have a 'Delete' endpoint in your API,
251-- the handler for this endpoint is meant to delete
174-- the handler for this endpoint is meant to delete
252-- a resource.
175-- a resource.
@@ -267,20 +190,7 @@ instance
267
190
268 type ServerT (Delete ctypes a) m = m a
191 type ServerT (Delete ctypes a) m = m a
269
192
270− route Proxy action request respond
193+ route Proxy = methodRouter methodDelete (Proxy :: Proxy ctypes) ok200
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
284
194
285instance
195instance
286#if MIN_VERSION_base(4,8,0)
196#if MIN_VERSION_base(4,8,0)
@@ -290,15 +200,7 @@ instance
290
200
291 type ServerT (Delete ctypes ()) m = m ()
201 type ServerT (Delete ctypes ()) m = m ()
292
202
293− route Proxy action request respond
203+ route Proxy = methodRouterEmpty methodDelete
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
302
204
303-- Add response headers
205-- Add response headers
304instance
206instance
@@ -310,21 +212,7 @@ instance
310
212
311 type ServerT (Delete ctypes (Headers h v)) m = m (Headers h v)
213 type ServerT (Delete ctypes (Headers h v)) m = m (Headers h v)
312
214
313− route Proxy action request respond
215+ route Proxy = methodRouterHeaders methodDelete (Proxy :: Proxy ctypes) ok200
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
328
216
329-- | When implementing the handler for a 'Get' endpoint,
217-- | When implementing the handler for a 'Get' endpoint,
330-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Post.Post'
218-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Post.Post'
@@ -347,20 +235,7 @@ instance
347
235
348 type ServerT (Get ctypes a) m = m a
236 type ServerT (Get ctypes a) m = m a
349
237
350− route Proxy action request respond
238+ route Proxy = methodRouter methodGet (Proxy :: Proxy ctypes) ok200
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
364
239
365-- '()' ==> 204 No Content
240-- '()' ==> 204 No Content
366instance
241instance
@@ -371,15 +246,7 @@ instance
371
246
372 type ServerT (Get ctypes ()) m = m ()
247 type ServerT (Get ctypes ()) m = m ()
373
248
374− route Proxy action request respond
249+ route Proxy = methodRouterEmpty methodGet
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
383
250
384-- Add response headers
251-- Add response headers
385instance
252instance
@@ -391,21 +258,7 @@ instance
391
258
392 type ServerT (Get ctypes (Headers h v)) m = m (Headers h v)
259 type ServerT (Get ctypes (Headers h v)) m = m (Headers h v)
393
260
394− route Proxy action request respond
261+ route Proxy = methodRouterHeaders methodGet (Proxy :: Proxy ctypes) ok200
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
409
262
410-- | If you use 'Header' in one of the endpoints for your API,
263-- | If you use 'Header' in one of the endpoints for your API,
411-- this automatically requires your server-side handler to be a function
264-- this automatically requires your server-side handler to be a function
@@ -433,11 +286,10 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
433 type ServerT (Header sym a :> sublayout) m =
286 type ServerT (Header sym a :> sublayout) m =
434 Maybe a -> ServerT sublayout m
287 Maybe a -> ServerT sublayout m
435
288
436− route Proxy subserver request respond = do
289+ route Proxy subserver = WithRequest $ \ request ->
437 let mheader = fromText . decodeUtf8 =<< lookup str (requestHeaders request)
290 let mheader = fromText . decodeUtf8 =<< lookup str (requestHeaders request)
438− route (Proxy :: Proxy sublayout) (subserver mheader) request respond
291+ in route (Proxy :: Proxy sublayout) (feedTo subserver mheader)
439−
440− where str = fromString $ symbolVal (Proxy :: Proxy sym)
292+ where str = fromString $ symbolVal (Proxy :: Proxy sym)
441
293
442-- | When implementing the handler for a 'Post' endpoint,
294-- | When implementing the handler for a 'Post' endpoint,
443-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'
295-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'
@@ -461,20 +313,7 @@ instance
461
313
462 type ServerT (Post ctypes a) m = m a
314 type ServerT (Post ctypes a) m = m a
463
315
464− route Proxy action request respond
316+ route Proxy = methodRouter methodPost (Proxy :: Proxy ctypes) created201
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
478
317
479instance
318instance
480#if MIN_VERSION_base(4,8,0)
319#if MIN_VERSION_base(4,8,0)
@@ -484,15 +323,7 @@ instance
484
323
485 type ServerT (Post ctypes ()) m = m ()
324 type ServerT (Post ctypes ()) m = m ()
486
325
487− route Proxy action request respond
326+ route Proxy = methodRouterEmpty methodPost
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
496
327
497-- Add response headers
328-- Add response headers
498instance
329instance
@@ -504,21 +335,7 @@ instance
504
335
505 type ServerT (Post ctypes (Headers h v)) m = m (Headers h v)
336 type ServerT (Post ctypes (Headers h v)) m = m (Headers h v)
506
337
507− route Proxy action request respond
338+ route Proxy = methodRouterHeaders methodPost (Proxy :: Proxy ctypes) created201
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
522
339
523-- | When implementing the handler for a 'Put' endpoint,
340-- | When implementing the handler for a 'Put' endpoint,
524-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'
341-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'
@@ -541,20 +358,7 @@ instance
541
358
542 type ServerT (Put ctypes a) m = m a
359 type ServerT (Put ctypes a) m = m a
543
360
544− route Proxy action request respond
361+ route Proxy = methodRouter methodPut (Proxy :: Proxy ctypes) ok200
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
558
362
559instance
363instance
560#if MIN_VERSION_base(4,8,0)
364#if MIN_VERSION_base(4,8,0)
@@ -564,15 +368,7 @@ instance
564
368
565 type ServerT (Put ctypes ()) m = m ()
369 type ServerT (Put ctypes ()) m = m ()
566
370
567− route Proxy action request respond
371+ route Proxy = methodRouterEmpty methodPut
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
576
372
577-- Add response headers
373-- Add response headers
578instance
374instance
@@ -584,21 +380,7 @@ instance
584
380
585 type ServerT (Put ctypes (Headers h v)) m = m (Headers h v)
381 type ServerT (Put ctypes (Headers h v)) m = m (Headers h v)
586
382
587− route Proxy action request respond
383+ route Proxy = methodRouterHeaders methodPut (Proxy :: Proxy ctypes) ok200
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
602
384
603-- | When implementing the handler for a 'Patch' endpoint,
385-- | When implementing the handler for a 'Patch' endpoint,
604-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'
386-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'
@@ -619,20 +401,7 @@ instance
619
401
620 type ServerT (Patch ctypes a) m = m a
402 type ServerT (Patch ctypes a) m = m a
621
403
622− route Proxy action request respond
404+ route Proxy = methodRouter methodPatch (Proxy :: Proxy ctypes) ok200
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
636
405
637instance
406instance
638#if MIN_VERSION_base(4,8,0)
407#if MIN_VERSION_base(4,8,0)
@@ -642,15 +411,7 @@ instance
642
411
643 type ServerT (Patch ctypes ()) m = m ()
412 type ServerT (Patch ctypes ()) m = m ()
644
413
645− route Proxy action request respond
414+ route Proxy = methodRouterEmpty methodPatch
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
654
415
655-- Add response headers
416-- Add response headers
656instance
417instance
@@ -662,21 +423,7 @@ instance
662
423
663 type ServerT (Patch ctypes (Headers h v)) m = m (Headers h v)
424 type ServerT (Patch ctypes (Headers h v)) m = m (Headers h v)
664
425
665− route Proxy action request respond
426+ route Proxy = methodRouterHeaders methodPatch (Proxy :: Proxy ctypes) ok200
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
680
427
681-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,
428-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,
682-- this automatically requires your server-side handler to be a function
429-- this automatically requires your server-side handler to be a function
@@ -705,7 +452,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
705 type ServerT (QueryParam sym a :> sublayout) m =
452 type ServerT (QueryParam sym a :> sublayout) m =
706 Maybe a -> ServerT sublayout m
453 Maybe a -> ServerT sublayout m
707
454
708− route Proxy subserver request respond = do
455+ route Proxy subserver = WithRequest $ \ request ->
709 let querytext = parseQueryText $ rawQueryString request
456 let querytext = parseQueryText $ rawQueryString request
710 param =
457 param =
711 case lookup paramname querytext of
458 case lookup paramname querytext of
@@ -713,9 +460,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
713 Just Nothing -> Nothing -- param present with no value -> Nothing
460 Just Nothing -> Nothing -- param present with no value -> Nothing
714 Just (Just v) -> fromText v -- if present, we try to convert to
461 Just (Just v) -> fromText v -- if present, we try to convert to
715 -- the right type
462 -- the right type
716−
717− route (Proxy :: Proxy sublayout) (subserver param) request respond
463+ in route (Proxy :: Proxy sublayout) (feedTo subserver param)
718−
719 where paramname = cs $ symbolVal (Proxy :: Proxy sym)
464 where paramname = cs $ symbolVal (Proxy :: Proxy sym)
720
465
721-- | If you use @'QueryParams' "authors" Text@ in one of the endpoints for your API,
466-- | If you use @'QueryParams' "authors" Text@ in one of the endpoints for your API,
@@ -743,16 +488,14 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
743 type ServerT (QueryParams sym a :> sublayout) m =
488 type ServerT (QueryParams sym a :> sublayout) m =
744 [a] -> ServerT sublayout m
489 [a] -> ServerT sublayout m
745
490
746− route Proxy subserver request respond = do
491+ route Proxy subserver = WithRequest $ \ request ->
747 let querytext = parseQueryText $ rawQueryString request
492 let querytext = parseQueryText $ rawQueryString request
748 -- if sym is "foo", we look for query string parameters
493 -- if sym is "foo", we look for query string parameters
749 -- named "foo" or "foo[]" and call fromText on the
494 -- named "foo" or "foo[]" and call fromText on the
750 -- corresponding values
495 -- corresponding values
751 parameters = filter looksLikeParam querytext
496 parameters = filter looksLikeParam querytext
752 values = catMaybes $ map (convert . snd) parameters
497 values = catMaybes $ map (convert . snd) parameters
753−
754− route (Proxy :: Proxy sublayout) (subserver values) request respond
498+ in route (Proxy :: Proxy sublayout) (feedTo subserver values)
755−
756 where paramname = cs $ symbolVal (Proxy :: Proxy sym)
499 where paramname = cs $ symbolVal (Proxy :: Proxy sym)
757 looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")
500 looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")
758 convert Nothing = Nothing
501 convert Nothing = Nothing
@@ -776,15 +519,13 @@ instance (KnownSymbol sym, HasServer sublayout)
776 type ServerT (QueryFlag sym :> sublayout) m =
519 type ServerT (QueryFlag sym :> sublayout) m =
777 Bool -> ServerT sublayout m
520 Bool -> ServerT sublayout m
778
521
779− route Proxy subserver request respond = do
522+ route Proxy subserver = WithRequest $ \ request ->
780 let querytext = parseQueryText $ rawQueryString request
523 let querytext = parseQueryText $ rawQueryString request
781 param = case lookup paramname querytext of
524 param = case lookup paramname querytext of
782 Just Nothing -> True -- param is there, with no value
525 Just Nothing -> True -- param is there, with no value
783 Just (Just v) -> examine v -- param with a value
526 Just (Just v) -> examine v -- param with a value
784 Nothing -> False -- param not in the query string
527 Nothing -> False -- param not in the query string
785−
786− route (Proxy :: Proxy sublayout) (subserver param) request respond
528+ in route (Proxy :: Proxy sublayout) (feedTo subserver param)
787−
788 where paramname = cs $ symbolVal (Proxy :: Proxy sym)
529 where paramname = cs $ symbolVal (Proxy :: Proxy sym)
789 examine v | v == "true" || v == "1" || v == "" = True
530 examine v | v == "true" || v == "1" || v == "" = True
790 | otherwise = False
531 | otherwise = False
@@ -819,16 +560,17 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
819 type ServerT (MatrixParam sym a :> sublayout) m =
560 type ServerT (MatrixParam sym a :> sublayout) m =
820 Maybe a -> ServerT sublayout m
561 Maybe a -> ServerT sublayout m
821
562
563+ route Proxy subserver = WithRequest $ \ request ->
822− route Proxy subserver request respond = case parsePathInfo request of
564+ case parsePathInfo request of
823− (first : _)
565+ (first : _)
824− -> do let querytext = parseMatrixText . encodeUtf8 $ T.tail first
566+ -> do let querytext = parseMatrixText . encodeUtf8 $ T.tail first
825− param = case lookup paramname querytext of
567+ param = case lookup paramname querytext of
826− Nothing -> Nothing -- param absent from the query string
568+ Nothing -> Nothing -- param absent from the query string
827− Just Nothing -> Nothing -- param present with no value -> Nothing
569+ Just Nothing -> Nothing -- param present with no value -> Nothing
828− Just (Just v) -> fromText v -- if present, we try to convert to
570+ Just (Just v) -> fromText v -- if present, we try to convert to
829− -- the right type
571+ -- the right type
830− route (Proxy :: Proxy sublayout) (subserver param) request respond
572+ route (Proxy :: Proxy sublayout) (feedTo subserver param)
831− _ -> route (Proxy :: Proxy sublayout) (subserver Nothing) request respond
573+ _ -> route (Proxy :: Proxy sublayout) (feedTo subserver Nothing)
832
574
833 where paramname = cs $ symbolVal (Proxy :: Proxy sym)
575 where paramname = cs $ symbolVal (Proxy :: Proxy sym)
834
576
@@ -857,16 +599,17 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
857 type ServerT (MatrixParams sym a :> sublayout) m =
599 type ServerT (MatrixParams sym a :> sublayout) m =
858 [a] -> ServerT sublayout m
600 [a] -> ServerT sublayout m
859
601
602+ route Proxy subserver = WithRequest $ \ request ->
860− route Proxy subserver request respond = case parsePathInfo request of
603+ case parsePathInfo request of
861− (first : _)
604+ (first : _)
862− -> do let matrixtext = parseMatrixText . encodeUtf8 $ T.tail first
605+ -> do let matrixtext = parseMatrixText . encodeUtf8 $ T.tail first
863− -- if sym is "foo", we look for matrix parameters
606+ -- if sym is "foo", we look for matrix parameters
864− -- named "foo" or "foo[]" and call fromText on the
607+ -- named "foo" or "foo[]" and call fromText on the
865− -- corresponding values
608+ -- corresponding values
866− parameters = filter looksLikeParam matrixtext
609+ parameters = filter looksLikeParam matrixtext
867− values = catMaybes $ map (convert . snd) parameters
610+ values = catMaybes $ map (convert . snd) parameters
868− route (Proxy :: Proxy sublayout) (subserver values) request respond
611+ route (Proxy :: Proxy sublayout) (feedTo subserver values)
869− _ -> route (Proxy :: Proxy sublayout) (subserver []) request respond
612+ _ -> route (Proxy :: Proxy sublayout) (feedTo subserver [])
870
613
871 where paramname = cs $ symbolVal (Proxy :: Proxy sym)
614 where paramname = cs $ symbolVal (Proxy :: Proxy sym)
872 looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")
615 looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")
@@ -891,17 +634,18 @@ instance (KnownSymbol sym, HasServer sublayout)
891 type ServerT (MatrixFlag sym :> sublayout) m =
634 type ServerT (MatrixFlag sym :> sublayout) m =
892 Bool -> ServerT sublayout m
635 Bool -> ServerT sublayout m
893
636
637+ route Proxy subserver = WithRequest $ \ request ->
894− route Proxy subserver request respond = case parsePathInfo request of
638+ case parsePathInfo request of
895− (first : _)
639+ (first : _)
896− -> do let matrixtext = parseMatrixText . encodeUtf8 $ T.tail first
640+ -> do let matrixtext = parseMatrixText . encodeUtf8 $ T.tail first
897− param = case lookup paramname matrixtext of
641+ param = case lookup paramname matrixtext of
898− Just Nothing -> True -- param is there, with no value
642+ Just Nothing -> True -- param is there, with no value
899− Just (Just v) -> examine v -- param with a value
643+ Just (Just v) -> examine v -- param with a value
900− Nothing -> False -- param not in the query string
644+ Nothing -> False -- param not in the query string
901−
645+
902− route (Proxy :: Proxy sublayout) (subserver param) request respond
646+ route (Proxy :: Proxy sublayout) (feedTo subserver param)
903−
647+
904− _ -> route (Proxy :: Proxy sublayout) (subserver False) request respond
648+ _ -> route (Proxy :: Proxy sublayout) (feedTo subserver False)
905
649
906 where paramname = cs $ symbolVal (Proxy :: Proxy sym)
650 where paramname = cs $ symbolVal (Proxy :: Proxy sym)
907 examine v | v == "true" || v == "1" || v == "" = True
651 examine v | v == "true" || v == "1" || v == "" = True
@@ -919,8 +663,11 @@ instance HasServer Raw where
919
663
920 type ServerT Raw m = Application
664 type ServerT Raw m = Application
921
665
922− route Proxy rawApplication request respond =
666+ route Proxy rawApplication = LeafRouter $ \ request respond -> do
667+ r <- rawApplication
668+ case r of
669+ RR (Left err) -> respond $ failWith err
923− rawApplication request (respond . succeedWith)
670+ RR (Right app) -> app request (respond . succeedWith)
924
671
925-- | If you use 'ReqBody' in one of the endpoints for your API,
672-- | If you use 'ReqBody' in one of the endpoints for your API,
926-- this automatically requires your server-side handler to be a function
673-- this automatically requires your server-side handler to be a function
@@ -948,19 +695,20 @@ instance ( AllCTUnrender list a, HasServer sublayout
948 type ServerT (ReqBody list a :> sublayout) m =
695 type ServerT (ReqBody list a :> sublayout) m =
949 a -> ServerT sublayout m
696 a -> ServerT sublayout m
950
697
951− route Proxy subserver request respond = do
698+ route Proxy subserver = WithRequest $ \ request ->
699+ route (Proxy :: Proxy sublayout) $ do
952− -- See HTTP RFC 2616, section 7.2.1
700+ -- See HTTP RFC 2616, section 7.2.1
953− -- http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1
701+ -- http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1
954− -- See also "W3C Internet Media Type registration, consistency of use"
702+ -- See also "W3C Internet Media Type registration, consistency of use"
955− -- http://www.w3.org/2001/tag/2002/0129-mime
703+ -- http://www.w3.org/2001/tag/2002/0129-mime
956− let contentTypeH = fromMaybe "application/octet-stream"
704+ let contentTypeH = fromMaybe "application/octet-stream"
957− $ lookup hContentType $ requestHeaders request
705+ $ lookup hContentType $ requestHeaders request
958− mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH)
706+ mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH)
959− <$> lazyRequestBody request
707+ <$> lazyRequestBody request
960− case mrqbody of
708+ case mrqbody of
961− Nothing -> respond . failWith $ UnsupportedMediaType
709+ Nothing -> return $ failWith $ UnsupportedMediaType
962− Just (Left e) -> respond . failWith $ InvalidBody e
710+ Just (Left e) -> return $ failWith $ InvalidBody e
963− Just (Right v) -> route (Proxy :: Proxy sublayout) (subserver v) request respond
711+ Just (Right v) -> feedTo subserver v
964
712
965-- | Make sure the incoming request starts with @"/path"@, strip it and
713-- | Make sure the incoming request starts with @"/path"@, strip it and
966-- pass the rest of the request path to @sublayout@.
714-- pass the rest of the request path to @sublayout@.
@@ -968,14 +716,9 @@ instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout
968
716
969 type ServerT (path :> sublayout) m = ServerT sublayout m
717 type ServerT (path :> sublayout) m = ServerT sublayout m
970
718
971− route Proxy subserver request respond = case processedPathInfo request of
719+ route Proxy subserver = StaticRouter $
972− (first : rest)
973− | first == cs (symbolVal proxyPath)
720+ M.singleton (cs (symbolVal proxyPath))
974− -> route (Proxy :: Proxy sublayout) subserver request{
721+ (route (Proxy :: Proxy sublayout) subserver)
975− pathInfo = rest
976− } respond
977− _ -> respond $ failWith NotFound
978−
979 where proxyPath = Proxy :: Proxy path
722 where proxyPath = Proxy :: Proxy path
980
723
981ct_wildcard :: B.ByteString
724ct_wildcard :: B.ByteString
servant-server/src/Servant/Server/Internal/PathInfo.hsnew file+38
@@ -0,0 +1,38 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Servant.Server.Internal.PathInfo where
3+
4+import Data.List (unfoldr)
5+import Data.Text (Text)
6+import qualified Data.Text as T
7+import Network.Wai (Request, pathInfo)
8+
9+-- | Like `null . pathInfo`, but works with redundant trailing slashes.
10+pathIsEmpty :: Request -> Bool
11+pathIsEmpty = f . processedPathInfo
12+ where
13+ f [] = True
14+ f [""] = True
15+ f _ = False
16+
17+
18+splitMatrixParameters :: Text -> (Text, Text)
19+splitMatrixParameters = T.break (== ';')
20+
21+parsePathInfo :: Request -> [Text]
22+parsePathInfo = filter (/= "") . mergePairs . map splitMatrixParameters . pathInfo
23+ where mergePairs = concat . unfoldr pairToList
24+ pairToList [] = Nothing
25+ pairToList ((a, b):xs) = Just ([a, b], xs)
26+
27+-- | Returns a processed pathInfo from the request.
28+--
29+-- In order to handle matrix parameters in the request correctly, the raw pathInfo needs to be
30+-- processed, so routing works as intended. Therefor this function should be used to access
31+-- the pathInfo for routing purposes.
32+processedPathInfo :: Request -> [Text]
33+processedPathInfo r =
34+ case pinfo of
35+ (x:xs) | T.head x == ';' -> xs
36+ _ -> pinfo
37+ where pinfo = parsePathInfo r
38+
servant-server/src/Servant/Server/Internal/Router.hsnew file+72
@@ -0,0 +1,72 @@
1+module Servant.Server.Internal.Router where
2+
3+import Data.Map (Map)
4+import qualified Data.Map as M
5+import Data.Monoid ((<>))
6+import Data.Text (Text)
7+import Network.Wai (Request, pathInfo)
8+import Servant.Server.Internal.PathInfo
9+import Servant.Server.Internal.RoutingApplication
10+
11+-- | Internal representation of a router.
12+data Router =
13+ WithRequest (Request -> Router)
14+ -- ^ current request is passed to the router
15+ | StaticRouter (Map Text Router)
16+ -- ^ first path component used for lookup and removed afterwards
17+ | DynamicRouter (Text -> Router)
18+ -- ^ first path component used for lookup and removed afterwards
19+ | LeafRouter RoutingApplication
20+ -- ^ to be used for routes that match an empty path
21+ | Choice Router Router
22+ -- ^ left-biased choice between two routers
23+
24+-- | Smart constructor for the choice between routers.
25+-- We currently optimize the following cases:
26+--
27+-- * Two static routers can be joined by joining their maps.
28+-- * Two dynamic routers can be joined by joining their codomains.
29+-- * Two 'WithRequest' routers can be joined by passing them
30+-- the same request and joining their codomains.
31+-- * A 'WithRequest' router can be joined with anything else by
32+-- passing the same request to both but ignoring it in the
33+-- component that does not need it.
34+--
35+choice :: Router -> Router -> Router
36+choice (StaticRouter table1) (StaticRouter table2) =
37+ StaticRouter (M.unionWith choice table1 table2)
38+choice (DynamicRouter fun1) (DynamicRouter fun2) =
39+ DynamicRouter (\ first -> choice (fun1 first) (fun2 first))
40+choice (WithRequest router1) (WithRequest router2) =
41+ WithRequest (\ request -> choice (router1 request) (router2 request))
42+choice (WithRequest router1) router2 =
43+ WithRequest (\ request -> choice (router1 request) router2)
44+choice router1 (WithRequest router2) =
45+ WithRequest (\ request -> choice router1 (router2 request))
46+choice router1 router2 = Choice router1 router2
47+
48+-- | Interpret a router as an application.
49+runRouter :: Router -> RoutingApplication
50+runRouter (WithRequest router) request respond =
51+ runRouter (router request) request respond
52+runRouter (StaticRouter table) request respond =
53+ case processedPathInfo request of
54+ first : rest
55+ | Just router <- M.lookup first table
56+ -> let request' = request { pathInfo = rest }
57+ in runRouter router request' respond
58+ _ -> respond $ failWith NotFound
59+runRouter (DynamicRouter fun) request respond =
60+ case processedPathInfo request of
61+ first : rest
62+ -> let request' = request { pathInfo = rest }
63+ in runRouter (fun first) request' respond
64+ _ -> respond $ failWith NotFound
65+runRouter (LeafRouter app) request respond = app request respond
66+runRouter (Choice r1 r2) request respond =
67+ runRouter r1 request $ \ mResponse1 ->
68+ if isMismatch mResponse1
69+ then runRouter r2 request $ \ mResponse2 ->
70+ respond (mResponse1 <> mResponse2)
71+ else respond mResponse1
72+
servant-server/src/Servant/Server/Internal/RoutingApplication.hsnew file+144
@@ -0,0 +1,144 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3+{-# LANGUAGE OverloadedStrings #-}
4+{-# LANGUAGE TypeOperators #-}
5+module Servant.Server.Internal.RoutingApplication where
6+
7+#if !MIN_VERSION_base(4,8,0)
8+import Control.Applicative (Applicative, (<$>))
9+import Data.Monoid (Monoid, mappend, mempty)
10+#endif
11+import Control.Monad.Trans.Either (EitherT, runEitherT)
12+import qualified Data.ByteString as B
13+import qualified Data.ByteString.Lazy as BL
14+import Data.IORef (newIORef, readIORef, writeIORef)
15+import Data.Maybe (fromMaybe)
16+import Data.Monoid ((<>))
17+import Data.String (fromString)
18+import Network.HTTP.Types hiding (Header, ResponseHeaders)
19+import Network.Wai (Application, Request, Response,
20+ ResponseReceived,
21+ requestBody,
22+ responseLBS,
23+ strictRequestBody)
24+import Servant.API ((:<|>) (..))
25+import Servant.Server.Internal.ServantErr
26+
27+type RoutingApplication =
28+ Request -- ^ the request, the field 'pathInfo' may be modified by url routing
29+ -> (RouteResult Response -> IO ResponseReceived) -> IO ResponseReceived
30+
31+-- | A wrapper around @'Either' 'RouteMismatch' a@.
32+newtype RouteResult a =
33+ RR { routeResult :: Either RouteMismatch a }
34+ deriving (Eq, Show, Functor, Applicative)
35+
36+-- | If we get a `Right`, it has precedence over everything else.
37+--
38+-- This in particular means that if we could get several 'Right's,
39+-- only the first we encounter would be taken into account.
40+instance Monoid (RouteResult a) where
41+ mempty = RR $ Left mempty
42+
43+ RR (Left x) `mappend` RR (Left y) = RR $ Left (x <> y)
44+ RR (Left _) `mappend` RR (Right y) = RR $ Right y
45+ r `mappend` _ = r
46+
47+-- Note that the ordering of the constructors has great significance! It
48+-- determines the Ord instance and, consequently, the monoid instance.
49+data RouteMismatch =
50+ NotFound -- ^ the usual "not found" error
51+ | WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error
52+ | UnsupportedMediaType -- ^ request body has unsupported media type
53+ | InvalidBody String -- ^ an even more informative "your json request body wasn't valid" error
54+ | HttpError Status (Maybe BL.ByteString) -- ^ an even even more informative arbitrary HTTP response code error.
55+ deriving (Eq, Ord, Show)
56+
57+instance Monoid RouteMismatch where
58+ mempty = NotFound
59+ -- The following isn't great, since it picks @InvalidBody@ based on
60+ -- alphabetical ordering, but any choice would be arbitrary.
61+ --
62+ -- "As one judge said to the other, 'Be just and if you can't be just, be
63+ -- arbitrary'" -- William Burroughs
64+ mappend = max
65+
66+data ReqBodyState = Uncalled
67+ | Called !B.ByteString
68+ | Done !B.ByteString
69+
70+toApplication :: RoutingApplication -> Application
71+toApplication ra request respond = do
72+ reqBodyRef <- newIORef Uncalled
73+ -- We may need to consume the requestBody more than once. In order to
74+ -- maintain the illusion that 'requestBody' works as expected,
75+ -- 'ReqBodyState' is introduced, and the complete body is memoized and
76+ -- returned as many times as requested with empty "Done" marker chunks in
77+ -- between.
78+ -- See https://github.com/haskell-servant/servant/issues/3
79+ let memoReqBody = do
80+ ior <- readIORef reqBodyRef
81+ case ior of
82+ Uncalled -> do
83+ r <- BL.toStrict <$> strictRequestBody request
84+ writeIORef reqBodyRef $ Done r
85+ return r
86+ Called bs -> do
87+ writeIORef reqBodyRef $ Done bs
88+ return bs
89+ Done bs -> do
90+ writeIORef reqBodyRef $ Called bs
91+ return B.empty
92+
93+ ra request{ requestBody = memoReqBody } (routingRespond . routeResult)
94+ where
95+ routingRespond :: Either RouteMismatch Response -> IO ResponseReceived
96+ routingRespond (Left NotFound) =
97+ respond $ responseLBS notFound404 [] "not found"
98+ routingRespond (Left WrongMethod) =
99+ respond $ responseLBS methodNotAllowed405 [] "method not allowed"
100+ routingRespond (Left (InvalidBody err)) =
101+ respond $ responseLBS badRequest400 [] $ fromString $ "invalid request body: " ++ err
102+ routingRespond (Left UnsupportedMediaType) =
103+ respond $ responseLBS unsupportedMediaType415 [] "unsupported media type"
104+ routingRespond (Left (HttpError status body)) =
105+ respond $ responseLBS status [] $ fromMaybe (BL.fromStrict $ statusMessage status) body
106+ routingRespond (Right response) =
107+ respond response
108+
109+runAction :: IO (RouteResult (EitherT ServantErr IO a))
110+ -> (RouteResult Response -> IO r)
111+ -> (a -> RouteResult Response)
112+ -> IO r
113+runAction action respond k = do
114+ r <- action
115+ go r
116+ where
117+ go (RR (Right a)) = do
118+ e <- runEitherT a
119+ respond $ case e of
120+ Right x -> k x
121+ Left err -> succeedWith $ responseServantErr err
122+ go (RR (Left err)) = respond $ failWith err
123+
124+feedTo :: IO (RouteResult (a -> b)) -> a -> IO (RouteResult b)
125+feedTo f x = (($ x) <$>) <$> f
126+
127+extractL :: RouteResult (a :<|> b) -> RouteResult a
128+extractL (RR (Right (a :<|> _))) = RR (Right a)
129+extractL (RR (Left err)) = RR (Left err)
130+
131+extractR :: RouteResult (a :<|> b) -> RouteResult b
132+extractR (RR (Right (_ :<|> b))) = RR (Right b)
133+extractR (RR (Left err)) = RR (Left err)
134+
135+failWith :: RouteMismatch -> RouteResult a
136+failWith = RR . Left
137+
138+succeedWith :: a -> RouteResult a
139+succeedWith = RR . Right
140+
141+isMismatch :: RouteResult a -> Bool
142+isMismatch (RR (Left _)) = True
143+isMismatch _ = False
144+
servant-server/test/Servant/ServerSpec.hs+51−1
@@ -42,7 +42,8 @@ import Servant.API ((:<|>) (..), (:>),
42 Post, Put, QueryFlag, QueryParam,
42 Post, Put, QueryFlag, QueryParam,
43 QueryParams, Raw, ReqBody)
43 QueryParams, Raw, ReqBody)
44import Servant.Server (Server, serve, ServantErr(..), err404)
44import Servant.Server (Server, serve, ServantErr(..), err404)
45−import Servant.Server.Internal (RouteMismatch (..))
45+import Servant.Server.Internal.RoutingApplication
46+ (RouteMismatch (..))
46
47
47
48
48-- * test data types
49-- * test data types
@@ -89,6 +90,7 @@ spec = do
89 headerSpec
90 headerSpec
90 rawSpec
91 rawSpec
91 unionSpec
92 unionSpec
93+ prioErrorsSpec
92 errorsSpec
94 errorsSpec
93 responseHeadersSpec
95 responseHeadersSpec
94
96
@@ -572,6 +574,54 @@ responseHeadersSpec = describe "ResponseHeaders" $ do
572 Test.Hspec.Wai.request method "" [(hAccept, "crazy/mime")] ""
574 Test.Hspec.Wai.request method "" [(hAccept, "crazy/mime")] ""
573 `shouldRespondWith` 415
575 `shouldRespondWith` 415
574
576
577+type PrioErrorsApi = ReqBody '[JSON] Person :> "foo" :> Get '[JSON] Integer
578+
579+prioErrorsApi :: Proxy PrioErrorsApi
580+prioErrorsApi = Proxy
581+
582+-- | Test the relative priority of error responses from the server.
583+--
584+-- In particular, we check whether matching continues even if a 'ReqBody'
585+-- or similar construct is encountered early in a path. We don't want to
586+-- see a complaint about the request body unless the path actually matches.
587+--
588+prioErrorsSpec :: Spec
589+prioErrorsSpec = describe "PrioErrors" $ do
590+ let server = return . age
591+ with (return $ serve prioErrorsApi server) $ do
592+ let check (mdescr, method) path (cdescr, ctype, body) resp =
593+ it fulldescr $
594+ Test.Hspec.Wai.request method path [(hContentType, ctype)] body
595+ `shouldRespondWith` resp
596+ where
597+ fulldescr = "returns " ++ show (matchStatus resp) ++ " on " ++ mdescr
598+ ++ " " ++ cs path ++ " (" ++ cdescr ++ ")"
599+
600+ get' = ("GET", methodGet)
601+ put' = ("PUT", methodPut)
602+
603+ txt = ("text" , "text/plain;charset=utf8" , "42" )
604+ ijson = ("invalid json", "application/json;charset=utf8", "invalid" )
605+ vjson = ("valid json" , "application/json;charset=utf8", encode alice)
606+
607+ check get' "/" txt 404
608+ check get' "/bar" txt 404
609+ check get' "/foo" txt 415
610+ check put' "/" txt 404
611+ check put' "/bar" txt 404
612+ check put' "/foo" txt 405
613+ check get' "/" ijson 404
614+ check get' "/bar" ijson 404
615+ check get' "/foo" ijson 400
616+ check put' "/" ijson 404
617+ check put' "/bar" ijson 404
618+ check put' "/foo" ijson 405
619+ check get' "/" vjson 404
620+ check get' "/bar" vjson 404
621+ check get' "/foo" vjson 200
622+ check put' "/" vjson 404
623+ check put' "/bar" vjson 404
624+ check put' "/foo" vjson 405
575
625
576-- | Test server error functionality.
626-- | Test server error functionality.
577errorsSpec :: Spec
627errorsSpec :: Spec