{-# 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
    ( 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
<$ :: forall a b. a -> DelayedIO b -> DelayedIO a
$c<$ :: forall a b. a -> DelayedIO b -> DelayedIO a
fmap :: forall a b. (a -> b) -> DelayedIO a -> DelayedIO b
$cfmap :: forall a b. (a -> b) -> DelayedIO a -> DelayedIO b
Functor, Functor 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 :: * -> *).
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
<* :: forall a b. DelayedIO a -> DelayedIO b -> DelayedIO a
$c<* :: forall a b. DelayedIO a -> DelayedIO b -> DelayedIO a
*> :: forall a b. DelayedIO a -> DelayedIO b -> DelayedIO b
$c*> :: forall a b. DelayedIO a -> DelayedIO b -> DelayedIO b
liftA2 :: forall a b c.
(a -> b -> c) -> DelayedIO a -> DelayedIO b -> DelayedIO c
$cliftA2 :: forall a b c.
(a -> b -> c) -> DelayedIO a -> DelayedIO b -> DelayedIO c
<*> :: forall a b. DelayedIO (a -> b) -> DelayedIO a -> DelayedIO b
$c<*> :: forall a b. DelayedIO (a -> b) -> DelayedIO a -> DelayedIO b
pure :: forall a. a -> DelayedIO a
$cpure :: forall a. a -> DelayedIO a
Applicative, Applicative 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 :: * -> *).
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 :: forall a. a -> DelayedIO a
$creturn :: forall a. a -> DelayedIO a
>> :: forall a b. DelayedIO a -> DelayedIO b -> DelayedIO b
$c>> :: forall a b. DelayedIO a -> DelayedIO b -> DelayedIO b
>>= :: forall a b. DelayedIO a -> (a -> DelayedIO b) -> DelayedIO b
$c>>= :: forall a b. DelayedIO a -> (a -> DelayedIO b) -> DelayedIO b
Monad
    , Monad DelayedIO
forall a. IO a -> DelayedIO a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: forall a. IO a -> DelayedIO a
$cliftIO :: forall a. IO a -> DelayedIO a
MonadIO, MonadReader Request
    , Monad DelayedIO
forall e a. Exception e => e -> DelayedIO a
forall (m :: * -> *).
Monad m -> (forall e a. Exception e => e -> m a) -> MonadThrow m
throwM :: forall e a. Exception e => e -> DelayedIO a
$cthrowM :: forall e a. Exception e => e -> DelayedIO a
MonadThrow
    , MonadIO DelayedIO
forall a. ResourceT IO a -> DelayedIO a
forall (m :: * -> *).
MonadIO m -> (forall a. ResourceT IO a -> m a) -> MonadResource m
liftResourceT :: forall a. ResourceT IO a -> DelayedIO a
$cliftResourceT :: forall a. ResourceT IO a -> DelayedIO a
MonadResource
    )

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

liftRouteResult :: RouteResult a -> DelayedIO a
liftRouteResult :: forall a. RouteResult a -> DelayedIO a
liftRouteResult RouteResult a
x = forall a.
ReaderT Request (ResourceT (RouteResultT IO)) a -> DelayedIO a
DelayedIO forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. m (RouteResult a) -> RouteResultT m a
RouteResultT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return 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 = forall a.
ReaderT Request (ResourceT (RouteResultT IO)) a -> DelayedIO a
DelayedIO forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall a b. (a -> b) -> a -> b
$ \Request
req -> forall (m :: * -> *) a. (InternalState -> m a) -> ResourceT m a
withInternalState forall a b. (a -> b) -> a -> b
$ \InternalState
s ->
        forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
(RunInBase m b -> b a) -> m a
liftBaseWith forall a b. (a -> b) -> a -> b
$ \RunInBase (RouteResultT IO) IO
runInBase -> RunInBase DelayedIO IO -> IO a
f forall a b. (a -> b) -> a -> b
$ \DelayedIO a
x ->
            RunInBase (RouteResultT IO) IO
runInBase (forall (m :: * -> *) a. ResourceT m a -> InternalState -> m a
runInternalState (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (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      = forall a.
ReaderT Request (ResourceT (RouteResultT IO)) a -> DelayedIO a
DelayedIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. (InternalState -> m a) -> ResourceT m a
withInternalState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (b :: * -> *) (m :: * -> *) 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 = forall (m :: * -> *) a (n :: * -> *) b.
(m a -> n b) -> ResourceT m a -> ResourceT n b
transResourceT forall (m :: * -> *) a. RouteResultT m a -> m (RouteResult a)
runRouteResultT forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (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 = forall a. RouteResult a -> DelayedIO a
liftRouteResult forall a b. (a -> b) -> a -> b
$ 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 = forall a. RouteResult a -> DelayedIO a
liftRouteResult forall a b. (a -> b) -> a -> b
$ 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 <- forall r (m :: * -> *). MonadReader r m => m r
ask
    Request -> DelayedIO a
f Request
req