From eb86a821059d9f6827972afe5155614b411d5138 Mon Sep 17 00:00:00 2001 From: Andres Loeh Date: Mon, 1 Jun 2015 19:38:51 +0200 Subject: [PATCH] Refactoring: one module per concept. The main `Server.Internal` module was getting a bit large for my taste. It now contains just the instances. All the administrative utilities are in their own dedicated modules. --- servant-server/servant-server.cabal | 5 +- servant-server/src/Servant/Server.hs | 1 - servant-server/src/Servant/Server/Internal.hs | 240 ++---------------- .../src/Servant/Server/Internal/PathInfo.hs | 38 +++ .../src/Servant/Server/Internal/Router.hs | 72 ++++++ .../Server/Internal/RoutingApplication.hs | 145 +++++++++++ servant-server/test/Servant/ServerSpec.hs | 3 +- 7 files changed, 276 insertions(+), 228 deletions(-) create mode 100644 servant-server/src/Servant/Server/Internal/PathInfo.hs create mode 100644 servant-server/src/Servant/Server/Internal/Router.hs create mode 100644 servant-server/src/Servant/Server/Internal/RoutingApplication.hs diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index bfb12f9b..00e5193f 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -35,8 +35,11 @@ library Servant Servant.Server Servant.Server.Internal - Servant.Server.Internal.ServantErr Servant.Server.Internal.Enter + Servant.Server.Internal.PathInfo + Servant.Server.Internal.Router + Servant.Server.Internal.RoutingApplication + Servant.Server.Internal.ServantErr Servant.Utils.StaticFiles build-depends: base >= 4.7 && < 5 diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index 8f60583a..fcf02f1a 100644 --- a/servant-server/src/Servant/Server.hs +++ b/servant-server/src/Servant/Server.hs @@ -81,7 +81,6 @@ import Data.Proxy (Proxy) import Network.Wai (Application) import Servant.Server.Internal import Servant.Server.Internal.Enter -import Servant.Server.Internal.ServantErr -- * Implementing Servers diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 069aab78..5d0f4025 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -12,17 +12,19 @@ {-# LANGUAGE OverlappingInstances #-} #endif -module Servant.Server.Internal where +module Servant.Server.Internal + ( module Servant.Server.Internal + , module Servant.Server.Internal.PathInfo + , module Servant.Server.Internal.Router + , module Servant.Server.Internal.RoutingApplication + , module Servant.Server.Internal.ServantErr + ) where #if !MIN_VERSION_base(4,8,0) -import Control.Applicative (Applicative, (<$>)) -import Data.Monoid (Monoid, mappend, mempty) +import Control.Applicative ((<$>)) #endif -import Control.Monad.Trans.Either (EitherT, runEitherT) +import Control.Monad.Trans.Either (EitherT) import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import Data.IORef (newIORef, readIORef, writeIORef) -import Data.List (unfoldr) import qualified Data.Map as M import Data.Maybe (catMaybes, fromMaybe) import Data.String (fromString) @@ -33,12 +35,9 @@ import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Typeable import GHC.TypeLits (KnownSymbol, symbolVal) import Network.HTTP.Types hiding (Header, ResponseHeaders) -import Network.Wai (Application, Request, Response, - ResponseReceived, lazyRequestBody, - pathInfo, rawQueryString, - requestBody, requestHeaders, - requestMethod, responseLBS, - strictRequestBody) +import Network.Wai (Application, lazyRequestBody, + rawQueryString, requestHeaders, + requestMethod, responseLBS) import Servant.API ((:<|>) (..), (:>), Capture, Delete, Get, Header, MatrixFlag, MatrixParam, MatrixParams, @@ -52,220 +51,11 @@ import Servant.API.ResponseHeaders (Headers, getResponse, GetHeaders, getHeaders) import Servant.Common.Text (FromText, fromText) +import Servant.Server.Internal.PathInfo +import Servant.Server.Internal.Router +import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.ServantErr --- | Internal representation of a router. -data Router = - WithRequest (Request -> Router) - -- ^ current request is passed to the router - | StaticRouter (M.Map Text Router) - -- ^ first path component used for lookup and removed afterwards - | DynamicRouter (Text -> Router) - -- ^ first path component used for lookup and removed afterwards - | LeafRouter RoutingApplication - -- ^ to be used for routes that match an empty path - | Choice Router Router - -- ^ left-biased choice between two routers - --- | Smart constructor for the choice between routers. --- We currently optimize the following cases: --- --- * Two static routers can be joined by joining their maps. --- * Two dynamic routers can be joined by joining their codomains. --- * Two 'WithRequest' routers can be joined by passing them --- the same request and joining their codomains. --- * A 'WithRequest' router can be joined with anything else by --- passing the same request to both but ignoring it in the --- component that does not need it. --- -choice :: Router -> Router -> Router -choice (StaticRouter table1) (StaticRouter table2) = - StaticRouter (M.unionWith choice table1 table2) -choice (DynamicRouter fun1) (DynamicRouter fun2) = - DynamicRouter (\ first -> choice (fun1 first) (fun2 first)) -choice (WithRequest router1) (WithRequest router2) = - WithRequest (\ request -> choice (router1 request) (router2 request)) -choice (WithRequest router1) router2 = - WithRequest (\ request -> choice (router1 request) router2) -choice router1 (WithRequest router2) = - WithRequest (\ request -> choice router1 (router2 request)) -choice router1 router2 = Choice router1 router2 - --- | Interpret a router as an application. -runRouter :: Router -> RoutingApplication -runRouter (WithRequest router) request respond = - runRouter (router request) request respond -runRouter (StaticRouter table) request respond = - case processedPathInfo request of - first : rest - | Just router <- M.lookup first table - -> let request' = request { pathInfo = rest } - in runRouter router request' respond - _ -> respond $ failWith NotFound -runRouter (DynamicRouter fun) request respond = - case processedPathInfo request of - first : rest - -> let request' = request { pathInfo = rest } - in runRouter (fun first) request' respond - _ -> respond $ failWith NotFound -runRouter (LeafRouter app) request respond = app request respond -runRouter (Choice r1 r2) request respond = - runRouter r1 request $ \ mResponse1 -> - if isMismatch mResponse1 - then runRouter r2 request $ \ mResponse2 -> - respond (mResponse1 <> mResponse2) - else respond mResponse1 - -data ReqBodyState = Uncalled - | Called !B.ByteString - | Done !B.ByteString - - -toApplication :: RoutingApplication -> Application -toApplication ra request respond = do - reqBodyRef <- newIORef Uncalled - -- We may need to consume the requestBody more than once. In order to - -- maintain the illusion that 'requestBody' works as expected, - -- 'ReqBodyState' is introduced, and the complete body is memoized and - -- returned as many times as requested with empty "Done" marker chunks in - -- between. - -- See https://github.com/haskell-servant/servant/issues/3 - let memoReqBody = do - ior <- readIORef reqBodyRef - case ior of - Uncalled -> do - r <- BL.toStrict <$> strictRequestBody request - writeIORef reqBodyRef $ Done r - return r - Called bs -> do - writeIORef reqBodyRef $ Done bs - return bs - Done bs -> do - writeIORef reqBodyRef $ Called bs - return B.empty - - ra request{ requestBody = memoReqBody } (routingRespond . routeResult) - where - routingRespond :: Either RouteMismatch Response -> IO ResponseReceived - routingRespond (Left NotFound) = - respond $ responseLBS notFound404 [] "not found" - routingRespond (Left WrongMethod) = - respond $ responseLBS methodNotAllowed405 [] "method not allowed" - routingRespond (Left (InvalidBody err)) = - respond $ responseLBS badRequest400 [] $ fromString $ "invalid request body: " ++ err - routingRespond (Left UnsupportedMediaType) = - respond $ responseLBS unsupportedMediaType415 [] "unsupported media type" - routingRespond (Left (HttpError status body)) = - respond $ responseLBS status [] $ fromMaybe (BL.fromStrict $ statusMessage status) body - routingRespond (Right response) = - respond response - --- Note that the ordering of the constructors has great significance! It --- determines the Ord instance and, consequently, the monoid instance. --- * Route mismatch -data RouteMismatch = - NotFound -- ^ the usual "not found" error - | WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error - | UnsupportedMediaType -- ^ request body has unsupported media type - | InvalidBody String -- ^ an even more informative "your json request body wasn't valid" error - | HttpError Status (Maybe BL.ByteString) -- ^ an even even more informative arbitrary HTTP response code error. - deriving (Eq, Ord, Show) - -instance Monoid RouteMismatch where - mempty = NotFound - -- The following isn't great, since it picks @InvalidBody@ based on - -- alphabetical ordering, but any choice would be arbitrary. - -- - -- "As one judge said to the other, 'Be just and if you can't be just, be - -- arbitrary'" -- William Burroughs - mappend = max - - --- | A wrapper around @'Either' 'RouteMismatch' a@. -newtype RouteResult a = - RR { routeResult :: Either RouteMismatch a } - deriving (Eq, Show, Functor, Applicative) - -runAction :: IO (RouteResult (EitherT ServantErr IO a)) - -> (RouteResult Response -> IO r) - -> (a -> RouteResult Response) - -> IO r -runAction action respond k = do - r <- action - go r - where - go (RR (Right a)) = do - e <- runEitherT a - respond $ case e of - Right x -> k x - Left err -> succeedWith $ responseServantErr err - go (RR (Left err)) = respond $ failWith err - -feedTo :: IO (RouteResult (a -> b)) -> a -> IO (RouteResult b) -feedTo f x = (($ x) <$>) <$> f - -extractL :: RouteResult (a :<|> b) -> RouteResult a -extractL (RR (Right (a :<|> _))) = RR (Right a) -extractL (RR (Left err)) = RR (Left err) - -extractR :: RouteResult (a :<|> b) -> RouteResult b -extractR (RR (Right (_ :<|> b))) = RR (Right b) -extractR (RR (Left err)) = RR (Left err) - -failWith :: RouteMismatch -> RouteResult a -failWith = RR . Left - -succeedWith :: a -> RouteResult a -succeedWith = RR . Right - -isMismatch :: RouteResult a -> Bool -isMismatch (RR (Left _)) = True -isMismatch _ = False - --- | Like `null . pathInfo`, but works with redundant trailing slashes. -pathIsEmpty :: Request -> Bool -pathIsEmpty = f . processedPathInfo - where - f [] = True - f [""] = True - f _ = False - --- | If we get a `Right`, it has precedence over everything else. --- --- This in particular means that if we could get several 'Right's, --- only the first we encounter would be taken into account. -instance Monoid (RouteResult a) where - mempty = RR $ Left mempty - - RR (Left x) `mappend` RR (Left y) = RR $ Left (x <> y) - RR (Left _) `mappend` RR (Right y) = RR $ Right y - r `mappend` _ = r - -type RoutingApplication = - Request -- ^ the request, the field 'pathInfo' may be modified by url routing - -> (RouteResult Response -> IO ResponseReceived) -> IO ResponseReceived - -splitMatrixParameters :: Text -> (Text, Text) -splitMatrixParameters = T.break (== ';') - -parsePathInfo :: Request -> [Text] -parsePathInfo = filter (/= "") . mergePairs . map splitMatrixParameters . pathInfo - where mergePairs = concat . unfoldr pairToList - pairToList [] = Nothing - pairToList ((a, b):xs) = Just ([a, b], xs) - --- | Returns a processed pathInfo from the request. --- --- In order to handle matrix parameters in the request correctly, the raw pathInfo needs to be --- processed, so routing works as intended. Therefor this function should be used to access --- the pathInfo for routing purposes. -processedPathInfo :: Request -> [Text] -processedPathInfo r = - case pinfo of - (x:xs) | T.head x == ';' -> xs - _ -> pinfo - where pinfo = parsePathInfo r - class HasServer layout where type ServerT layout (m :: * -> *) :: * diff --git a/servant-server/src/Servant/Server/Internal/PathInfo.hs b/servant-server/src/Servant/Server/Internal/PathInfo.hs new file mode 100644 index 00000000..0138f72e --- /dev/null +++ b/servant-server/src/Servant/Server/Internal/PathInfo.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE OverloadedStrings #-} +module Servant.Server.Internal.PathInfo where + +import Data.List (unfoldr) +import Data.Text (Text) +import qualified Data.Text as T +import Network.Wai (Request, pathInfo) + +-- | Like `null . pathInfo`, but works with redundant trailing slashes. +pathIsEmpty :: Request -> Bool +pathIsEmpty = f . processedPathInfo + where + f [] = True + f [""] = True + f _ = False + + +splitMatrixParameters :: Text -> (Text, Text) +splitMatrixParameters = T.break (== ';') + +parsePathInfo :: Request -> [Text] +parsePathInfo = filter (/= "") . mergePairs . map splitMatrixParameters . pathInfo + where mergePairs = concat . unfoldr pairToList + pairToList [] = Nothing + pairToList ((a, b):xs) = Just ([a, b], xs) + +-- | Returns a processed pathInfo from the request. +-- +-- In order to handle matrix parameters in the request correctly, the raw pathInfo needs to be +-- processed, so routing works as intended. Therefor this function should be used to access +-- the pathInfo for routing purposes. +processedPathInfo :: Request -> [Text] +processedPathInfo r = + case pinfo of + (x:xs) | T.head x == ';' -> xs + _ -> pinfo + where pinfo = parsePathInfo r + diff --git a/servant-server/src/Servant/Server/Internal/Router.hs b/servant-server/src/Servant/Server/Internal/Router.hs new file mode 100644 index 00000000..2e0188e4 --- /dev/null +++ b/servant-server/src/Servant/Server/Internal/Router.hs @@ -0,0 +1,72 @@ +module Servant.Server.Internal.Router where + +import Data.Map (Map) +import qualified Data.Map as M +import Data.Monoid ((<>)) +import Data.Text (Text) +import Network.Wai (Request, pathInfo) +import Servant.Server.Internal.PathInfo +import Servant.Server.Internal.RoutingApplication + +-- | Internal representation of a router. +data Router = + WithRequest (Request -> Router) + -- ^ current request is passed to the router + | StaticRouter (Map Text Router) + -- ^ first path component used for lookup and removed afterwards + | DynamicRouter (Text -> Router) + -- ^ first path component used for lookup and removed afterwards + | LeafRouter RoutingApplication + -- ^ to be used for routes that match an empty path + | Choice Router Router + -- ^ left-biased choice between two routers + +-- | Smart constructor for the choice between routers. +-- We currently optimize the following cases: +-- +-- * Two static routers can be joined by joining their maps. +-- * Two dynamic routers can be joined by joining their codomains. +-- * Two 'WithRequest' routers can be joined by passing them +-- the same request and joining their codomains. +-- * A 'WithRequest' router can be joined with anything else by +-- passing the same request to both but ignoring it in the +-- component that does not need it. +-- +choice :: Router -> Router -> Router +choice (StaticRouter table1) (StaticRouter table2) = + StaticRouter (M.unionWith choice table1 table2) +choice (DynamicRouter fun1) (DynamicRouter fun2) = + DynamicRouter (\ first -> choice (fun1 first) (fun2 first)) +choice (WithRequest router1) (WithRequest router2) = + WithRequest (\ request -> choice (router1 request) (router2 request)) +choice (WithRequest router1) router2 = + WithRequest (\ request -> choice (router1 request) router2) +choice router1 (WithRequest router2) = + WithRequest (\ request -> choice router1 (router2 request)) +choice router1 router2 = Choice router1 router2 + +-- | Interpret a router as an application. +runRouter :: Router -> RoutingApplication +runRouter (WithRequest router) request respond = + runRouter (router request) request respond +runRouter (StaticRouter table) request respond = + case processedPathInfo request of + first : rest + | Just router <- M.lookup first table + -> let request' = request { pathInfo = rest } + in runRouter router request' respond + _ -> respond $ failWith NotFound +runRouter (DynamicRouter fun) request respond = + case processedPathInfo request of + first : rest + -> let request' = request { pathInfo = rest } + in runRouter (fun first) request' respond + _ -> respond $ failWith NotFound +runRouter (LeafRouter app) request respond = app request respond +runRouter (Choice r1 r2) request respond = + runRouter r1 request $ \ mResponse1 -> + if isMismatch mResponse1 + then runRouter r2 request $ \ mResponse2 -> + respond (mResponse1 <> mResponse2) + else respond mResponse1 + diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs new file mode 100644 index 00000000..2f2355fe --- /dev/null +++ b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +module Servant.Server.Internal.RoutingApplication where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative (Applicative, (<$>)) +import Data.Monoid (Monoid, mappend, mempty) +#endif +import Control.Monad.Trans.Either (EitherT, runEitherT) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import Data.IORef (newIORef, readIORef, writeIORef) +import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) +import Data.String (fromString) +import Network.HTTP.Types hiding (Header, ResponseHeaders) +import Network.Wai (Application, Request, Response, + ResponseReceived, + requestBody, + responseLBS, + strictRequestBody) +import Servant.API ((:<|>) (..)) +import Servant.Server.Internal.ServantErr + +type RoutingApplication = + Request -- ^ the request, the field 'pathInfo' may be modified by url routing + -> (RouteResult Response -> IO ResponseReceived) -> IO ResponseReceived + +-- | A wrapper around @'Either' 'RouteMismatch' a@. +newtype RouteResult a = + RR { routeResult :: Either RouteMismatch a } + deriving (Eq, Show, Functor, Applicative) + +-- | If we get a `Right`, it has precedence over everything else. +-- +-- This in particular means that if we could get several 'Right's, +-- only the first we encounter would be taken into account. +instance Monoid (RouteResult a) where + mempty = RR $ Left mempty + + RR (Left x) `mappend` RR (Left y) = RR $ Left (x <> y) + RR (Left _) `mappend` RR (Right y) = RR $ Right y + r `mappend` _ = r + +-- Note that the ordering of the constructors has great significance! It +-- determines the Ord instance and, consequently, the monoid instance. +-- * Route mismatch +data RouteMismatch = + NotFound -- ^ the usual "not found" error + | WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error + | UnsupportedMediaType -- ^ request body has unsupported media type + | InvalidBody String -- ^ an even more informative "your json request body wasn't valid" error + | HttpError Status (Maybe BL.ByteString) -- ^ an even even more informative arbitrary HTTP response code error. + deriving (Eq, Ord, Show) + +instance Monoid RouteMismatch where + mempty = NotFound + -- The following isn't great, since it picks @InvalidBody@ based on + -- alphabetical ordering, but any choice would be arbitrary. + -- + -- "As one judge said to the other, 'Be just and if you can't be just, be + -- arbitrary'" -- William Burroughs + mappend = max + +data ReqBodyState = Uncalled + | Called !B.ByteString + | Done !B.ByteString + +toApplication :: RoutingApplication -> Application +toApplication ra request respond = do + reqBodyRef <- newIORef Uncalled + -- We may need to consume the requestBody more than once. In order to + -- maintain the illusion that 'requestBody' works as expected, + -- 'ReqBodyState' is introduced, and the complete body is memoized and + -- returned as many times as requested with empty "Done" marker chunks in + -- between. + -- See https://github.com/haskell-servant/servant/issues/3 + let memoReqBody = do + ior <- readIORef reqBodyRef + case ior of + Uncalled -> do + r <- BL.toStrict <$> strictRequestBody request + writeIORef reqBodyRef $ Done r + return r + Called bs -> do + writeIORef reqBodyRef $ Done bs + return bs + Done bs -> do + writeIORef reqBodyRef $ Called bs + return B.empty + + ra request{ requestBody = memoReqBody } (routingRespond . routeResult) + where + routingRespond :: Either RouteMismatch Response -> IO ResponseReceived + routingRespond (Left NotFound) = + respond $ responseLBS notFound404 [] "not found" + routingRespond (Left WrongMethod) = + respond $ responseLBS methodNotAllowed405 [] "method not allowed" + routingRespond (Left (InvalidBody err)) = + respond $ responseLBS badRequest400 [] $ fromString $ "invalid request body: " ++ err + routingRespond (Left UnsupportedMediaType) = + respond $ responseLBS unsupportedMediaType415 [] "unsupported media type" + routingRespond (Left (HttpError status body)) = + respond $ responseLBS status [] $ fromMaybe (BL.fromStrict $ statusMessage status) body + routingRespond (Right response) = + respond response + +runAction :: IO (RouteResult (EitherT ServantErr IO a)) + -> (RouteResult Response -> IO r) + -> (a -> RouteResult Response) + -> IO r +runAction action respond k = do + r <- action + go r + where + go (RR (Right a)) = do + e <- runEitherT a + respond $ case e of + Right x -> k x + Left err -> succeedWith $ responseServantErr err + go (RR (Left err)) = respond $ failWith err + +feedTo :: IO (RouteResult (a -> b)) -> a -> IO (RouteResult b) +feedTo f x = (($ x) <$>) <$> f + +extractL :: RouteResult (a :<|> b) -> RouteResult a +extractL (RR (Right (a :<|> _))) = RR (Right a) +extractL (RR (Left err)) = RR (Left err) + +extractR :: RouteResult (a :<|> b) -> RouteResult b +extractR (RR (Right (_ :<|> b))) = RR (Right b) +extractR (RR (Left err)) = RR (Left err) + +failWith :: RouteMismatch -> RouteResult a +failWith = RR . Left + +succeedWith :: a -> RouteResult a +succeedWith = RR . Right + +isMismatch :: RouteResult a -> Bool +isMismatch (RR (Left _)) = True +isMismatch _ = False + diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index ca604ae7..00087d93 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -42,7 +42,8 @@ import Servant.API ((:<|>) (..), (:>), Post, Put, QueryFlag, QueryParam, QueryParams, Raw, ReqBody) import Servant.Server (Server, serve, ServantErr(..), err404) -import Servant.Server.Internal (RouteMismatch (..)) +import Servant.Server.Internal.RoutingApplication + (RouteMismatch (..)) -- * test data types