nested-routes 0.1 → 0.1.1

raw patch · 2 files changed

+57/−33 lines, 2 filesdep ~pseudo-triePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: pseudo-trie

API changes (from Hackage documentation)

Files

• nested-routes.cabal +2/−2
• src/Web/Routes/Nested.hs +55/−31

@@ -1,5 +1,5 @@ Name:                   nested-routes-Version:                0.1+Version:                0.1.1 Author:                 Athan Clark <athan.clark@gmail.com> Maintainer:             Athan Clark <athan.clark@gmail.com> License:                BSD3@@ -24,7 +24,7 @@                       , transformers                       , semigroups                       , containers-                      , pseudo-trie >= 0.0.4.2+                      , pseudo-trie >= 0.0.4.3                       , text                       , aeson                       , blaze-html

@@ -9,7 +9,9 @@ module Web.Routes.Nested   ( module Web.Routes.Nested.FileExtListener   , module Web.Routes.Nested.VerbListener+  , HandlerT (..)   , handle+  , notFound   , route   ) where @@ -36,10 +38,12 @@ import qualified Data.Text                         as T import qualified Data.Map.Lazy                     as M import qualified Data.ByteString.Lazy              as BL+import           Data.Maybe                        (fromMaybe)   newtype HandlerT z m a = HandlerT-  { runHandler :: WriterT (MergeRooted T.Text (Verbs z m Response)) m a }+  { runHandler :: WriterT ( MergeRooted T.Text (Verbs z m Response)+                          , MergeRooted T.Text (FileExts Response) ) m a }   deriving (Functor)  deriving instance Applicative m => Applicative (HandlerT z m)@@ -51,75 +55,95 @@  -- | Add a path to the list of routes handle :: Monad m =>-          [T.Text] -- ^ Input path, separated by slashes+          [T.Text]                      -- ^ Input path, separated by slashes        -> VerbListenerT z Response m () -- ^ HTTP Method-oriented monad-       -> [HandlerT z m ()] -- ^ Child paths+       -> [HandlerT z m ()]             -- ^ Child paths        -> HandlerT z m () handle ts vl [] = do   vfrs <- lift $ execWriterT $ runVerbListenerT vl    HandlerT $ tell $     case ts of-      [] -> MergeRooted $ Rooted (Just vfrs) []-      _  -> MergeRooted $ Rooted Nothing [Rest (NE.fromList ts) vfrs]+      [] -> (MergeRooted $ Rooted (Just vfrs) [],                           mempty)+      _  -> (MergeRooted $ Rooted Nothing     [Rest (NE.fromList ts) vfrs], mempty) handle ts vl cs = do   vfrs <- lift $ execWriterT $ runVerbListenerT vl-  child <- lift $ foldM (\acc c -> (acc <>) <$> (execWriterT $ runHandler c)) mempty cs+  (child,_) <- lift $ foldM (\acc c -> (acc <>) <$> (execWriterT $ runHandler c)) mempty cs    HandlerT $ tell $     case ts of       [] -> case unMergeRooted child of-              Rooted _ xs -> MergeRooted $ Rooted (Just vfrs) xs+              Rooted _ xs -> (MergeRooted $ Rooted (Just vfrs) xs, mempty)       _  -> let child' = push (unMergeRooted child) $ NE.fromList ts in-            MergeRooted $ Rooted Nothing [P.assign (NE.fromList ts) (Just vfrs) child']+            (MergeRooted $ Rooted Nothing [P.assign (NE.fromList ts) (Just vfrs) child'], mempty)  +notFound :: Monad m =>+            [T.Text]+         -> FileExtListenerT Response m ()+         -> HandlerT z m ()+notFound ts flistener = do+  (fes :: FileExts Response) <- lift $ execWriterT $ runFileExtListenerT flistener+  HandlerT $ tell $+    case ts of+      [] -> (mempty, MergeRooted $ Rooted (Just fes) [])+      _  -> (mempty, MergeRooted $ Rooted Nothing    [Rest (NE.fromList ts) fes])++ -- | Turns a @HandlerT@ into a Wai @Application@ route :: (Functor m, Monad m, MonadIO m) =>-         Response -- ^ Response to give when not found in the router-      -> HandlerT z m a -- ^ Assembled @handle@ calls+         HandlerT z m a -- ^ Assembled @handle@ calls       -> Request-      -> (Response -> m b) -> m b-route notFound h req respond = do-  trie <- unMergeRooted <$> (execWriterT $ runHandler h)-  let mMethod = httpMethodToMSym $ requestMethod req-      mFileext = case pathInfo req of-                   [] -> Just Html-                   xs -> possibleExts $ getFileExt $ last xs+      -> (Response -> IO ResponseReceived) -> m ResponseReceived+route h req respond = do+  (rtrie, festrie) <- execWriterT $ runHandler h+  let trie         = unMergeRooted rtrie+      notFoundTrie = unMergeRooted festrie+      mMethod      = httpMethodToMSym $ requestMethod req+      mFileext     = case pathInfo req of+                       [] -> Just Html+                       xs -> possibleExts $ getFileExt $ last xs+      mNotFoundMap :: Maybe (M.Map FileExt Response)+      mNotFoundMap = (return . unFileExts) =<< R.lookupNearestParent (pathInfo req) notFoundTrie    case (mFileext, mMethod) of-    (Just f, Just v) -> let cleanedPathInfo = applyToLast trimFileExt $ pathInfo req in+    (Just f, Just v) -> let cleanedPathInfo = applyToLast trimFileExt $ pathInfo req+                        in                         case R.lookup cleanedPathInfo trie of-      Just vmap -> continue f v vmap+      Just vmap -> continue f v vmap mNotFoundMap       Nothing  -> case trimFileExt $ last $ pathInfo req of         "index" -> case R.lookup (init $ pathInfo req) trie of-          Just vmap -> continue f v vmap-          Nothing -> respond notFound-        _       -> respond notFound-    _ -> respond notFound+          Just vmap -> continue f v vmap mNotFoundMap+          Nothing -> liftIO $ respond $ fromMaybe plain404 $ mNotFoundMap >>= lookupMin f+        _       -> liftIO $ respond $ fromMaybe plain404 $ mNotFoundMap >>= lookupMin f+    _ -> liftIO $ respond $ fromMaybe plain404 $ mNotFoundMap >>= lookupMin Html    where-    continue f v vmap = case M.lookup v $ unVerbs vmap of+    continue :: MonadIO m => FileExt -> Verb -> Verbs z m Response -> Maybe (M.Map FileExt Response) -> m ResponseReceived+    continue f v vmap mNotFoundMap = case M.lookup v $ unVerbs vmap of         Just (mreqbodyf,femap) ->           case lookupMin f $ unFileExts femap of             Just r -> do               case mreqbodyf of-                Nothing    -> respond r+                Nothing    -> liftIO $ respond r                 Just (reqbf,Nothing) -> do                   body <- liftIO $ strictRequestBody req                   (runReaderT $ reqbf) body-                  respond r+                  liftIO $ respond r                 Just (reqbf,Just bl) -> do                   case requestBodyLength req of                     KnownLength bl' -> if bl' <= bl                                          then do body <- liftIO $ strictRequestBody req                                                  (runReaderT $ reqbf) body-                                                 respond r-                                         else respond notFound-                    _ -> respond notFound-            Nothing -> respond notFound-        Nothing -> respond notFound+                                                 liftIO $ respond r+                                         else liftIO $ respond $ fromMaybe plain404 $ mNotFoundMap >>= lookupMin f+                    _ -> liftIO $ respond $ fromMaybe plain404 $ mNotFoundMap >>= lookupMin f+            Nothing -> liftIO $ respond $ fromMaybe plain404 $ mNotFoundMap >>= lookupMin f+        Nothing -> liftIO $ respond $ fromMaybe plain404 $ lookupMin f =<< mNotFoundMap +    plain404 = responseLBS status404 [("Content-Type","text/plain")] "404"++    lookupMin :: Ord k => k -> M.Map k a -> Maybe a     lookupMin k map | all (k <) (M.keys map) = M.lookup (minimum $ M.keys map) map                     | otherwise              = M.lookup k map