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.
This commit is contained in:
Andres Loeh
parent
e83397a1db
commit
eb86a82105
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 :: * -> *) :: *
|
||||
|
||||
|
|
|
|||
38
servant-server/src/Servant/Server/Internal/PathInfo.hs
Normal file
38
servant-server/src/Servant/Server/Internal/PathInfo.hs
Normal 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
72
servant-server/src/Servant/Server/Internal/Router.hs
Normal 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
145
servant-server/src/Servant/Server/Internal/RoutingApplication.hs
Normal 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
|
||||
|
||||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user