wai-middleware-verbs 0.0.5 → 0.1.0
raw patch · 3 files changed
+79/−133 lines, 3 filesdep +mmorphdep −bifunctorsdep −composition-extrasetup-changed
Dependencies added: mmorph
Dependencies removed: bifunctors, composition-extra
Files
- Setup.hs +2/−0
- src/Network/Wai/Middleware/Verbs.hs +74/−129
- wai-middleware-verbs.cabal +3/−4
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
src/Network/Wai/Middleware/Verbs.hs view
@@ -4,6 +4,7 @@ , StandaloneDeriving , ScopedTypeVariables , MultiParamTypeClasses+ , UndecidableInstances , GeneralizedNewtypeDeriving #-} @@ -15,50 +16,50 @@ Stability : experimental Portability : POSIX -This module provides everything you need to route based off different HTTP verbs.-The <#g:1 Combinators> section defines the @get@, @post@ and other functions you would-expect in a toolset like this. Likewise, we also include tools for manually-looking into the <#t:VerbListenerT VerbListenerT> object constructed from the combinators, and-turning it directly into a WAI @MiddlewareT@.+This module provides everything you need to respond depending on an HTTP verbs.+The <#g:1 Combinators> section defines the 'get', 'post' and other functions you would+expect in a toolset like this. The 'VerbListenerT' object is constructed from the+combinators, and turning it directly into a WAI 'Network.Wai.Trans.MiddlewareT'+is easy with 'verbsToMiddleware'.++> myApp :: MonadIO => MiddlewareT m+> myApp = verbsToMiddleware $ do+> get myMiddleware1+> put uploader myMiddleware2+> post uploader myMiddleware3+> delete myMiddleware4+> where+> uploader :: MonadIO m => Request -> m ()+> uploader req = liftIO $ print =<< getStrictRequestBody req -} module Network.Wai.Middleware.Verbs ( -- * Combinators get- , getReq , post- , postReq , put- , putReq , delete- , deleteReq , -- * Types- Verbs (..)+ VerbMap , Verb , getVerb- , ResponseSpec- , HandleUpload- , RespondUpload- , supplyReq , -- ** Monad Transformer VerbListenerT (..) , execVerbListenerT , verbsToMiddleware- , mapVerbs , -- * Utilities lookupVerb- , lookupVerbM+ , mapVerbs ) where import Network.Wai.Trans import Network.HTTP.Types -import Data.Function.Syntax-import Data.Bifunctor import Data.Map (Map) import qualified Data.Map as Map import Data.Monoid+import Control.Arrow (second) import Control.Applicative import Control.Monad.Trans import Control.Monad.Trans.Maybe@@ -77,24 +78,8 @@ -- * Types --- | Given a request, either throw a possibly existent error, or create some--- upload result.-type HandleUpload e m u = Request -> ExceptT (Maybe e) m u---- | Given a request and the potential result of handling an upload, return a--- response (usually @Middleware@).-type RespondUpload e u r = Request -> Either (Maybe e) u -> r--type ResponseSpec e u m r = (HandleUpload e m u, RespondUpload e u r)---- | A map from an HTTP verb, to a responding and uploading mechanism.-newtype Verbs e u m r = Verbs- { unVerbs :: Map Verb (ResponseSpec e u m r)- } deriving (Monoid)--instance Functor (Verbs e u m) where- fmap f (Verbs xs) = Verbs $ (second (f .*)) <$> xs-+-- | A map from an HTTP verb, to a result and uploading method.+type VerbMap m r = Map Verb (Request -> m (), r) type Verb = StdMethod @@ -109,138 +94,98 @@ | x == methodDelete = Just DELETE | otherwise = Nothing --- | @flip ($)@ for supplying a @Request@ into the two @ResponseSpec@ functions.-supplyReq :: Request- -> Map Verb (ResponseSpec e u m r)- -> Map Verb (ExceptT (Maybe e) m u, Either (Maybe e) u -> r)-supplyReq req xs = bimap ($ req) ($ req) <$> xs----- | Take a verb map and a request, and return the lookup after providing the request--- (for upload cases).-lookupVerb :: Verb- -> Request- -> Verbs e u m r- -> Maybe (ExceptT (Maybe e) m u, Either (Maybe e) u -> r)-lookupVerb v req vmap = Map.lookup v $ supplyReq req $ unVerbs vmap---- | Take the monadic partial result of @lookupVerb@, and actually handle the upload.-lookupVerbM :: Monad m => Verb -> Request -> Verbs e u m r -> m (Maybe r)-lookupVerbM v req vmap = runMaybeT $ do- (uploadT, result) <- hoistMaybe $ lookupVerb v req vmap- eUpload <- lift $ runExceptT uploadT- return $ result eUpload+-- | Take the monadic partial result of @lookupVerb@, and actually h the upload.+lookupVerb :: Monad m => Request -> Verb -> VerbMap m r -> m (Maybe r)+lookupVerb req v vmap = runMaybeT $ do+ (upload, result) <- hoistMaybe $ Map.lookup v vmap+ lift (upload req)+ return result -- * Verb Writer --- | The type variables are @r@ for the result, @e@ for the error type throwable--- during uploading, @u@ is the sucessful upload type, and @m@ and @a@ form the--- last two parts of the monad transformer.-newtype VerbListenerT r e u m a =- VerbListenerT { runVerbListenerT :: StateT (Verbs e u m r) m a }+-- | This is the monad for our DSL - where @r@ is the result type. We leave this+-- polymorphic for 'Web.Routes.Nested.ActionT' for <https://hackage.haskell.org/package/nested-routes nested-routes>.+--+-- > myListener :: MonadIO m => VerbListenerT (MiddlewareT m) m ()+-- > myListener = do+-- > get myMiddleware1+-- > post uploader myMiddleware2+-- > where+-- > uploader :: MonadIO Request -> m ()+-- > uploader req =+-- > liftIO $ print =<< strictRequestBody req+newtype VerbListenerT r m a =+ VerbListenerT { runVerbListenerT :: StateT (VerbMap m r) m a } deriving ( Functor, Applicative, Alternative, Monad, MonadFix, MonadPlus- , MonadState (Verbs e u m r), MonadWriter w, MonadReader r, MonadIO+ , MonadState (VerbMap m r), MonadWriter w, MonadReader r, MonadIO , MonadError e', MonadCont, MonadBase b, MonadThrow, MonadCatch , MonadMask, MonadLogger ) -deriving instance (MonadResource m, MonadBase IO m) => MonadResource (VerbListenerT r e u m)+deriving instance (MonadResource m, MonadBase IO m) => MonadResource (VerbListenerT r m) -execVerbListenerT :: Monad m => VerbListenerT r e u m a -> m (Verbs e u m r)+execVerbListenerT :: Monad m => VerbListenerT r m a -> m (VerbMap m r) execVerbListenerT xs = execStateT (runVerbListenerT xs) mempty -instance MonadTrans (VerbListenerT r e u) where- lift ma = VerbListenerT $ lift ma+instance MonadTrans (VerbListenerT r) where+ lift = VerbListenerT . lift -- uses StateT -- | Turn a map from HTTP verbs to middleware, into a middleware. verbsToMiddleware :: MonadIO m =>- VerbListenerT (MiddlewareT m) e u m ()+ VerbListenerT (MiddlewareT m) m () -> MiddlewareT m verbsToMiddleware vl app req respond = do let v = getVerb req vmap <- execVerbListenerT vl- mMiddleware <- lookupVerbM v req vmap- fromMaybe (app req respond) $ do- middleware <- mMiddleware- return $ middleware app req respond+ mMiddleware <- lookupVerb req v vmap+ fromMaybe (app req respond) $+ (\mid -> mid app req respond) <$> mMiddleware -mapVerbs :: Monad m =>- (a -> b)- -> VerbListenerT a e u m () -> VerbListenerT b e u m ()-mapVerbs f vl = do- vmap <- lift $ execVerbListenerT vl- tell' $ f <$> vmap -- * Combinators -- | For simple @GET@ responses get :: ( Monad m- ) => r -> VerbListenerT r e u m ()-get r = tell' $ Verbs $ Map.singleton GET ( const $ throwError Nothing- , const $ const r- )---- | Inspect the @Request@ object supplied by WAI-getReq :: ( Monad m- ) => (Request -> r) -> VerbListenerT r e u m ()-getReq r = tell' $ Verbs $ Map.singleton GET ( const $ throwError Nothing- , const . r- )-+ ) => r -> VerbListenerT r m ()+get r = tell' $ Map.singleton GET ( const $ return ()+ , r+ ) -- | For simple @POST@ responses post :: ( Monad m- , MonadIO m- ) => HandleUpload e m u -> (Either (Maybe e) u -> r) -> VerbListenerT r e u m ()-post handle r = tell' $ Verbs $ Map.singleton POST ( handle- , const r- )---- | Inspect the @Request@ object supplied by WAI-postReq :: ( Monad m- , MonadIO m- ) => HandleUpload e m u -> RespondUpload e u r -> VerbListenerT r e u m ()-postReq handle r = tell' $ Verbs $ Map.singleton POST ( handle- , r- )-+ ) => (Request -> m ()) -- Handle upload+ -> r+ -> VerbListenerT r m ()+post h r = tell' $ Map.singleton POST ( h+ , r+ ) -- | For simple @PUT@ responses put :: ( Monad m- , MonadIO m- ) => HandleUpload e m u -> (Either (Maybe e) u -> r) -> VerbListenerT r e u m ()-put handle r = tell' $ Verbs $ Map.singleton PUT ( handle- , const r- )---- | Inspect the @Request@ object supplied by WAI-putReq :: ( Monad m- , MonadIO m- ) => HandleUpload e m u -> RespondUpload e u r -> VerbListenerT r e u m ()-putReq handle r = tell' $ Verbs $ Map.singleton PUT ( handle- , r- )-+ ) => (Request -> m ()) -- Handle upload+ -> r+ -> VerbListenerT r m ()+put h r = tell' $ Map.singleton PUT ( h+ , r+ ) -- | For simple @DELETE@ responses delete :: ( Monad m- ) => r -> VerbListenerT r e u m ()-delete r = tell' $ Verbs $ Map.singleton DELETE ( const $ throwError Nothing- , const $ const r- )---- | Inspect the @Request@ object supplied by WAI-deleteReq :: ( Monad m- ) => (Request -> r) -> VerbListenerT r e u m ()-deleteReq r = tell' $ Verbs $ Map.singleton DELETE ( const $ throwError Nothing- , const . r- )+ ) => r -> VerbListenerT r m ()+delete r = tell' $ Map.singleton DELETE ( const $ return ()+ , r+ ) tell' :: (Monoid w, MonadState w m) => w -> m () tell' x = do xs <- S.get S.put $ xs <> x++mapVerbs :: Monad m => (r -> s) -> VerbListenerT r m () -> VerbListenerT s m ()+mapVerbs f xs = do+ vmap <- lift $ execVerbListenerT xs+ tell' $ second f <$> vmap
wai-middleware-verbs.cabal view
@@ -1,5 +1,5 @@ Name: wai-middleware-verbs-Version: 0.0.5+Version: 0.1.0 Author: Athan Clark <athan.clark@gmail.com> Maintainer: Athan Clark <athan.clark@gmail.com> License: BSD3@@ -15,14 +15,13 @@ HS-Source-Dirs: src GHC-Options: -Wall Exposed-Modules: Network.Wai.Middleware.Verbs- Build-Depends: base >= 4.6 && < 5- , bifunctors- , composition-extra >= 2.0.0+ Build-Depends: base >= 4.8 && < 5 , containers , exceptions , errors , http-types , monad-logger+ , mmorph , mtl , resourcet , transformers