wai-middleware-verbs (empty) → 0.0.1
raw patch · 3 files changed
+225/−0 lines, 3 filesdep +basedep +bifunctorsdep +composition-extra
Dependencies added: base, bifunctors, composition-extra, containers, errors, http-types, mtl, transformers, wai, wai-transformers
Files
- LICENSE +30/−0
- src/Network/Wai/Middleware/Verbs.hs +164/−0
- wai-middleware-verbs.cabal +31/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Athan Clark++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Athan Clark nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ src/Network/Wai/Middleware/Verbs.hs view
@@ -0,0 +1,164 @@+{-# LANGUAGE+ GeneralizedNewtypeDeriving+ , ScopedTypeVariables+ , MultiParamTypeClasses+ , TupleSections+ #-}++module Network.Wai.Middleware.Verbs 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.Maybe (fromMaybe)+import Control.Monad.Trans+import Control.Monad.Trans.Maybe+import Control.Monad.Writer+import Control.Error.Util+++-- * Verb Map++newtype Verbs u m r = Verbs+ { unVerbs :: Map Verb (ResponseSpec u m r)+ } deriving (Monoid)++type Verb = StdMethod++getVerb :: Request -> Verb+getVerb req = fromMaybe GET $ httpMethodToMSym $ requestMethod req+ where+ httpMethodToMSym :: Method -> Maybe Verb+ httpMethodToMSym x | x == methodGet = Just GET+ | x == methodPost = Just POST+ | x == methodPut = Just PUT+ | x == methodDelete = Just DELETE+ | otherwise = Nothing++type HandleUpload m u = Request -> m (Maybe u)+type Respond u r = Request -> Maybe u -> r+type ResponseSpec u m r = (HandleUpload m u, Respond u r)+++supplyReq :: Request+ -> Map Verb (ResponseSpec u m r)+ -> Map Verb (m (Maybe u), Maybe u -> r)+supplyReq req xs = bimap ($ req) ($ req) <$> xs++instance Functor (Verbs u m) where+ fmap f (Verbs xs) = Verbs $ (second (f .*)) <$> xs+++-- | Take a verb map and a request, and return the lookup after providing the request+-- (for upload cases).+lookupVerb :: Verb -> Request -> Verbs u m r -> Maybe (m (Maybe u), Maybe u -> r)+lookupVerb v req vmap = Map.lookup v $ supplyReq req $ unVerbs vmap+++lookupVerbM :: Monad m => Verb -> Request -> Verbs u m r -> m (Maybe r)+lookupVerbM v req vmap = runMaybeT $ do+ (mUM, mUtoResult) <- hoistMaybe $ lookupVerb v req vmap+ mU <- lift mUM+ return $ mUtoResult mU+++-- * Verb Writer++newtype VerbListenerT r u m a =+ VerbListenerT { runVerbListenerT :: WriterT (Verbs u m r) m a }+ deriving ( Functor+ , Applicative+ , Monad+ , MonadWriter (Verbs u m r)+ , MonadIO+ )++execVerbListenerT :: Monad m => VerbListenerT r u m a -> m (Verbs u m r)+execVerbListenerT = execWriterT . runVerbListenerT+++instance MonadTrans (VerbListenerT r u) where+ lift ma = VerbListenerT $ lift ma++++verbsToMiddleware :: MonadIO m =>+ VerbListenerT (MiddlewareT m) u 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+++-- * Combinators++-- | For simple @GET@ responses+get :: ( Monad m+ ) => r -> VerbListenerT r u m ()+get r = tell $ Verbs $ Map.singleton GET ( const $ return Nothing+ , const $ const r+ )++-- | Inspect the @Request@ object supplied by WAI+getReq :: ( Monad m+ ) => (Request -> r) -> VerbListenerT r u m ()+getReq r = tell $ Verbs $ Map.singleton GET ( const $ return Nothing+ , const . r)+++-- | For simple @POST@ responses+post :: ( Monad m+ , MonadIO m+ ) => HandleUpload m u -> (Maybe u -> r) -> VerbListenerT r 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 m u -> (Request -> Maybe u -> r) -> VerbListenerT r u m ()+postReq handle r = tell $ Verbs $ Map.singleton POST ( handle+ , r+ )+++-- | For simple @PUT@ responses+put :: ( Monad m+ , MonadIO m+ ) => HandleUpload m u -> (Maybe u -> r) -> VerbListenerT r 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 m u -> (Request -> Maybe u -> r) -> VerbListenerT r u m ()+putReq handle r = tell $ Verbs $ Map.singleton PUT ( handle+ , r+ )+++-- | For simple @DELETE@ responses+delete :: ( Monad m+ ) => r -> VerbListenerT r u m ()+delete r = tell $ Verbs $ Map.singleton DELETE ( const $ return Nothing+ , const $ const r+ )++-- | Inspect the @Request@ object supplied by WAI+deleteReq :: ( Monad m+ ) => (Request -> r) -> VerbListenerT r u m ()+deleteReq r = tell $ Verbs $ Map.singleton DELETE ( const $ return Nothing+ , const . r+ )
+ wai-middleware-verbs.cabal view
@@ -0,0 +1,31 @@+Name: wai-middleware-verbs+Version: 0.0.1+Author: Athan Clark <athan.clark@gmail.com>+Maintainer: Athan Clark <athan.clark@gmail.com>+License: BSD3+License-File: LICENSE+Synopsis: Route different middleware responses based on the incoming HTTP verb.+-- Description:+Cabal-Version: >= 1.10+Build-Type: Simple+Category: Web++Library+ Default-Language: Haskell2010+ 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+ , containers+ , errors+ , http-types+ , mtl+ , transformers+ , wai+ , wai-transformers++Source-Repository head+ Type: git+ Location: https://github.com/athanclark/wai-middleware-verbs