{-# LANGUAGE
FlexibleContexts
, Rank2Types
#-}
-- |
-- Module : Network.Wai.Trans
-- Copyright : (c) 2015, 2016, 2017, 2018 Athan Clark
-- License : BSD-style
-- Maintainer : athan.clark@gmail.com
-- Stability : experimental
-- Portability : GHC
--
-- Simple utilities for embedding a monad transformer stack in an 'Network.Wai.Application'
-- or 'Network.Wai.Middleware' - with 'MiddlewareT', your transformer stack is shared
-- across all attached middlewares until run. You can also lift existing 'Network.Wai.Middleware'
-- to 'MiddlewareT', given some extraction function.
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))
-- | Isomorphic to @Kleisli (ContT ResponseReceived m) Request Response@
type ApplicationT m = Request -> (Response -> m ResponseReceived) -> m ResponseReceived
type MiddlewareT m = ApplicationT m -> ApplicationT m
-- * Lift and Run
liftApplication :: MonadBaseControl IO m stM
=> Extractable stM
=> Application -- ^ To lift
-> ApplicationT m
liftApplication app req resp = liftBaseWith (\runInBase -> app req (\r -> runSingleton <$> runInBase (resp r)))
liftMiddleware :: MonadBaseControl IO m stM
=> Extractable stM
=> Middleware -- ^ To lift
-> 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 -- ^ To run
-> 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 -- ^ To run
-> m Middleware
runMiddlewareT mid = liftBaseWith $ \runInBase ->
pure $ \app req respond -> do
app' <- fmap runSingleton $ runInBase $ runApplicationT (mid (liftApplication app))
app' req respond
-- * Monad Morphisms
hoistApplicationT :: Monad m
=> Monad n
=> (forall a. m a -> n a) -- ^ To
-> (forall a. n a -> m a) -- ^ From
-> 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) -- ^ To
-> (forall a. n a -> m a) -- ^ From
-> MiddlewareT m
-> MiddlewareT n
hoistMiddlewareT to from mid =
hoistApplicationT to from . mid . hoistApplicationT from to
-- * Exception Catching
catchApplicationT :: MonadCatch m
=> Exception e
=> ApplicationT m
-> (e -> ApplicationT m) -- ^ Handler
-> 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) -- ^ Handler
-> MiddlewareT m
catchMiddlewareT x f app =
x app `catchApplicationT` (`f` app)