eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Refactoring: one module per concept.

Browse source 
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.
This commit is contained in:
Andres Loeh 2015-06-01 19:38:51 +02:00
parent e83397a1db
commit eb86a82105
7 changed files with 276 additions and 228 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5
servant-server/servant-server.cabal
View file

@ -35,8 +35,11 @@ library
Servant Servant
Servant.Server Servant.Server
Servant.Server.Internal Servant.Server.Internal
Servant.Server.Internal.ServantErr
Servant.Server.Internal.Enter Servant.Server.Internal.Enter
Servant.Server.Internal.PathInfo
Servant.Server.Internal.Router
Servant.Server.Internal.RoutingApplication
Servant.Server.Internal.ServantErr
Servant.Utils.StaticFiles Servant.Utils.StaticFiles
build-depends: build-depends:
base >= 4.7 && < 5 base >= 4.7 && < 5

1
servant-server/src/Servant/Server.hs
View file

@ -81,7 +81,6 @@ import Data.Proxy (Proxy)
import Network.Wai (Application) import Network.Wai (Application)
import Servant.Server.Internal import Servant.Server.Internal
import Servant.Server.Internal.Enter import Servant.Server.Internal.Enter
import Servant.Server.Internal.ServantErr
-- * Implementing Servers -- * Implementing Servers

240
servant-server/src/Servant/Server/Internal.hs
View file

@ -12,17 +12,19 @@
{-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE OverlappingInstances #-}
#endif #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) #if !MIN_VERSION_base(4,8,0)
import Control.Applicative (Applicative, (<$>)) import Control.Applicative ((<$>))
import Data.Monoid (Monoid, mappend, mempty)
#endif #endif
import Control.Monad.Trans.Either (EitherT, runEitherT) import Control.Monad.Trans.Either (EitherT)
import qualified Data.ByteString as B 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 qualified Data.Map as M
import Data.Maybe (catMaybes, fromMaybe) import Data.Maybe (catMaybes, fromMaybe)
import Data.String (fromString) import Data.String (fromString)
@ -33,12 +35,9 @@ import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Data.Typeable import Data.Typeable
import GHC.TypeLits (KnownSymbol, symbolVal) import GHC.TypeLits (KnownSymbol, symbolVal)
import Network.HTTP.Types hiding (Header, ResponseHeaders) import Network.HTTP.Types hiding (Header, ResponseHeaders)
import Network.Wai (Application, Request, Response, import Network.Wai (Application, lazyRequestBody,
ResponseReceived, lazyRequestBody, rawQueryString, requestHeaders,
pathInfo, rawQueryString, requestMethod, responseLBS)
requestBody, requestHeaders,
requestMethod, responseLBS,
strictRequestBody)
import Servant.API ((:<|>) (..), (:>), Capture, import Servant.API ((:<|>) (..), (:>), Capture,
Delete, Get, Header, Delete, Get, Header,
MatrixFlag, MatrixParam, MatrixParams, MatrixFlag, MatrixParam, MatrixParams,
@ -52,220 +51,11 @@ import Servant.API.ResponseHeaders (Headers, getResponse, GetHeaders,
getHeaders) getHeaders)
import Servant.Common.Text (FromText, fromText) 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 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 class HasServer layout where
type ServerT layout (m :: * -> *) :: * type ServerT layout (m :: * -> *) :: *

38
servant-server/src/Servant/Server/Internal/PathInfo.hs Normal file
View file

@ -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

72
servant-server/src/Servant/Server/Internal/Router.hs Normal file
View file

@ -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

145
servant-server/src/Servant/Server/Internal/RoutingApplication.hs Normal file
View file

@ -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

3
servant-server/test/Servant/ServerSpec.hs
View file

@ -42,7 +42,8 @@ import Servant.API ((:<|>) (..), (:>),
Post, Put, QueryFlag, QueryParam, Post, Put, QueryFlag, QueryParam,
QueryParams, Raw, ReqBody) QueryParams, Raw, ReqBody)
import Servant.Server (Server, serve, ServantErr(..), err404) import Servant.Server (Server, serve, ServantErr(..), err404)
import Servant.Server.Internal (RouteMismatch (..)) import Servant.Server.Internal.RoutingApplication
(RouteMismatch (..))
-- * test data types -- * test data types