nested-routes 3.0.0.2 → 3.1.0

raw patch · 3 files changed

+102/−32 lines, 3 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• nested-routes.cabal +3/−2
• src/Web/Routes/Nested.hs +22/−18
• src/Web/Routes/Nested/VerbListener.hs +77/−12

@@ -1,5 +1,5 @@ Name:                   nested-routes-Version:                3.0.0.2+Version:                3.1.0 Author:                 Athan Clark <athan.clark@gmail.com> Maintainer:             Athan Clark <athan.clark@gmail.com> License:                BSD3@@ -20,7 +20,8 @@   <https://hackage.haskell.org/package/attoparsec Attoparsec>   parsers and <https://hackage.haskell.org/package/regex-compat Regular Expressions>   /directly/ in our routes, with our handlers-  reflecting their results. You can find more information on the <https://www.fpcomplete.com/user/AthanClark/nested-routes demo>.+  reflecting their results. You can find more information on the+  <https://www.fpcomplete.com/user/AthanClark/nested-routes demo>.   .   As an example:   .

@@ -31,10 +31,6 @@ import           Network.HTTP.Media import           Network.Wai -import           Control.Applicative-import           Control.Monad.IO.Class-import           Control.Monad.Trans-import           Control.Monad.Writer import           Data.Trie.Pred.Unified import qualified Data.Trie.Pred.Unified            as P import qualified Data.Text                         as T@@ -45,8 +41,13 @@ import           Data.Constraint import           Data.Witherable import           Data.List+import           Data.Function.Poly -import Data.Function.Poly+import           Control.Arrow+import           Control.Applicative+import           Control.Monad.IO.Class+import           Control.Monad.Trans+import           Control.Monad.Writer   newtype HandlerT x m a = HandlerT@@ -141,12 +142,12 @@       acceptBS = Prelude.lookup ("Accept" :: HeaderName) $ requestHeaders req       fe = fromMaybe Html mFileext -  notFoundBasic <- handleNotFound acceptBS Html Get mnftrans+  notFoundBasic <- handleNotFound req acceptBS Html Get mnftrans    case mMethod of     Nothing -> liftIO $ respond404 notFoundBasic     Just v  -> do-      menf <- handleNotFound acceptBS fe v mnftrans+      menf <- handleNotFound req acceptBS fe v mnftrans       let failResp = liftIO $ respond404 menf        case P.lookupWithL trimFileExt (pathInfo req) rtrie of@@ -154,10 +155,10 @@           [] -> failResp           _  -> case trimFileExt $ last $ pathInfo req of                   "index" -> maybe failResp-                               (\foundM -> continue acceptBS fe v foundM menf) $+                               (\foundM -> continue req acceptBS fe v foundM menf) $                                P.lookup (init $ pathInfo req) rtrie                   _ -> failResp-        Just foundM -> continue acceptBS fe v foundM menf+        Just foundM -> continue req acceptBS fe v foundM menf    where     onJustM :: Monad m => (a -> m (Maybe b)) -> Maybe a -> m (Maybe b)@@ -165,38 +166,41 @@       handleNotFound :: MonadIO m =>-                      Maybe B.ByteString+                      Request+                   -> Maybe B.ByteString                    -> FileExt                    -> Verb                    -> Maybe (ActionT m ())                    -> m (Maybe Response)-    handleNotFound acceptBS f v mnfcomp =+    handleNotFound req acceptBS f v mnfcomp =       let handleEither nfcomp = do             vmapLit <- execWriterT $ runVerbListenerT nfcomp             onJustM (\(_, femonad) -> do               femap <- execWriterT $ runFileExtListenerT femonad               return $ lookupProper acceptBS f $ unFileExts femap) $-                M.lookup v $ unVerbs vmapLit-      in-      onJustM handleEither mnfcomp+                M.lookup v $ supplyReq req $ unVerbs vmapLit+      in onJustM handleEither mnfcomp       continue :: MonadIO m =>-                Maybe B.ByteString+                Request+             -> Maybe B.ByteString              -> FileExt              -> Verb              -> ActionT m ()              -> Maybe Response              -> m ResponseReceived-    continue acceptBS f v foundM mnfResp = do+    continue req acceptBS f v foundM mnfResp = do       vmapLit <- execWriterT $ runVerbListenerT foundM-      continueMap acceptBS f v (unVerbs vmapLit) mnfResp+      continueMap acceptBS f v (supplyReq req $ unVerbs vmapLit) mnfResp      continueMap :: MonadIO m =>                    Maybe B.ByteString                 -> FileExt                 -> Verb-                -> M.Map Verb (Maybe (BL.ByteString -> m (), Maybe BodyLength), FileExtListenerT Response m ())+                -> M.Map Verb ( Maybe (BL.ByteString -> m (), Maybe BodyLength)+                              , FileExtListenerT Response m ()+                              )                 -> Maybe Response                 -> m ResponseReceived     continueMap acceptBS f v vmap mnfResp = do

@@ -5,18 +5,22 @@   , GeneralizedNewtypeDeriving   , ScopedTypeVariables   , MultiParamTypeClasses+  , TupleSections   #-}  module Web.Routes.Nested.VerbListener where -import           Control.Applicative hiding (empty)-import           Control.Monad.Trans-import           Control.Monad.Writer+import           Network.Wai (Request)+ import           Data.Foldable import           Data.Traversable-import           Data.Map.Lazy+import           Data.Map                             as Map import qualified Data.ByteString.Lazy                 as BL import           Data.Word                            (Word64)+import           Control.Arrow+import           Control.Applicative hiding (empty)+import           Control.Monad.Trans+import           Control.Monad.Writer   data Verb = Get@@ -27,9 +31,31 @@  type BodyLength = Word64 -newtype Verbs m r = Verbs { unVerbs :: Map Verb (Maybe (BL.ByteString -> m (), Maybe BodyLength), r) }-  deriving (Monoid, Functor, Foldable, Traversable)+newtype Verbs m r = Verbs+  { unVerbs :: Map Verb ( Maybe (BL.ByteString -> m (), Maybe BodyLength)+                        , Either r (Request -> r)+                        )+  } deriving (Monoid) +supplyReq :: Request+          -> Map Verb ( Maybe (BL.ByteString -> m (), Maybe BodyLength)+                      , Either r (Request -> r)+                      )+          -> Map Verb ( Maybe (BL.ByteString -> m (), Maybe BodyLength)+                      , r+                      )+supplyReq req xs = second (either id ($ req)) <$> xs++instance Functor (Verbs m) where+  fmap f (Verbs xs) = Verbs $ fmap go xs+    where go (x, Left r)  = (x, Left $ f r)+          go (x, Right r) = (x, Right $ f . r)++instance Foldable (Verbs m) where+  foldMap f (Verbs xs) = foldMap go xs+    where go (_, Left r) = f r+          go _ = mempty+ newtype VerbListenerT r m a =   VerbListenerT { runVerbListenerT :: WriterT (Verbs m r) m a }     deriving (Functor, Applicative, Monad, MonadIO)@@ -45,44 +71,83 @@ get :: ( Monad m        ) => r -> VerbListenerT r m () get r = do-  let new = singleton Get (Nothing, r)+  let new = singleton Get (Nothing, Left r)   VerbListenerT $ tell $ Verbs new +getReq :: ( Monad m+          ) => (Request -> r) -> VerbListenerT r m ()+getReq r = do+  let new = singleton Get (Nothing, Right r)+  VerbListenerT $ tell $ Verbs new + post :: ( Monad m         , MonadIO m         ) => (BL.ByteString -> m ()) -> r -> VerbListenerT r m () post handle r = do-  let new = singleton Post (Just (handle, Nothing), r)+  let new = singleton Post (Just (handle, Nothing), Left r)   VerbListenerT $ tell $ Verbs new +postReq :: ( Monad m+           , MonadIO m+           ) => (BL.ByteString -> m ()) -> (Request -> r) -> VerbListenerT r m ()+postReq handle r = do+  let new = singleton Post (Just (handle, Nothing), Right r)+  VerbListenerT $ tell $ Verbs new + postMax :: ( Monad m            , MonadIO m            ) => BodyLength -> (BL.ByteString -> m ()) -> r -> VerbListenerT r m () postMax bl handle r = do-  let new = singleton Post (Just (handle, Just bl), r)+  let new = singleton Post (Just (handle, Just bl), Left r)   VerbListenerT $ tell $ Verbs new +postMaxReq :: ( Monad m+              , MonadIO m+              ) => BodyLength -> (BL.ByteString -> m ()) -> (Request -> r) -> VerbListenerT r m ()+postMaxReq bl handle r = do+  let new = singleton Post (Just (handle, Just bl), Right r)+  VerbListenerT $ tell $ Verbs new + put :: ( Monad m        , MonadIO m        ) => (BL.ByteString -> m ()) -> r -> VerbListenerT r m () put handle r = do-  let new = singleton Put (Just (handle, Nothing), r)+  let new = singleton Put (Just (handle, Nothing), Left r)   VerbListenerT $ tell $ Verbs new +putReq :: ( Monad m+          , MonadIO m+          ) => (BL.ByteString -> m ()) -> (Request -> r) -> VerbListenerT r m ()+putReq handle r = do+  let new = singleton Put (Just (handle, Nothing), Right r)+  VerbListenerT $ tell $ Verbs new  putMax :: ( Monad m           , MonadIO m           ) => BodyLength -> (BL.ByteString -> m ()) -> r -> VerbListenerT r m () putMax bl handle r = do-  let new = singleton Put (Just (handle, Just bl), r)+  let new = singleton Put (Just (handle, Just bl), Left r)   VerbListenerT $ tell $ Verbs new +putMaxReq :: ( Monad m+             , MonadIO m+             ) => BodyLength -> (BL.ByteString -> m ()) -> (Request -> r) -> VerbListenerT r m ()+putMaxReq bl handle r = do+  let new = singleton Put (Just (handle, Just bl), Right r)+  VerbListenerT $ tell $ Verbs new + delete :: ( Monad m           ) => r -> VerbListenerT r m () delete r = do-  let new = singleton Delete (Nothing, r)+  let new = singleton Delete (Nothing, Left r)+  VerbListenerT $ tell $ Verbs new++deleteReq :: ( Monad m+             ) => (Request -> r) -> VerbListenerT r m ()+deleteReq r = do+  let new = singleton Delete (Nothing, Right r)   VerbListenerT $ tell $ Verbs new