{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE TypeFamilies               #-}
module Servant.Server.Internal.DelayedIO where

import           Control.Monad.Base
                 (MonadBase (..))
import           Control.Monad.Catch
                 (MonadThrow (..))
import           Control.Monad.Reader
                 (MonadReader (..), ReaderT (..), runReaderT)
import           Control.Monad.Trans
                 (MonadIO (..), MonadTrans (..))
import           Control.Monad.Trans.Control
                 (MonadBaseControl (..))
import           Control.Monad.Trans.Resource
                 (MonadResource (..), ResourceT, runInternalState,
                 transResourceT, withInternalState)
import           Network.Wai
                 (Request)

import           Servant.Server.Internal.RouteResult
import           Servant.Server.Internal.ServerError

-- | Computations used in a 'Delayed' can depend on the
-- incoming 'Request', may perform 'IO', and result in a
-- 'RouteResult', meaning they can either succeed, fail
-- (with the possibility to recover), or fail fatally.
--
newtype DelayedIO a = DelayedIO { forall a.
DelayedIO a -> ReaderT Request (ResourceT (RouteResultT IO)) a
runDelayedIO' :: ReaderT Request (ResourceT (RouteResultT IO)) a }
  deriving newtype
    ( (forall a b. (a -> b) -> DelayedIO a -> DelayedIO b)
-> (forall a b. a -> DelayedIO b -> DelayedIO a)
-> Functor DelayedIO
forall a b. a -> DelayedIO b -> DelayedIO a
forall a b. (a -> b) -> DelayedIO a -> DelayedIO b
forall (f :: Type -> Type).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> DelayedIO a -> DelayedIO b
fmap :: forall a b. (a -> b) -> DelayedIO a -> DelayedIO b
$c<$ :: forall a b. a -> DelayedIO b -> DelayedIO a
<$ :: forall a b. a -> DelayedIO b -> DelayedIO a
Functor, Functor DelayedIO
Functor DelayedIO =>
(forall a. a -> DelayedIO a)
-> (forall a b. DelayedIO (a -> b) -> DelayedIO a -> DelayedIO b)
-> (forall a b c.
    (a -> b -> c) -> DelayedIO a -> DelayedIO b -> DelayedIO c)
-> (forall a b. DelayedIO a -> DelayedIO b -> DelayedIO b)
-> (forall a b. DelayedIO a -> DelayedIO b -> DelayedIO a)
-> Applicative DelayedIO
forall a. a -> DelayedIO a
forall a b. DelayedIO a -> DelayedIO b -> DelayedIO a
forall a b. DelayedIO a -> DelayedIO b -> DelayedIO b
forall a b. DelayedIO (a -> b) -> DelayedIO a -> DelayedIO b
forall a b c.
(a -> b -> c) -> DelayedIO a -> DelayedIO b -> DelayedIO c
forall (f :: Type -> Type).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> DelayedIO a
pure :: forall a. a -> DelayedIO a
$c<*> :: forall a b. DelayedIO (a -> b) -> DelayedIO a -> DelayedIO b
<*> :: forall a b. DelayedIO (a -> b) -> DelayedIO a -> DelayedIO b
$cliftA2 :: forall a b c.
(a -> b -> c) -> DelayedIO a -> DelayedIO b -> DelayedIO c
liftA2 :: forall a b c.
(a -> b -> c) -> DelayedIO a -> DelayedIO b -> DelayedIO c
$c*> :: forall a b. DelayedIO a -> DelayedIO b -> DelayedIO b
*> :: forall a b. DelayedIO a -> DelayedIO b -> DelayedIO b
$c<* :: forall a b. DelayedIO a -> DelayedIO b -> DelayedIO a
<* :: forall a b. DelayedIO a -> DelayedIO b -> DelayedIO a
Applicative, Applicative DelayedIO
Applicative DelayedIO =>
(forall a b. DelayedIO a -> (a -> DelayedIO b) -> DelayedIO b)
-> (forall a b. DelayedIO a -> DelayedIO b -> DelayedIO b)
-> (forall a. a -> DelayedIO a)
-> Monad DelayedIO
forall a. a -> DelayedIO a
forall a b. DelayedIO a -> DelayedIO b -> DelayedIO b
forall a b. DelayedIO a -> (a -> DelayedIO b) -> DelayedIO b
forall (m :: Type -> Type).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. DelayedIO a -> (a -> DelayedIO b) -> DelayedIO b
>>= :: forall a b. DelayedIO a -> (a -> DelayedIO b) -> DelayedIO b
$c>> :: forall a b. DelayedIO a -> DelayedIO b -> DelayedIO b
>> :: forall a b. DelayedIO a -> DelayedIO b -> DelayedIO b
$creturn :: forall a. a -> DelayedIO a
return :: forall a. a -> DelayedIO a
Monad
    , Monad DelayedIO
Monad DelayedIO =>
(forall a. IO a -> DelayedIO a) -> MonadIO DelayedIO
forall a. IO a -> DelayedIO a
forall (m :: Type -> Type).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall a. IO a -> DelayedIO a
liftIO :: forall a. IO a -> DelayedIO a
MonadIO, MonadReader Request
    , Monad DelayedIO
Monad DelayedIO =>
(forall e a. (HasCallStack, Exception e) => e -> DelayedIO a)
-> MonadThrow DelayedIO
forall e a. (HasCallStack, Exception e) => e -> DelayedIO a
forall (m :: Type -> Type).
Monad m =>
(forall e a. (HasCallStack, Exception e) => e -> m a)
-> MonadThrow m
$cthrowM :: forall e a. (HasCallStack, Exception e) => e -> DelayedIO a
throwM :: forall e a. (HasCallStack, Exception e) => e -> DelayedIO a
MonadThrow
    , MonadIO DelayedIO
MonadIO DelayedIO =>
(forall a. ResourceT IO a -> DelayedIO a)
-> MonadResource DelayedIO
forall a. ResourceT IO a -> DelayedIO a
forall (m :: Type -> Type).
MonadIO m =>
(forall a. ResourceT IO a -> m a) -> MonadResource m
$cliftResourceT :: forall a. ResourceT IO a -> DelayedIO a
liftResourceT :: forall a. ResourceT IO a -> DelayedIO a
MonadResource
    )

instance MonadBase IO DelayedIO where
    liftBase :: forall a. IO a -> DelayedIO a
liftBase = IO α -> DelayedIO α
forall a. IO a -> DelayedIO a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO

liftRouteResult :: RouteResult a -> DelayedIO a
liftRouteResult :: forall a. RouteResult a -> DelayedIO a
liftRouteResult RouteResult a
x = ReaderT Request (ResourceT (RouteResultT IO)) a -> DelayedIO a
forall a.
ReaderT Request (ResourceT (RouteResultT IO)) a -> DelayedIO a
DelayedIO (ReaderT Request (ResourceT (RouteResultT IO)) a -> DelayedIO a)
-> ReaderT Request (ResourceT (RouteResultT IO)) a -> DelayedIO a
forall a b. (a -> b) -> a -> b
$ ResourceT (RouteResultT IO) a
-> ReaderT Request (ResourceT (RouteResultT IO)) a
forall (m :: Type -> Type) a. Monad m => m a -> ReaderT Request m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ResourceT (RouteResultT IO) a
 -> ReaderT Request (ResourceT (RouteResultT IO)) a)
-> (RouteResultT IO a -> ResourceT (RouteResultT IO) a)
-> RouteResultT IO a
-> ReaderT Request (ResourceT (RouteResultT IO)) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RouteResultT IO a -> ResourceT (RouteResultT IO) a
forall (m :: Type -> Type) a. Monad m => m a -> ResourceT m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (RouteResultT IO a
 -> ReaderT Request (ResourceT (RouteResultT IO)) a)
-> RouteResultT IO a
-> ReaderT Request (ResourceT (RouteResultT IO)) a
forall a b. (a -> b) -> a -> b
$ IO (RouteResult a) -> RouteResultT IO a
forall (m :: Type -> Type) a. m (RouteResult a) -> RouteResultT m a
RouteResultT (IO (RouteResult a) -> RouteResultT IO a)
-> (RouteResult a -> IO (RouteResult a))
-> RouteResult a
-> RouteResultT IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RouteResult a -> IO (RouteResult a)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (RouteResult a -> RouteResultT IO a)
-> RouteResult a -> RouteResultT IO a
forall a b. (a -> b) -> a -> b
$ RouteResult a
x

instance MonadBaseControl IO DelayedIO where
    -- type StM DelayedIO a = StM (ReaderT Request (ResourceT (RouteResultT IO))) a
    -- liftBaseWith f = DelayedIO $ liftBaseWith $ \g -> f (g . runDelayedIO')
    -- restoreM       = DelayedIO . restoreM

    type StM DelayedIO a = RouteResult a
    liftBaseWith :: forall a. (RunInBase DelayedIO IO -> IO a) -> DelayedIO a
liftBaseWith RunInBase DelayedIO IO -> IO a
f = ReaderT Request (ResourceT (RouteResultT IO)) a -> DelayedIO a
forall a.
ReaderT Request (ResourceT (RouteResultT IO)) a -> DelayedIO a
DelayedIO (ReaderT Request (ResourceT (RouteResultT IO)) a -> DelayedIO a)
-> ReaderT Request (ResourceT (RouteResultT IO)) a -> DelayedIO a
forall a b. (a -> b) -> a -> b
$ (Request -> ResourceT (RouteResultT IO) a)
-> ReaderT Request (ResourceT (RouteResultT IO)) a
forall r (m :: Type -> Type) a. (r -> m a) -> ReaderT r m a
ReaderT ((Request -> ResourceT (RouteResultT IO) a)
 -> ReaderT Request (ResourceT (RouteResultT IO)) a)
-> (Request -> ResourceT (RouteResultT IO) a)
-> ReaderT Request (ResourceT (RouteResultT IO)) a
forall a b. (a -> b) -> a -> b
$ \Request
req -> (InternalState -> RouteResultT IO a)
-> ResourceT (RouteResultT IO) a
forall (m :: Type -> Type) a.
(InternalState -> m a) -> ResourceT m a
withInternalState ((InternalState -> RouteResultT IO a)
 -> ResourceT (RouteResultT IO) a)
-> (InternalState -> RouteResultT IO a)
-> ResourceT (RouteResultT IO) a
forall a b. (a -> b) -> a -> b
$ \InternalState
s ->
        (RunInBase (RouteResultT IO) IO -> IO a) -> RouteResultT IO a
forall a.
(RunInBase (RouteResultT IO) IO -> IO a) -> RouteResultT IO a
forall (b :: Type -> Type) (m :: Type -> Type) a.
MonadBaseControl b m =>
(RunInBase m b -> b a) -> m a
liftBaseWith ((RunInBase (RouteResultT IO) IO -> IO a) -> RouteResultT IO a)
-> (RunInBase (RouteResultT IO) IO -> IO a) -> RouteResultT IO a
forall a b. (a -> b) -> a -> b
$ \RunInBase (RouteResultT IO) IO
runInBase -> RunInBase DelayedIO IO -> IO a
f (RunInBase DelayedIO IO -> IO a) -> RunInBase DelayedIO IO -> IO a
forall a b. (a -> b) -> a -> b
$ \DelayedIO a
x ->
            RouteResultT IO a -> IO (StM (RouteResultT IO) a)
RunInBase (RouteResultT IO) IO
runInBase (ResourceT (RouteResultT IO) a -> InternalState -> RouteResultT IO a
forall (m :: Type -> Type) a. ResourceT m a -> InternalState -> m a
runInternalState (ReaderT Request (ResourceT (RouteResultT IO)) a
-> Request -> ResourceT (RouteResultT IO) a
forall r (m :: Type -> Type) a. ReaderT r m a -> r -> m a
runReaderT (DelayedIO a -> ReaderT Request (ResourceT (RouteResultT IO)) a
forall a.
DelayedIO a -> ReaderT Request (ResourceT (RouteResultT IO)) a
runDelayedIO' DelayedIO a
x) Request
req) InternalState
s)
    restoreM :: forall a. StM DelayedIO a -> DelayedIO a
restoreM      = ReaderT Request (ResourceT (RouteResultT IO)) a -> DelayedIO a
forall a.
ReaderT Request (ResourceT (RouteResultT IO)) a -> DelayedIO a
DelayedIO (ReaderT Request (ResourceT (RouteResultT IO)) a -> DelayedIO a)
-> (RouteResult a
    -> ReaderT Request (ResourceT (RouteResultT IO)) a)
-> RouteResult a
-> DelayedIO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResourceT (RouteResultT IO) a
-> ReaderT Request (ResourceT (RouteResultT IO)) a
forall (m :: Type -> Type) a. Monad m => m a -> ReaderT Request m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ResourceT (RouteResultT IO) a
 -> ReaderT Request (ResourceT (RouteResultT IO)) a)
-> (RouteResult a -> ResourceT (RouteResultT IO) a)
-> RouteResult a
-> ReaderT Request (ResourceT (RouteResultT IO)) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InternalState -> RouteResultT IO a)
-> ResourceT (RouteResultT IO) a
forall (m :: Type -> Type) a.
(InternalState -> m a) -> ResourceT m a
withInternalState ((InternalState -> RouteResultT IO a)
 -> ResourceT (RouteResultT IO) a)
-> (RouteResult a -> InternalState -> RouteResultT IO a)
-> RouteResult a
-> ResourceT (RouteResultT IO) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RouteResultT IO a -> InternalState -> RouteResultT IO a
forall a b. a -> b -> a
const (RouteResultT IO a -> InternalState -> RouteResultT IO a)
-> (RouteResult a -> RouteResultT IO a)
-> RouteResult a
-> InternalState
-> RouteResultT IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StM (RouteResultT IO) a -> RouteResultT IO a
RouteResult a -> RouteResultT IO a
forall a. StM (RouteResultT IO) a -> RouteResultT IO a
forall (b :: Type -> Type) (m :: Type -> Type) a.
MonadBaseControl b m =>
StM m a -> m a
restoreM


runDelayedIO :: DelayedIO a -> Request -> ResourceT IO (RouteResult a)
runDelayedIO :: forall a. DelayedIO a -> Request -> ResourceT IO (RouteResult a)
runDelayedIO DelayedIO a
m Request
req = (RouteResultT IO a -> IO (RouteResult a))
-> ResourceT (RouteResultT IO) a -> ResourceT IO (RouteResult a)
forall (m :: Type -> Type) a (n :: Type -> Type) b.
(m a -> n b) -> ResourceT m a -> ResourceT n b
transResourceT RouteResultT IO a -> IO (RouteResult a)
forall (m :: Type -> Type) a. RouteResultT m a -> m (RouteResult a)
runRouteResultT (ResourceT (RouteResultT IO) a -> ResourceT IO (RouteResult a))
-> ResourceT (RouteResultT IO) a -> ResourceT IO (RouteResult a)
forall a b. (a -> b) -> a -> b
$ ReaderT Request (ResourceT (RouteResultT IO)) a
-> Request -> ResourceT (RouteResultT IO) a
forall r (m :: Type -> Type) a. ReaderT r m a -> r -> m a
runReaderT (DelayedIO a -> ReaderT Request (ResourceT (RouteResultT IO)) a
forall a.
DelayedIO a -> ReaderT Request (ResourceT (RouteResultT IO)) a
runDelayedIO' DelayedIO a
m) Request
req

-- | Fail with the option to recover.
delayedFail :: ServerError -> DelayedIO a
delayedFail :: forall a. ServerError -> DelayedIO a
delayedFail ServerError
err = RouteResult a -> DelayedIO a
forall a. RouteResult a -> DelayedIO a
liftRouteResult (RouteResult a -> DelayedIO a) -> RouteResult a -> DelayedIO a
forall a b. (a -> b) -> a -> b
$ ServerError -> RouteResult a
forall a. ServerError -> RouteResult a
Fail ServerError
err

-- | Fail fatally, i.e., without any option to recover.
delayedFailFatal :: ServerError -> DelayedIO a
delayedFailFatal :: forall a. ServerError -> DelayedIO a
delayedFailFatal ServerError
err = RouteResult a -> DelayedIO a
forall a. RouteResult a -> DelayedIO a
liftRouteResult (RouteResult a -> DelayedIO a) -> RouteResult a -> DelayedIO a
forall a b. (a -> b) -> a -> b
$ ServerError -> RouteResult a
forall a. ServerError -> RouteResult a
FailFatal ServerError
err

-- | Gain access to the incoming request.
withRequest :: (Request -> DelayedIO a) -> DelayedIO a
withRequest :: forall a. (Request -> DelayedIO a) -> DelayedIO a
withRequest Request -> DelayedIO a
f = do
    Request
req <- DelayedIO Request
forall r (m :: Type -> Type). MonadReader r m => m r
ask
    Request -> DelayedIO a
f Request
req