@@ -12,17 +12,19 @@
1212{-# LANGUAGE OverlappingInstances #-}
1313#endif
1414
15−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
1622
1723#if !MIN_VERSION_base(4,8,0)
18−import Control.Applicative (Applicative, (<$>))
19−import Data.Monoid (Monoid, mappend, mempty)
24+import Control.Applicative ((<$>))
2025#endif
21−import Control.Monad.Trans.Either (EitherT, runEitherT)
26+import Control.Monad.Trans.Either (EitherT)
2227import qualified Data.ByteString as B
23−import qualified Data.ByteString.Lazy as BL
24−import Data.IORef (newIORef, readIORef, writeIORef)
25−import Data.List (unfoldr)
2628import qualified Data.Map as M
2729import Data.Maybe (catMaybes, fromMaybe)
2830import Data.String (fromString)
@@ -33,12 +35,9 @@ import Data.Text.Encoding (decodeUtf8, encodeUtf8)
3335import Data.Typeable
3436import GHC.TypeLits (KnownSymbol, symbolVal)
3537import Network.HTTP.Types hiding (Header, ResponseHeaders)
36−import Network.Wai (Application, Request, Response,
37− ResponseReceived, lazyRequestBody,
38− pathInfo, rawQueryString,
39− requestBody, requestHeaders,
40− requestMethod, responseLBS,
41− strictRequestBody)
38+import Network.Wai (Application, lazyRequestBody,
39+ rawQueryString, requestHeaders,
40+ requestMethod, responseLBS)
4241import Servant.API ((:<|>) (..), (:>), Capture,
4342 Delete, Get, Header,
4443 MatrixFlag, MatrixParam, MatrixParams,
@@ -52,220 +51,11 @@ import Servant.API.ResponseHeaders (Headers, getResponse, GetHeaders,
5251 getHeaders)
5352import Servant.Common.Text (FromText, fromText)
5453
54+import Servant.Server.Internal.PathInfo
55+import Servant.Server.Internal.Router
56+import Servant.Server.Internal.RoutingApplication
5557import Servant.Server.Internal.ServantErr
5658
57−-- | Internal representation of a router.
58−data Router =
59− WithRequest (Request -> Router)
60− -- ^ current request is passed to the router
61− | StaticRouter (M.Map Text Router)
62− -- ^ first path component used for lookup and removed afterwards
63− | DynamicRouter (Text -> Router)
64− -- ^ first path component used for lookup and removed afterwards
65− | LeafRouter RoutingApplication
66− -- ^ to be used for routes that match an empty path
67− | Choice Router Router
68− -- ^ left-biased choice between two routers
69−
70−-- | Smart constructor for the choice between routers.
71−-- We currently optimize the following cases:
72−--
73−-- * Two static routers can be joined by joining their maps.
74−-- * Two dynamic routers can be joined by joining their codomains.
75−-- * Two 'WithRequest' routers can be joined by passing them
76−-- the same request and joining their codomains.
77−-- * A 'WithRequest' router can be joined with anything else by
78−-- passing the same request to both but ignoring it in the
79−-- component that does not need it.
80−--
81−choice :: Router -> Router -> Router
82−choice (StaticRouter table1) (StaticRouter table2) =
83− StaticRouter (M.unionWith choice table1 table2)
84−choice (DynamicRouter fun1) (DynamicRouter fun2) =
85− DynamicRouter (\ first -> choice (fun1 first) (fun2 first))
86−choice (WithRequest router1) (WithRequest router2) =
87− WithRequest (\ request -> choice (router1 request) (router2 request))
88−choice (WithRequest router1) router2 =
89− WithRequest (\ request -> choice (router1 request) router2)
90−choice router1 (WithRequest router2) =
91− WithRequest (\ request -> choice router1 (router2 request))
92−choice router1 router2 = Choice router1 router2
93−
94−-- | Interpret a router as an application.
95−runRouter :: Router -> RoutingApplication
96−runRouter (WithRequest router) request respond =
97− runRouter (router request) request respond
98−runRouter (StaticRouter table) request respond =
99− case processedPathInfo request of
100− first : rest
101− | Just router <- M.lookup first table
102− -> let request' = request { pathInfo = rest }
103− in runRouter router request' respond
104− _ -> respond $ failWith NotFound
105−runRouter (DynamicRouter fun) request respond =
106− case processedPathInfo request of
107− first : rest
108− -> let request' = request { pathInfo = rest }
109− in runRouter (fun first) request' respond
110− _ -> respond $ failWith NotFound
111−runRouter (LeafRouter app) request respond = app request respond
112−runRouter (Choice r1 r2) request respond =
113− runRouter r1 request $ \ mResponse1 ->
114− if isMismatch mResponse1
115− then runRouter r2 request $ \ mResponse2 ->
116− respond (mResponse1 <> mResponse2)
117− else respond mResponse1
118−
119−data ReqBodyState = Uncalled
120− | Called !B.ByteString
121− | Done !B.ByteString
122−
123−
124−toApplication :: RoutingApplication -> Application
125−toApplication ra request respond = do
126− reqBodyRef <- newIORef Uncalled
127− -- We may need to consume the requestBody more than once. In order to
128− -- maintain the illusion that 'requestBody' works as expected,
129− -- 'ReqBodyState' is introduced, and the complete body is memoized and
130− -- returned as many times as requested with empty "Done" marker chunks in
131− -- between.
132− -- See https://github.com/haskell-servant/servant/issues/3
133− let memoReqBody = do
134− ior <- readIORef reqBodyRef
135− case ior of
136− Uncalled -> do
137− r <- BL.toStrict <$> strictRequestBody request
138− writeIORef reqBodyRef $ Done r
139− return r
140− Called bs -> do
141− writeIORef reqBodyRef $ Done bs
142− return bs
143− Done bs -> do
144− writeIORef reqBodyRef $ Called bs
145− return B.empty
146−
147− ra request{ requestBody = memoReqBody } (routingRespond . routeResult)
148− where
149− routingRespond :: Either RouteMismatch Response -> IO ResponseReceived
150− routingRespond (Left NotFound) =
151− respond $ responseLBS notFound404 [] "not found"
152− routingRespond (Left WrongMethod) =
153− respond $ responseLBS methodNotAllowed405 [] "method not allowed"
154− routingRespond (Left (InvalidBody err)) =
155− respond $ responseLBS badRequest400 [] $ fromString $ "invalid request body: " ++ err
156− routingRespond (Left UnsupportedMediaType) =
157− respond $ responseLBS unsupportedMediaType415 [] "unsupported media type"
158− routingRespond (Left (HttpError status body)) =
159− respond $ responseLBS status [] $ fromMaybe (BL.fromStrict $ statusMessage status) body
160− routingRespond (Right response) =
161− respond response
162−
163−-- Note that the ordering of the constructors has great significance! It
164−-- determines the Ord instance and, consequently, the monoid instance.
165−-- * Route mismatch
166−data RouteMismatch =
167− NotFound -- ^ the usual "not found" error
168− | WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error
169− | UnsupportedMediaType -- ^ request body has unsupported media type
170− | InvalidBody String -- ^ an even more informative "your json request body wasn't valid" error
171− | HttpError Status (Maybe BL.ByteString) -- ^ an even even more informative arbitrary HTTP response code error.
172− deriving (Eq, Ord, Show)
173−
174−instance Monoid RouteMismatch where
175− mempty = NotFound
176− -- The following isn't great, since it picks @InvalidBody@ based on
177− -- alphabetical ordering, but any choice would be arbitrary.
178− --
179− -- "As one judge said to the other, 'Be just and if you can't be just, be
180− -- arbitrary'" -- William Burroughs
181− mappend = max
182−
183−
184−-- | A wrapper around @'Either' 'RouteMismatch' a@.
185−newtype RouteResult a =
186− RR { routeResult :: Either RouteMismatch a }
187− deriving (Eq, Show, Functor, Applicative)
188−
189−runAction :: IO (RouteResult (EitherT ServantErr IO a))
190− -> (RouteResult Response -> IO r)
191− -> (a -> RouteResult Response)
192− -> IO r
193−runAction action respond k = do
194− r <- action
195− go r
196− where
197− go (RR (Right a)) = do
198− e <- runEitherT a
199− respond $ case e of
200− Right x -> k x
201− Left err -> succeedWith $ responseServantErr err
202− go (RR (Left err)) = respond $ failWith err
203−
204−feedTo :: IO (RouteResult (a -> b)) -> a -> IO (RouteResult b)
205−feedTo f x = (($ x) <$>) <$> f
206−
207−extractL :: RouteResult (a :<|> b) -> RouteResult a
208−extractL (RR (Right (a :<|> _))) = RR (Right a)
209−extractL (RR (Left err)) = RR (Left err)
210−
211−extractR :: RouteResult (a :<|> b) -> RouteResult b
212−extractR (RR (Right (_ :<|> b))) = RR (Right b)
213−extractR (RR (Left err)) = RR (Left err)
214−
215−failWith :: RouteMismatch -> RouteResult a
216−failWith = RR . Left
217−
218−succeedWith :: a -> RouteResult a
219−succeedWith = RR . Right
220−
221−isMismatch :: RouteResult a -> Bool
222−isMismatch (RR (Left _)) = True
223−isMismatch _ = False
224−
225−-- | Like `null . pathInfo`, but works with redundant trailing slashes.
226−pathIsEmpty :: Request -> Bool
227−pathIsEmpty = f . processedPathInfo
228− where
229− f [] = True
230− f [""] = True
231− f _ = False
232−
233−-- | If we get a `Right`, it has precedence over everything else.
234−--
235−-- This in particular means that if we could get several 'Right's,
236−-- only the first we encounter would be taken into account.
237−instance Monoid (RouteResult a) where
238− mempty = RR $ Left mempty
239−
240− RR (Left x) `mappend` RR (Left y) = RR $ Left (x <> y)
241− RR (Left _) `mappend` RR (Right y) = RR $ Right y
242− r `mappend` _ = r
243−
244−type RoutingApplication =
245− Request -- ^ the request, the field 'pathInfo' may be modified by url routing
246− -> (RouteResult Response -> IO ResponseReceived) -> IO ResponseReceived
247−
248−splitMatrixParameters :: Text -> (Text, Text)
249−splitMatrixParameters = T.break (== ';')
250−
251−parsePathInfo :: Request -> [Text]
252−parsePathInfo = filter (/= "") . mergePairs . map splitMatrixParameters . pathInfo
253− where mergePairs = concat . unfoldr pairToList
254− pairToList [] = Nothing
255− pairToList ((a, b):xs) = Just ([a, b], xs)
256−
257−-- | Returns a processed pathInfo from the request.
258−--
259−-- In order to handle matrix parameters in the request correctly, the raw pathInfo needs to be
260−-- processed, so routing works as intended. Therefor this function should be used to access
261−-- the pathInfo for routing purposes.
262−processedPathInfo :: Request -> [Text]
263−processedPathInfo r =
264− case pinfo of
265− (x:xs) | T.head x == ';' -> xs
266− _ -> pinfo
267− where pinfo = parsePathInfo r
268−
26959class HasServer layout where
27060 type ServerT layout (m :: * -> *) :: *
27161