wai-transformers 0.0.7 → 0.1.0

raw patch · 4 files changed

+226/−139 lines, 4 filesdep +extractable-singletondep +monad-control-aligneddep ~waidep ~websocketsPVP ok

version bump matches the API change (PVP)

Dependencies added: extractable-singleton, monad-control-aligned

Dependency ranges changed: wai, websockets

API changes (from Hackage documentation)

Files

• README.md +52/−0
• src/Network/Wai/Trans.hs +63/−114
• src/Network/WebSockets/Trans.hs +68/−0
• wai-transformers.cabal +43/−25

@@ -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+```

@@ -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)

@@ -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

@@ -1,27 +1,45 @@-Name:                   wai-transformers-Version:                0.0.7-Author:                 Athan Clark <athan.clark@gmail.com>-Maintainer:             Athan Clark <athan.clark@gmail.com>-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 <https://git.localcooking.com/tooling/wai-transformers#readme>+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