2015-06-01 19:38:51 +02:00
|
|
|
{-# LANGUAGE CPP #-}
|
2015-09-10 08:49:19 +02:00
|
|
|
{-# LANGUAGE DeriveFunctor #-}
|
2015-06-01 19:38:51 +02:00
|
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
{-# LANGUAGE TypeOperators #-}
|
|
|
|
module Servant.Server.Internal.RoutingApplication where
|
|
|
|
|
|
|
|
#if !MIN_VERSION_base(4,8,0)
|
2015-08-17 23:56:29 +02:00
|
|
|
import Control.Applicative (Applicative, (<$>))
|
2015-09-10 08:49:19 +02:00
|
|
|
import Data.Monoid (Monoid, mappend, mempty,
|
|
|
|
(<>))
|
2015-06-01 19:38:51 +02:00
|
|
|
#endif
|
2015-09-12 14:11:24 +02:00
|
|
|
import Control.Monad.Trans.Except (ExceptT, runExceptT)
|
2015-08-17 23:56:29 +02:00
|
|
|
import qualified Data.ByteString as B
|
|
|
|
import qualified Data.ByteString.Lazy as BL
|
|
|
|
import Data.IORef (newIORef, readIORef,
|
|
|
|
writeIORef)
|
|
|
|
import Network.Wai (Application, Request,
|
|
|
|
Response, ResponseReceived,
|
2015-09-10 08:49:19 +02:00
|
|
|
requestBody,
|
2015-08-17 23:56:29 +02:00
|
|
|
strictRequestBody)
|
|
|
|
import Servant.API ((:<|>) (..))
|
2015-06-01 19:38:51 +02:00
|
|
|
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@.
|
2015-09-10 08:49:19 +02:00
|
|
|
data RouteResult a =
|
|
|
|
Retriable ServantErr -- ^ Keep trying other paths. The @ServantErr@
|
|
|
|
-- should only be 404 or 405.
|
|
|
|
| NonRetriable ServantErr -- ^ Stop trying.
|
|
|
|
| HandlerVal a
|
|
|
|
deriving (Eq, Show, Read, Functor)
|
2015-06-01 19:38:51 +02:00
|
|
|
|
|
|
|
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
|
|
|
|
|
2015-09-10 08:49:19 +02:00
|
|
|
ra request{ requestBody = memoReqBody } routingRespond
|
2015-06-01 19:38:51 +02:00
|
|
|
where
|
2015-09-10 08:49:19 +02:00
|
|
|
routingRespond :: RouteResult Response -> IO ResponseReceived
|
|
|
|
routingRespond (Retriable err) = respond $! responseServantErr err
|
|
|
|
routingRespond (NonRetriable err) = respond $! responseServantErr err
|
|
|
|
routingRespond (HandlerVal v) = respond v
|
2015-06-01 19:38:51 +02:00
|
|
|
|
2015-09-12 14:11:24 +02:00
|
|
|
runAction :: IO (RouteResult (ExceptT ServantErr IO a))
|
2015-06-01 19:38:51 +02:00
|
|
|
-> (RouteResult Response -> IO r)
|
|
|
|
-> (a -> RouteResult Response)
|
|
|
|
-> IO r
|
2015-09-10 08:49:19 +02:00
|
|
|
runAction action respond k = action >>= go >>= respond
|
2015-06-01 19:38:51 +02:00
|
|
|
where
|
2015-09-10 08:49:19 +02:00
|
|
|
go (Retriable e) = return $! Retriable e
|
|
|
|
go (NonRetriable e) = return . succeedWith $! responseServantErr e
|
|
|
|
go (HandlerVal a) = do
|
2015-09-12 14:11:24 +02:00
|
|
|
e <- runExceptT a
|
2015-09-10 08:49:19 +02:00
|
|
|
case e of
|
|
|
|
Left err -> return . succeedWith $! responseServantErr err
|
|
|
|
Right x -> return $! k x
|
2015-06-01 19:38:51 +02:00
|
|
|
|
|
|
|
feedTo :: IO (RouteResult (a -> b)) -> a -> IO (RouteResult b)
|
|
|
|
feedTo f x = (($ x) <$>) <$> f
|
|
|
|
|
|
|
|
extractL :: RouteResult (a :<|> b) -> RouteResult a
|
2015-09-10 08:49:19 +02:00
|
|
|
extractL (HandlerVal (a :<|> _)) = HandlerVal a
|
|
|
|
extractL (Retriable x) = Retriable x
|
|
|
|
extractL (NonRetriable x) = NonRetriable x
|
2015-06-01 19:38:51 +02:00
|
|
|
|
|
|
|
extractR :: RouteResult (a :<|> b) -> RouteResult b
|
2015-09-10 08:49:19 +02:00
|
|
|
extractR (HandlerVal (_ :<|> b)) = HandlerVal b
|
|
|
|
extractR (Retriable x) = Retriable x
|
|
|
|
extractR (NonRetriable x) = NonRetriable x
|
|
|
|
|
|
|
|
-- | Fail with a @ServantErr@, but keep trying other paths and.
|
|
|
|
failWith :: ServantErr -> RouteResult a
|
|
|
|
failWith = Retriable
|
2015-06-01 19:38:51 +02:00
|
|
|
|
2015-09-10 08:49:19 +02:00
|
|
|
-- | Fail with immediately @ServantErr@.
|
|
|
|
failFatallyWith :: ServantErr -> RouteResult a
|
|
|
|
failFatallyWith = NonRetriable
|
2015-06-01 19:38:51 +02:00
|
|
|
|
2015-09-10 08:49:19 +02:00
|
|
|
-- | Return a value, and don't try other paths.
|
2015-06-01 19:38:51 +02:00
|
|
|
succeedWith :: a -> RouteResult a
|
2015-09-10 08:49:19 +02:00
|
|
|
succeedWith = HandlerVal
|
2015-06-01 19:38:51 +02:00
|
|
|
|
|
|
|
isMismatch :: RouteResult a -> Bool
|
2015-09-10 08:49:19 +02:00
|
|
|
isMismatch (Retriable _) = True
|
2015-06-01 19:38:51 +02:00
|
|
|
isMismatch _ = False
|