{-# 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 { DelayedIO a -> ReaderT Request (ResourceT (RouteResultT IO)) a
runDelayedIO' :: ReaderT Request (ResourceT (RouteResultT IO)) a }
  deriving
    ( a -> DelayedIO b -> DelayedIO a
(a -> b) -> DelayedIO a -> DelayedIO b
(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 :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> DelayedIO b -> DelayedIO a
$c<$ :: forall a b. a -> DelayedIO b -> DelayedIO a
fmap :: (a -> b) -> DelayedIO a -> DelayedIO b
$cfmap :: forall a b. (a -> b) -> DelayedIO a -> DelayedIO b
Functor, Functor DelayedIO
a -> DelayedIO a
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
DelayedIO a -> DelayedIO b -> DelayedIO b
DelayedIO a -> DelayedIO b -> DelayedIO a
DelayedIO (a -> b) -> DelayedIO a -> DelayedIO b
(a -> b -> c) -> DelayedIO a -> DelayedIO b -> DelayedIO c
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 :: * -> *).
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
<* :: DelayedIO a -> DelayedIO b -> DelayedIO a
$c<* :: forall a b. DelayedIO a -> DelayedIO b -> DelayedIO a
*> :: DelayedIO a -> DelayedIO b -> DelayedIO b
$c*> :: forall a b. DelayedIO a -> DelayedIO b -> DelayedIO b
liftA2 :: (a -> b -> c) -> DelayedIO a -> DelayedIO b -> DelayedIO c
$cliftA2 :: forall a b c.
(a -> b -> c) -> DelayedIO a -> DelayedIO b -> DelayedIO c
<*> :: DelayedIO (a -> b) -> DelayedIO a -> DelayedIO b
$c<*> :: forall a b. DelayedIO (a -> b) -> DelayedIO a -> DelayedIO b
pure :: a -> DelayedIO a
$cpure :: forall a. a -> DelayedIO a
$cp1Applicative :: Functor DelayedIO
Applicative, Applicative DelayedIO
a -> DelayedIO a
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
DelayedIO a -> (a -> DelayedIO b) -> DelayedIO b
DelayedIO a -> DelayedIO b -> DelayedIO b
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 :: * -> *).
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
return :: a -> DelayedIO a
$creturn :: forall a. a -> DelayedIO a
>> :: DelayedIO a -> DelayedIO b -> DelayedIO b
$c>> :: forall a b. DelayedIO a -> DelayedIO b -> DelayedIO b
>>= :: DelayedIO a -> (a -> DelayedIO b) -> DelayedIO b
$c>>= :: forall a b. DelayedIO a -> (a -> DelayedIO b) -> DelayedIO b
$cp1Monad :: Applicative DelayedIO
Monad
    , Monad DelayedIO
Monad DelayedIO
-> (forall a. IO a -> DelayedIO a) -> MonadIO DelayedIO
IO a -> DelayedIO a
forall a. IO a -> DelayedIO a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> DelayedIO a
$cliftIO :: forall a. IO a -> DelayedIO a
$cp1MonadIO :: Monad DelayedIO
MonadIO, MonadReader Request
    , Monad DelayedIO
e -> DelayedIO a
Monad DelayedIO
-> (forall e a. Exception e => e -> DelayedIO a)
-> MonadThrow DelayedIO
forall e a. Exception e => e -> DelayedIO a
forall (m :: * -> *).
Monad m -> (forall e a. Exception e => e -> m a) -> MonadThrow m
throwM :: e -> DelayedIO a
$cthrowM :: forall e a. Exception e => e -> DelayedIO a
$cp1MonadThrow :: Monad DelayedIO
MonadThrow
    , MonadIO DelayedIO
MonadIO DelayedIO
-> (forall a. ResourceT IO a -> DelayedIO a)
-> MonadResource DelayedIO
ResourceT IO a -> DelayedIO a
forall a. ResourceT IO a -> DelayedIO a
forall (m :: * -> *).
MonadIO m -> (forall a. ResourceT IO a -> m a) -> MonadResource m
liftResourceT :: ResourceT IO a -> DelayedIO a
$cliftResourceT :: forall a. ResourceT IO a -> DelayedIO a
$cp1MonadResource :: MonadIO DelayedIO
MonadResource
    )

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

liftRouteResult :: RouteResult a -> DelayedIO a
liftRouteResult :: 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 (t :: (* -> *) -> * -> *) (m :: * -> *) 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 (t :: (* -> *) -> * -> *) (m :: * -> *) 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 :: * -> *) 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 (m :: * -> *) 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 :: (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 :: * -> *) 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 :: * -> *) 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 (b :: * -> *) (m :: * -> *) 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 :: * -> *) a. ResourceT m a -> InternalState -> m a
runInternalState (ReaderT Request (ResourceT (RouteResultT IO)) a
-> Request -> ResourceT (RouteResultT IO) a
forall r (m :: * -> *) 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 :: 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 (t :: (* -> *) -> * -> *) (m :: * -> *) 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 :: * -> *) 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
. RouteResult a -> RouteResultT IO a
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
StM m a -> m a
restoreM


runDelayedIO :: DelayedIO a -> Request -> ResourceT IO (RouteResult a)
runDelayedIO :: 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 :: * -> *) a (n :: * -> *) b.
(m a -> n b) -> ResourceT m a -> ResourceT n b
transResourceT RouteResultT IO a -> IO (RouteResult a)
forall (m :: * -> *) 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 :: * -> *) 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 :: 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 :: 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 :: (Request -> DelayedIO a) -> DelayedIO a
withRequest Request -> DelayedIO a
f = do
    Request
req <- DelayedIO Request
forall r (m :: * -> *). MonadReader r m => m r
ask
    Request -> DelayedIO a
f Request
req