wai-middleware-verbs 0.3.2.1 → 0.4.0

raw patch · 3 files changed

+47/−33 lines, 3 filesdep +bytestringdep +wai-transformers

Dependencies added: bytestring, wai-transformers

Files

README.md +4/−7
src/Network/Wai/Middleware/Verbs.hs +39/−24
wai-middleware-verbs.cabal +4/−2

README.md view

@@ -19,16 +19,13 @@ myMid1 :: MiddlewareT (ReaderT Env m) myMid2 :: Middleware -uploader :: Request -> m (Maybe u)-uploader _ = return Nothing--uploadResponse :: Maybe u -> MiddlewareT m-uploadResponse _ = liftMiddleware (\t -> runReaderT t config) myMid2+uploadResponse :: ByteString -> MiddlewareT m+uploadResponse _ = liftMiddleware myMid2 -verbRoutes :: VerbListenerT (MiddlewareT m) u m ()+verbRoutes :: VerbListenerT (MiddlewareT m) m () verbRoutes = do   get myMid1-  post uploader uploadResponse+  post uploadResponse ```  Then, to use your newly assembled verb-router, turn the Verbs into a Middleware:

src/Network/Wai/Middleware/Verbs.hs view

@@ -1,6 +1,5 @@ {-# LANGUAGE-    TupleSections-  , FlexibleContexts+    FlexibleContexts   , StandaloneDeriving   , ScopedTypeVariables   , MultiParamTypeClasses@@ -48,12 +47,13 @@     VerbListenerT (..)   , execVerbListenerT   , -- * Utilities-    lookupVerb-  , getVerb+    getVerbFromRequest+  , verbsToMiddleware   ) where  -import           Network.Wai (Request (..))+import           Network.Wai (Request, strictRequestBody, requestMethod)+import           Network.Wai.Trans (MiddlewareT) import           Network.HTTP.Types (StdMethod (..), Method, methodDelete, methodPut, methodPost, methodGet)  import           Data.HashMap.Lazy (HashMap)@@ -61,10 +61,11 @@ import           Data.Monoid ((<>)) import           Data.Hashable (Hashable) import           Data.Maybe (fromMaybe)+import qualified Data.ByteString.Lazy as LBS import           Control.Applicative (Alternative) import           Control.Monad (MonadPlus) import           Control.Monad.Fix (MonadFix)-import           Control.Monad.IO.Class (MonadIO)+import           Control.Monad.IO.Class (MonadIO (liftIO)) import           Control.Monad.Trans (MonadTrans (lift)) import           Control.Monad.State (MonadState, StateT (..), modify', execStateT) import           Control.Monad.Reader (MonadReader)@@ -82,7 +83,7 @@ -- * Types  -- | A map from an HTTP verb, to a result and uploading method.-type VerbMap r = HashMap Verb r+type VerbMap r = HashMap Verb (Either r (LBS.ByteString -> r))  type Verb = StdMethod @@ -91,9 +92,9 @@ instance Hashable Verb  --- | Fetches the HTTP verb from the WAI @Request@ - defaults to GET.-getVerb :: Request -> Verb-getVerb req = fromMaybe GET $ httpMethodToMSym (requestMethod req)+-- | Fetches the HTTP verb from the WAI 'Network.Wai.Request' - defaults to GET.+getVerbFromRequest :: Request -> Verb+getVerbFromRequest req = fromMaybe GET $ httpMethodToMSym (requestMethod req)   where     httpMethodToMSym :: Method -> Maybe Verb     httpMethodToMSym x | x == methodGet    = Just GET@@ -102,13 +103,7 @@                        | x == methodDelete = Just DELETE                        | otherwise         = Nothing -{-# INLINEABLE getVerb #-}---- | Take the monadic partial result of @lookupVerb@, and actually h the upload.-lookupVerb :: Verb -> VerbMap r -> Maybe r-lookupVerb = HM.lookup--{-# INLINEABLE lookupVerb #-}+{-# INLINEABLE getVerbFromRequest #-}   -- * Verb Writer@@ -150,23 +145,23 @@ get :: ( Monad m        , Monoid r        ) => r -> VerbListenerT r m ()-get r = tell' $ HM.singleton GET r+get r = tell' (HM.singleton GET (Left r))  {-# INLINEABLE get #-}  -- | For simple @POST@ responses post :: ( Monad m         , Monoid r-        ) => r -> VerbListenerT r m ()-post r = tell' $ HM.singleton POST r+        ) => (LBS.ByteString -> r) -> VerbListenerT r m ()+post r = tell' (HM.singleton POST (Right r))  {-# INLINEABLE post #-}  -- | For simple @PUT@ responses put :: ( Monad m        , Monoid r-       ) => r -> VerbListenerT r m ()-put r = tell' $ HM.singleton PUT r+       ) => (LBS.ByteString -> r) -> VerbListenerT r m ()+put r = tell' (HM.singleton PUT (Right r))  {-# INLINEABLE put #-} @@ -174,11 +169,31 @@ delete :: ( Monad m           , Monoid r           ) => r -> VerbListenerT r m ()-delete r = tell' $ HM.singleton DELETE r+delete r = tell' (HM.singleton DELETE (Left r))  {-# INLINEABLE delete #-}  tell' :: (Monoid r, MonadState (VerbMap r) m) => VerbMap r -> m ()-tell' x = modify' (\y -> HM.unionWith (<>) y x)+tell' z = modify' (\y -> HM.unionWith go y z)+  where+    go (Left x) (Left y) = Left (x <> y)+    go (Right f) (Right g) = Right (\a -> f a <> g a)+    go (Left x) (Right g) = Right (\a -> x <> g a)+    go (Right f) (Left y) = Right (\a -> f a <> y)  {-# INLINEABLE tell' #-}+++verbsToMiddleware :: MonadIO m+                  => VerbListenerT (MiddlewareT m) m ()+                  -> MiddlewareT m+verbsToMiddleware vs app req resp = do+  m <- execVerbListenerT vs+  let v = getVerbFromRequest req+  case HM.lookup v m of+    Nothing -> app req resp+    Just eR -> case eR of+      Left x -> x app req resp+      Right f -> do+        body <- liftIO (strictRequestBody req)+        f body app req resp

wai-middleware-verbs.cabal view

@@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 9c43d7c8db95eb21d2d5a3d86cdce709454c42de2d61fe27cb471a0c92115f4a+-- hash: c44481a358f46e101abf15c73f7e9876073a1bd3f4cc3ad6bac1db9e7ce8cb25  name:           wai-middleware-verbs-version:        0.3.2.1+version:        0.4.0 synopsis:       Route Wai middlewares based on HTTP verbs description:    Please see the README on Github at <https://git.localcooking.com/tooling/wai-middleware-verbs#readme> category:       Web@@ -36,6 +36,7 @@   ghc-options: -Wall   build-depends:       base >=4.8 && <5+    , bytestring     , exceptions     , hashable     , http-types@@ -47,4 +48,5 @@     , transformers-base     , unordered-containers     , wai >=3.2.1+    , wai-transformers >=0.1.0   default-language: Haskell2010