wai-middleware-verbs 0.1.0 → 0.1.1

raw patch · 3 files changed

+137/−17 lines, 3 filesdep +hashabledep +textdep +unordered-containersdep −containersnew-component:exe:examplePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: hashable, text, unordered-containers, wai-middleware-content-type, warp

Dependencies removed: containers

API changes (from Hackage documentation)

Files

• examples/Example.hs +61/−0
• src/Network/Wai/Middleware/Verbs.hs +39/−15
• wai-middleware-verbs.cabal +37/−2

@@ -0,0 +1,61 @@+{-# LANGUAGE+    OverloadedStrings+  , DeriveDataTypeable+  #-}++module Main where++import Network.Wai.Handler.Warp+import Network.Wai.Middleware.Verbs+import Network.Wai.Middleware.ContentType (textOnly)+import Network.Wai.Trans+import qualified Data.Text.Lazy as LT+import Data.Monoid+import Data.Typeable+import Control.Monad.IO.Class+import Control.Monad.Catch+++theEmbeddedApp :: MonadIO m => LT.Text -> MiddlewareT m+theEmbeddedApp v _ _ respond =+  respond $ textOnly $ v <> " Verb accepted!"+++data UploadError = UploadFailed+  deriving (Show, Typeable)++instance Exception UploadError++myListener :: ( MonadIO m+              , MonadThrow m+              ) => VerbListenerT (MiddlewareT m) m ()+myListener = do+  get                $ theEmbeddedApp "GET"+  put  uploadFail    $ theEmbeddedApp "PUT" -- should never work+  post uploadSucceed $ theEmbeddedApp "POST"+  delete             $ theEmbeddedApp "DELETE"+  where+    uploadFail    _ = throwM UploadFailed+    uploadSucceed _ = return ()++handleError :: UploadError -> MiddlewareT m+handleError UploadFailed _ _ respond =+  respond $ textOnly "Upload Failed!"+++myApp :: ( MonadIO m+         , MonadCatch m+         ) => MiddlewareT m+myApp app req respond =+          (verbsToMiddleware myListener app req respond)+  `catch` (\e -> handleError e app req respond)+++main :: IO ()+main = run 3000 (myApp defApp)+  where+    defApp :: Application+    defApp _ respond =+      respond $ textOnly "404"++

@@ -6,6 +6,8 @@   , MultiParamTypeClasses   , UndecidableInstances   , GeneralizedNewtypeDeriving+  , DeriveGeneric+  , TypeSynonymInstances   #-}  {-|@@ -56,9 +58,10 @@ import           Network.Wai.Trans import           Network.HTTP.Types -import           Data.Map (Map)-import qualified Data.Map                             as Map+import           Data.HashMap.Lazy (HashMap)+import qualified Data.HashMap.Lazy                    as HM import           Data.Monoid+import           Data.Hashable import           Control.Arrow (second) import           Control.Applicative import           Control.Monad.Trans@@ -75,17 +78,24 @@ import           Control.Monad.Logger import           Control.Error +import           GHC.Generics + -- * Types  -- | A map from an HTTP verb, to a result and uploading method.-type VerbMap m r = Map Verb (Request -> m (), r)+type VerbMap m r = HashMap Verb (Request -> m (), r)  type Verb = StdMethod +deriving instance Generic Verb++instance Hashable Verb++ -- | Fetches the HTTP verb from the WAI @Request@ - defaults to GET. getVerb :: Request -> Verb-getVerb req = fromMaybe GET $ httpMethodToMSym $ requestMethod req+getVerb req = fromMaybe GET $ httpMethodToMSym (requestMethod req)   where     httpMethodToMSym :: Method -> Maybe Verb     httpMethodToMSym x | x == methodGet    = Just GET@@ -94,13 +104,16 @@                        | x == methodDelete = Just DELETE                        | otherwise         = Nothing +{-# INLINEABLE getVerb #-}+ -- | 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+  (upload, result) <- hoistMaybe $ HM.lookup v vmap   lift (upload req)   return result +{-# INLINEABLE lookupVerb #-}  -- * Verb Writer @@ -115,9 +128,9 @@ --   >     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+newtype VerbListenerT r m a = VerbListenerT+  { runVerbListenerT :: StateT (VerbMap m r) m a+  } deriving ( Functor, Applicative, Alternative, Monad, MonadFix, MonadPlus              , MonadState (VerbMap m r), MonadWriter w, MonadReader r, MonadIO              , MonadError e', MonadCont, MonadBase b, MonadThrow, MonadCatch              , MonadMask, MonadLogger@@ -128,6 +141,7 @@ execVerbListenerT :: Monad m => VerbListenerT r m a -> m (VerbMap m r) execVerbListenerT xs = execStateT (runVerbListenerT xs) mempty +{-# INLINEABLE execVerbListenerT #-}  instance MonadTrans (VerbListenerT r) where   lift = VerbListenerT . lift -- uses StateT@@ -144,48 +158,58 @@   fromMaybe (app req respond) $     (\mid -> mid app req respond) <$> mMiddleware +{-# INLINEABLE verbsToMiddleware #-}  -- * Combinators  -- | For simple @GET@ responses get :: ( Monad m        ) => r -> VerbListenerT r m ()-get r = tell' $ Map.singleton GET ( const $ return ()+get r = tell' $! HM.singleton GET ( const $ return ()                                   , r                                   ) +{-# INLINEABLE get #-}+ -- | For simple @POST@ responses post :: ( Monad m         ) => (Request -> m ()) -- Handle upload           -> r           -> VerbListenerT r m ()-post h r = tell' $ Map.singleton POST ( h+post h r = tell' $! HM.singleton POST ( h                                       , r                                       ) +{-# INLINEABLE post #-}+ -- | For simple @PUT@ responses put :: ( Monad m        ) => (Request -> m ()) -- Handle upload          -> r          -> VerbListenerT r m ()-put h r = tell' $ Map.singleton PUT ( h+put h r = tell' $! HM.singleton PUT ( h                                     , r                                     ) +{-# INLINEABLE put #-}+ -- | For simple @DELETE@ responses delete :: ( Monad m           ) => r -> VerbListenerT r m ()-delete r = tell' $ Map.singleton DELETE ( const $ return ()+delete r = tell' $! HM.singleton DELETE ( const $ return ()                                         , r                                         ) +{-# INLINEABLE delete #-}  tell' :: (Monoid w, MonadState w m) => w -> m ()-tell' x = do-  xs <- S.get-  S.put $ xs <> x+tell' x = modify' (<> x) +{-# INLINEABLE tell' #-}+ mapVerbs :: Monad m => (r -> s) ->  VerbListenerT r m () -> VerbListenerT s m () mapVerbs f xs = do   vmap <- lift $ execVerbListenerT xs   tell' $ second f <$> vmap++{-# INLINEABLE mapVerbs #-}

@@ -1,5 +1,5 @@ Name:                   wai-middleware-verbs-Version:                0.1.0+Version:                0.1.1 Author:                 Athan Clark <athan.clark@gmail.com> Maintainer:             Athan Clark <athan.clark@gmail.com> License:                BSD3@@ -10,15 +10,19 @@ Build-Type:             Simple Category:               Web +Flag Example+  Description:          Build a simple example+  Default:              False+ Library   Default-Language:     Haskell2010   HS-Source-Dirs:       src   GHC-Options:          -Wall   Exposed-Modules:      Network.Wai.Middleware.Verbs   Build-Depends:        base >= 4.8 && < 5-                      , containers                       , exceptions                       , errors+                      , hashable                       , http-types                       , monad-logger                       , mmorph@@ -26,8 +30,39 @@                       , resourcet                       , transformers                       , transformers-base+                      , unordered-containers                       , wai                       , wai-transformers >= 0.0.3++Executable example+  if flag(Example)+    Buildable: True+  else+    Buildable: False+  Default-Language:     Haskell2010+  HS-Source-Dirs:       src+                      , examples+  GHC-Options:          -Wall+  Main-Is:              Example.hs+  Other-Modules:        Network.Wai.Middleware.Verbs+  Build-Depends:        base >= 4.8 && < 5+                      , exceptions+                      , errors+                      , hashable+                      , http-types+                      , monad-logger+                      , mmorph+                      , mtl+                      , resourcet+                      , text+                      , transformers+                      , transformers-base+                      , unordered-containers+                      , wai+                      , wai-transformers >= 0.0.3+                      , wai-middleware-content-type+                      , warp+    Source-Repository head   Type:                 git