module Network.Wai.Trans where
import Network.Wai (Application, Middleware, Request, Response, ResponseReceived)
import Data.Singleton.Class (Extractable (runSingleton))
import Control.Monad.Catch (Exception, MonadCatch (catch))
import Control.Monad.Trans.Control.Aligned (MonadBaseControl (liftBaseWith))
type ApplicationT m = Request -> (Response -> m ResponseReceived) -> m ResponseReceived
type MiddlewareT m = ApplicationT m -> ApplicationT m
liftApplication :: MonadBaseControl IO m stM
=> Extractable stM
=> Application
-> ApplicationT m
liftApplication app req resp = liftBaseWith (\runInBase -> app req (\r -> runSingleton <$> runInBase (resp r)))
liftMiddleware :: MonadBaseControl IO m stM
=> Extractable stM
=> Middleware
-> MiddlewareT m
liftMiddleware mid app req respond = do
app' <- runApplicationT app
liftBaseWith (\runInBase -> mid app' req (fmap runSingleton . runInBase . respond))
runApplicationT :: MonadBaseControl IO m stM
=> Extractable stM
=> ApplicationT m
-> m Application
runApplicationT app = liftBaseWith $ \runInBase ->
pure $ \req respond -> fmap runSingleton $ runInBase $ app req (\x -> liftBaseWith (\_ -> respond x))
runMiddlewareT :: MonadBaseControl IO m stM
=> Extractable stM
=> MiddlewareT m
-> m Middleware
runMiddlewareT mid = liftBaseWith $ \runInBase ->
pure $ \app req respond -> do
app' <- fmap runSingleton $ runInBase $ runApplicationT (mid (liftApplication app))
app' req respond
hoistApplicationT :: Monad m
=> Monad n
=> (forall a. m a -> n a)
-> (forall a. n a -> m a)
-> ApplicationT m
-> ApplicationT n
hoistApplicationT to from app req resp =
to $ app req (from . resp)
hoistMiddlewareT :: Monad m
=> Monad n
=> (forall a. m a -> n a)
-> (forall a. n a -> m a)
-> MiddlewareT m
-> MiddlewareT n
hoistMiddlewareT to from mid =
hoistApplicationT to from . mid . hoistApplicationT from to
catchApplicationT :: MonadCatch m
=> Exception e
=> ApplicationT m
-> (e -> ApplicationT m)
-> ApplicationT m
catchApplicationT x f req respond =
x req respond `catch` (\e -> f e req respond)
catchMiddlewareT :: MonadCatch m
=> Exception e
=> MiddlewareT m
-> (e -> MiddlewareT m)
-> MiddlewareT m
catchMiddlewareT x f app =
x app `catchApplicationT` (`f` app)