diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,52 @@ +wai-transformers +================ + +Simple parameterization of Wai's `Application` and `Middleware` types. + + +## Overview + +Wai's `Application` type is defined as follows: + +```haskell +type Application = Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived +``` + +This is great for the server - we can just `flip ($)` the middlewares together to get +an effectful server. However, what if we want to encode useful information in our +middleware chain / end-point application? Something like a `ReaderT Env` environment, +where useful data like a universal salt, current hostname, or global mutable references can +be referenced later if it were wedged-in. + +The design looks like this: + +```haskell +type ApplicationT m = Request -> (Response -> IO ResponseReceived) -> m ResponseReceived +``` + +Now we can encode MTL-style contexts with applications we write + +```haskell +type MiddlewareT m = ApplicationT m -> ApplicationT m + + +data AuthConfig = AuthConfig + { authFunction :: Request -> Either AuthException (Response -> Response) + } + +simpleAuth :: ( MonadReader AuthConfig m + , MonadError AuthException m + ) => MiddlewareT m +simpleAuth app req resp = do + auth <- authFunction <$> ask + case auth req of + Left e = throwError e + Right f = app req (resp . f) + +simpleAuth' :: Middleware +simpleAuth' app req resp = + eReceived <- runExceptT $ runReaderT (simpleAuth app req resp) myAuthConfig + case eReceived of + Left e = resp $ respondLBS "Unauthorized!" + Right r = return r +``` diff --git a/src/Network/Wai/Trans.hs b/src/Network/Wai/Trans.hs --- a/src/Network/Wai/Trans.hs +++ b/src/Network/Wai/Trans.hs @@ -1,152 +1,101 @@ {-# LANGUAGE FlexibleContexts - , OverloadedStrings , Rank2Types #-} -- | -- Module : Network.Wai.Trans --- Copyright : (c) 2015 Athan Clark +-- 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 @Application@ --- or @Middleware@ - with @MiddlewareT@, your transformer stack is shared --- across all attached middlewares until run. You can also lift existing @Middleware@ --- to @MiddlewareT@, given some extraction function. +-- 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 - ( -- * WAI - -- ** Types - module Network.Wai - , ApplicationT - , MiddlewareT - , -- ** Embedding - liftApplication - , liftMiddleware - , runApplicationT - , runMiddlewareT - , hoistApplicationT - , hoistMiddlewareT - , inApplicationT - , inMiddlewareT - , -- ** Exception catching - catchApplicationT - , catchMiddlewareT - , -- ** General Purpose - readingRequest - , -- * Websockets - ServerAppT - , liftServerApp - , runServerAppT - , ClientAppT - , liftClientApp - , runClientAppT - , websocketsOrT - ) where - +module Network.Wai.Trans where -import Network.Wai -import Network.Wai.Handler.WebSockets -import Network.WebSockets hiding (Request, Response) +import Network.Wai (Application, Middleware, Request, Response, ResponseReceived) -import Control.Monad.IO.Class -import Control.Monad.Catch +import Data.Singleton.Class (Extractable (runSingleton)) +import Control.Monad.Catch (Exception, MonadCatch (catch)) +import Control.Monad.Trans.Control.Aligned (MonadBaseControl (liftBaseWith)) --- * WAI - -- | Isomorphic to @Kleisli (ContT ResponseReceived m) Request Response@ type ApplicationT m = Request -> (Response -> m ResponseReceived) -> m ResponseReceived type MiddlewareT m = ApplicationT m -> ApplicationT m --- ** Generalization - -liftApplication :: MonadIO m => (forall a. m a -> IO a) -> Application -> ApplicationT m -liftApplication run app req resp = liftIO (app req (run . resp)) - -liftMiddleware :: MonadIO m => (forall a. m a -> IO a) -> Middleware -> MiddlewareT m -liftMiddleware run mid app = liftApplication run (mid (runApplicationT run app)) +-- * Lift and Run -runApplicationT :: MonadIO m => (forall a. m a -> IO a) -> ApplicationT m -> Application -runApplicationT run app req respond = run (app req (liftIO . respond)) +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))) -runMiddlewareT :: MonadIO m => (forall a. m a -> IO a) -> MiddlewareT m -> Middleware -runMiddlewareT run mid app = runApplicationT run (mid (liftApplication run app)) +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)) -inApplicationT :: Monad m => m a -> ApplicationT m -> ApplicationT m -inApplicationT x app req resp = x >> app req resp +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)) -inMiddlewareT :: Monad m => m a -> MiddlewareT m -> MiddlewareT m -inMiddlewareT x mid = mid . inApplicationT 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 +-- * Monad Morphisms -hoistApplicationT :: ( Monad m - , Monad n - ) => (forall a. m a -> n a) - -> (forall a. n a -> m a) - -> ApplicationT m - -> ApplicationT n +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) - -> (forall a. n a -> m a) - -> MiddlewareT m - -> MiddlewareT n +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 +-- * Exception Catching -catchApplicationT :: ( MonadCatch m - , Exception e - ) => ApplicationT m -> (e -> ApplicationT m) -> ApplicationT m +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) + x req respond `catch` (\e -> f e req respond) -catchMiddlewareT :: ( MonadCatch m - , Exception e - ) => MiddlewareT m -> (e -> MiddlewareT m) -> MiddlewareT m +catchMiddlewareT :: MonadCatch m + => Exception e + => MiddlewareT m + -> (e -> MiddlewareT m) -- ^ Handler + -> MiddlewareT m catchMiddlewareT x f app = - (x app) `catchApplicationT` (\e -> f e app) - --- ** Utils - -readingRequest :: Monad m => (Request -> m ()) -> MiddlewareT m -readingRequest f app req resp = do - f req - app req resp - - --- * Websockets - -type ServerAppT m = PendingConnection -> m () - -liftServerApp :: (MonadIO m) => ServerApp -> ServerAppT m -liftServerApp s = liftIO . s - -runServerAppT :: (forall a. m a -> IO a) -> ServerAppT m -> ServerApp -runServerAppT run s = run . s - -type ClientAppT m a = Connection -> m a - -liftClientApp :: (MonadIO m) => ClientApp a -> ClientAppT m a -liftClientApp c = liftIO . c - -runClientAppT :: (forall a. m a -> IO a) -> ClientAppT m a -> ClientApp a -runClientAppT run c = run . c - - --- | Respond with the WebSocket server when applicable, as a middleware -websocketsOrT :: (MonadIO m) => (forall a. m a -> IO a) -> ConnectionOptions -> ServerAppT m -> MiddlewareT m -websocketsOrT run cOpts server app req respond = - let server' pend = run $ server pend - app' = liftApplication run . websocketsOr cOpts server' $ runApplicationT run app - in app' req respond + x app `catchApplicationT` (`f` app) diff --git a/src/Network/WebSockets/Trans.hs b/src/Network/WebSockets/Trans.hs new file mode 100644 --- /dev/null +++ b/src/Network/WebSockets/Trans.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE + FlexibleContexts + #-} + +-- | +-- 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.WebSockets.ClientApp' +-- or 'Network.WebSockets.ServerApp'. + +module Network.WebSockets.Trans where + +import Network.WebSockets (ConnectionOptions, ClientApp, ServerApp, Connection, PendingConnection) +import Network.Wai.Handler.WebSockets (websocketsOr) +import Network.Wai.Trans (MiddlewareT, runApplicationT, liftApplication) +import Data.Singleton.Class (Extractable (runSingleton)) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Trans.Control.Aligned (MonadBaseControl (liftBaseWith)) + + +-- * Websockets + +type ServerAppT m = PendingConnection -> m () + +liftServerApp :: MonadIO m + => ServerApp -- ^ To lift + -> ServerAppT m +liftServerApp s = liftIO . s + +runServerAppT :: MonadBaseControl IO m stM + => Extractable stM + => ServerAppT m -- ^ To run + -> m ServerApp +runServerAppT s = liftBaseWith $ \runInBase -> + pure $ \pending -> runSingleton <$> runInBase (s pending) + +type ClientAppT m a = Connection -> m a + +liftClientApp :: MonadIO m + => ClientApp a -- ^ To lift + -> ClientAppT m a +liftClientApp c = liftIO . c + +runClientAppT :: MonadBaseControl IO m stM + => Extractable stM + => ClientAppT m a -- ^ To run + -> m (ClientApp a) +runClientAppT c = liftBaseWith $ \runInBase -> + pure $ \conn -> runSingleton <$> runInBase (c conn) + + +-- * WAI Compatability + +-- | Respond with the WebSocket server when applicable, as a middleware +websocketsOrT :: MonadBaseControl IO m stM + => Extractable stM + => ConnectionOptions + -> ServerAppT m -- ^ Server + -> MiddlewareT m +websocketsOrT cOpts server app req respond = do + server' <- runServerAppT server + app' <- runApplicationT app + liftApplication (websocketsOr cOpts server' app') req respond diff --git a/wai-transformers.cabal b/wai-transformers.cabal --- a/wai-transformers.cabal +++ b/wai-transformers.cabal @@ -1,27 +1,45 @@ -Name: wai-transformers -Version: 0.0.7 -Author: Athan Clark -Maintainer: Athan Clark -License: BSD3 -License-File: LICENSE -Synopsis: Simple parameterization of Wai's Application type --- Description: -Cabal-Version: >= 1.10 -Build-Type: Simple -Category: Web +-- This file has been generated from package.yaml by hpack version 0.21.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 8e306e52f1f366b2119966770b3cebf95cf4d551b833e42765a246aa7acf78df -Library - Default-Language: Haskell2010 - HS-Source-Dirs: src - GHC-Options: -Wall - Exposed-Modules: Network.Wai.Trans - Build-Depends: base >= 4.8 && < 5 - , exceptions - , wai - , wai-websockets - , transformers - , websockets +name: wai-transformers +version: 0.1.0 +description: Please see the README on Github at +homepage: https://github.com/athanclark/wai-transformers#readme +bug-reports: https://github.com/athanclark/wai-transformers/issues +author: Athan Clark +maintainer: athan.clark@localcooking.com +copyright: 2018 Athan Clark +license: BSD3 +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 -Source-Repository head - Type: git - Location: https://github.com/athanclark/wai-transformers.git +extra-source-files: + README.md + +source-repository head + type: git + location: https://github.com/athanclark/wai-transformers + +library + exposed-modules: + Network.Wai.Trans + Network.WebSockets.Trans + other-modules: + Paths_wai_transformers + hs-source-dirs: + src + ghc-options: -Wall + build-depends: + base >=4.8 && <5 + , exceptions + , extractable-singleton >=0.0.1 + , monad-control-aligned >=0.0.1 + , transformers + , wai >=3.2.1 + , wai-websockets + , websockets >=0.12.4 + default-language: Haskell2010