{-# LANGUAGE FlexibleContexts #-}

module Network.Wai.Trans (

  -- * Application
  ApplicationT
, liftApplication
, runApplicationT

  -- * Middleware
, MiddlewareT
, liftMiddleware
, runMiddlewareT

) where

import Control.Monad.IO.Unlift
import Network.Wai

-- | A type synonym for a wai 'Application' which has been lifted from the 'IO' monad.
type ApplicationT m = Request -> (Response -> m ResponseReceived) -> m ResponseReceived

-- | Lift a wai 'Application' to an 'ApplicationT'.
liftApplication :: MonadUnliftIO m
                => Application
                -> ApplicationT m
liftApplication :: Application -> ApplicationT m
liftApplication Application
app Request
request Response -> m ResponseReceived
respond = ((forall a. m a -> IO a) -> IO ResponseReceived)
-> m ResponseReceived
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO ResponseReceived)
 -> m ResponseReceived)
-> ((forall a. m a -> IO a) -> IO ResponseReceived)
-> m ResponseReceived
forall a b. (a -> b) -> a -> b
$ \ forall a. m a -> IO a
runInIO ->
  Application
app Request
request ((Response -> IO ResponseReceived) -> IO ResponseReceived)
-> (Response -> IO ResponseReceived) -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ m ResponseReceived -> IO ResponseReceived
forall a. m a -> IO a
runInIO (m ResponseReceived -> IO ResponseReceived)
-> (Response -> m ResponseReceived)
-> Response
-> IO ResponseReceived
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> m ResponseReceived
respond

-- | Run an 'ApplicationT' in the inner monad.
runApplicationT :: MonadUnliftIO m
                => ApplicationT m
                -> m Application
runApplicationT :: ApplicationT m -> m Application
runApplicationT ApplicationT m
appT = ((forall a. m a -> IO a) -> IO Application) -> m Application
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO Application) -> m Application)
-> ((forall a. m a -> IO a) -> IO Application) -> m Application
forall a b. (a -> b) -> a -> b
$ \ forall a. m a -> IO a
runInIO ->
  Application -> IO Application
forall (m :: * -> *) a. Monad m => a -> m a
return (Application -> IO Application) -> Application -> IO Application
forall a b. (a -> b) -> a -> b
$ \ Request
request Response -> IO ResponseReceived
respond -> m ResponseReceived -> IO ResponseReceived
forall a. m a -> IO a
runInIO (m ResponseReceived -> IO ResponseReceived)
-> m ResponseReceived -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ ApplicationT m
appT Request
request ((Response -> m ResponseReceived) -> m ResponseReceived)
-> (Response -> m ResponseReceived) -> m ResponseReceived
forall a b. (a -> b) -> a -> b
$ IO ResponseReceived -> m ResponseReceived
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ResponseReceived -> m ResponseReceived)
-> (Response -> IO ResponseReceived)
-> Response
-> m ResponseReceived
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> IO ResponseReceived
respond

-- | A type synonym for a wai 'Middleware' which has been lifted from the 'IO' monad.
type MiddlewareT m = ApplicationT m -> ApplicationT m

-- | Lift a wai 'Middleware' to a 'MiddlewareT'.
liftMiddleware :: MonadUnliftIO m
               => Middleware
               -> MiddlewareT m
liftMiddleware :: Middleware -> MiddlewareT m
liftMiddleware Middleware
mid ApplicationT m
appT Request
request Response -> m ResponseReceived
respond = do
  Application
app <- ApplicationT m -> m Application
forall (m :: * -> *).
MonadUnliftIO m =>
ApplicationT m -> m Application
runApplicationT ApplicationT m
appT
  ((forall a. m a -> IO a) -> IO ResponseReceived)
-> m ResponseReceived
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO ResponseReceived)
 -> m ResponseReceived)
-> ((forall a. m a -> IO a) -> IO ResponseReceived)
-> m ResponseReceived
forall a b. (a -> b) -> a -> b
$ \ forall a. m a -> IO a
runInIO -> Middleware
mid Application
app Request
request ((Response -> IO ResponseReceived) -> IO ResponseReceived)
-> (Response -> IO ResponseReceived) -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ m ResponseReceived -> IO ResponseReceived
forall a. m a -> IO a
runInIO (m ResponseReceived -> IO ResponseReceived)
-> (Response -> m ResponseReceived)
-> Response
-> IO ResponseReceived
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> m ResponseReceived
respond

-- | Run a 'MiddlewareT' in the inner monad.
runMiddlewareT :: MonadUnliftIO m
               => MiddlewareT m
               -> m Middleware
runMiddlewareT :: MiddlewareT m -> m Middleware
runMiddlewareT MiddlewareT m
midT = ((forall a. m a -> IO a) -> IO Middleware) -> m Middleware
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO Middleware) -> m Middleware)
-> ((forall a. m a -> IO a) -> IO Middleware) -> m Middleware
forall a b. (a -> b) -> a -> b
$ \ forall a. m a -> IO a
runInIO ->
  Middleware -> IO Middleware
forall (m :: * -> *) a. Monad m => a -> m a
return (Middleware -> IO Middleware) -> Middleware -> IO Middleware
forall a b. (a -> b) -> a -> b
$ \ Application
app Request
request Response -> IO ResponseReceived
respond -> do
    Application
app' <- m Application -> IO Application
forall a. m a -> IO a
runInIO (m Application -> IO Application)
-> (ApplicationT m -> m Application)
-> ApplicationT m
-> IO Application
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ApplicationT m -> m Application
forall (m :: * -> *).
MonadUnliftIO m =>
ApplicationT m -> m Application
runApplicationT (ApplicationT m -> m Application)
-> MiddlewareT m -> ApplicationT m -> m Application
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MiddlewareT m
midT (ApplicationT m -> IO Application)
-> ApplicationT m -> IO Application
forall a b. (a -> b) -> a -> b
$ Application -> ApplicationT m
forall (m :: * -> *).
MonadUnliftIO m =>
Application -> ApplicationT m
liftApplication Application
app
    Application
app' Request
request Response -> IO ResponseReceived
respond