wai-middleware-verbs 0.2.0 → 0.3.0
raw patch · 3 files changed
+28/−44 lines, 3 filesdep ~wai-middleware-content-typedep ~wai-transformers
Dependency ranges changed: wai-middleware-content-type, wai-transformers
Files
- examples/Example.hs +11/−11
- src/Network/Wai/Middleware/Verbs.hs +14/−29
- wai-middleware-verbs.cabal +3/−4
examples/Example.hs view
@@ -9,6 +9,7 @@ import Network.Wai.Middleware.Verbs import Network.Wai.Middleware.ContentType (textOnly) import Network.Wai.Trans+import Network.HTTP.Types import qualified Data.Text.Lazy as LT import Data.Monoid import Data.Typeable@@ -19,7 +20,7 @@ theEmbeddedApp :: ( MonadIO m ) => LT.Text -> ApplicationT m theEmbeddedApp v _ respond =- respond $ textOnly $ v <> " Verb accepted!"+ respond $ textOnly (v <> " Verb accepted!") status200 [] data UploadError = UploadFailed@@ -31,10 +32,12 @@ , MonadThrow m ) => VerbListenerT (ApplicationT m) m () myListener = do- get $ theEmbeddedApp "GET"- put uploadFail $ theEmbeddedApp "PUT" -- should never work- post uploadSucceed $ theEmbeddedApp "POST"- delete $ theEmbeddedApp "DELETE"+ get $ theEmbeddedApp "GET"+ put $ readingRequest uploadFail+ $ theEmbeddedApp "PUT" -- should never work+ post $ readingRequest uploadSucceed+ $ theEmbeddedApp "POST"+ delete $ theEmbeddedApp "DELETE" where uploadFail _ = throwM UploadFailed uploadSucceed _ = return ()@@ -42,7 +45,7 @@ handleError :: ( MonadIO m ) => UploadError -> ApplicationT m handleError UploadFailed _ respond =- respond $ textOnly "Upload Failed!"+ respond $ textOnly "Upload Failed!" status500 [] myApp :: ( MonadIO m@@ -52,10 +55,8 @@ findResponse `catch` (\e -> handleError e req respond) where findResponse = do- let v = getVerb req xs <- execVerbListenerT myListener- mr <- lookupVerb req v xs- case mr of+ case lookupVerb (getVerb req) xs of Nothing -> app req respond Just r -> r req respond @@ -64,7 +65,6 @@ main = run 3000 (myApp defApp) where defApp :: Application- defApp _ respond =- respond $ textOnly "404"+ defApp _ respond = respond $ textOnly "404" status404 []
src/Network/Wai/Middleware/Verbs.hs view
@@ -83,7 +83,7 @@ -- * Types -- | A map from an HTTP verb, to a result and uploading method.-type VerbMap m r = HashMap Verb (Request -> m (), r)+type VerbMap r = HashMap Verb r type Verb = StdMethod @@ -106,11 +106,8 @@ {-# 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 $ HM.lookup v vmap- lift (upload req)- return result+lookupVerb :: Verb -> VerbMap r -> Maybe r+lookupVerb = HM.lookup {-# INLINEABLE lookupVerb #-} @@ -129,16 +126,16 @@ -- > uploader req = -- > liftIO $ print =<< strictRequestBody req newtype VerbListenerT r m a = VerbListenerT- { runVerbListenerT :: StateT (VerbMap m r) m a+ { runVerbListenerT :: StateT (VerbMap r) m a } deriving ( Functor, Applicative, Alternative, Monad, MonadFix, MonadPlus- , MonadState (VerbMap m r), MonadWriter w, MonadReader r, MonadIO+ , MonadState (VerbMap r), MonadWriter w, MonadReader r, MonadIO , MonadError e', MonadCont, MonadBase b, MonadThrow, MonadCatch , MonadMask, MonadLogger- )+ ) -- TODO: MonadControl deriving instance (MonadResource m, MonadBase IO m) => MonadResource (VerbListenerT r m) -execVerbListenerT :: Monad m => VerbListenerT r m a -> m (VerbMap m r)+execVerbListenerT :: Monad m => VerbListenerT r m a -> m (VerbMap r) execVerbListenerT xs = execStateT (runVerbListenerT xs) mempty {-# INLINEABLE execVerbListenerT #-}@@ -153,40 +150,28 @@ -- | For simple @GET@ responses get :: ( Monad m ) => r -> VerbListenerT r m ()-get r = tell' $! HM.singleton GET ( const $ return ()- , r- )+get r = tell' $! HM.singleton GET r {-# INLINEABLE get #-} -- | For simple @POST@ responses post :: ( Monad m- ) => (Request -> m ()) -- Handle upload- -> r- -> VerbListenerT r m ()-post h r = tell' $! HM.singleton POST ( h- , r- )+ ) => r -> VerbListenerT r m ()+post r = tell' $! HM.singleton POST r {-# INLINEABLE post #-} -- | For simple @PUT@ responses put :: ( Monad m- ) => (Request -> m ()) -- Handle upload- -> r- -> VerbListenerT r m ()-put h r = tell' $! HM.singleton PUT ( h- , r- )+ ) => r -> VerbListenerT r m ()+put r = tell' $! HM.singleton PUT r {-# INLINEABLE put #-} -- | For simple @DELETE@ responses delete :: ( Monad m ) => r -> VerbListenerT r m ()-delete r = tell' $! HM.singleton DELETE ( const $ return ()- , r- )+delete r = tell' $! HM.singleton DELETE r {-# INLINEABLE delete #-} @@ -198,6 +183,6 @@ mapVerbs :: Monad m => (r -> s) -> VerbListenerT r m () -> VerbListenerT s m () mapVerbs f xs = do vmap <- lift $ execVerbListenerT xs- tell' $ second f <$> vmap+ tell' $ f <$> vmap {-# INLINEABLE mapVerbs #-}
wai-middleware-verbs.cabal view
@@ -1,5 +1,5 @@ Name: wai-middleware-verbs-Version: 0.2.0+Version: 0.3.0 Author: Athan Clark <athan.clark@gmail.com> Maintainer: Athan Clark <athan.clark@gmail.com> License: BSD3@@ -58,10 +58,9 @@ , transformers-base , unordered-containers , wai- , wai-transformers >= 0.0.4- , wai-middleware-content-type+ , wai-transformers >= 0.0.5+ , wai-middleware-content-type >= 0.2.1 , warp- Source-Repository head Type: git