nested-routes 0.0.1.1 → 0.0.2

raw patch · 4 files changed

+159/−98 lines, 4 filesdep +blaze-htmldep +bytestringdep +lucidPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: blaze-html, bytestring, lucid

API changes (from Hackage documentation)

Files

• nested-routes.cabal +4/−1
• src/Web/Routes/Nested.hs +53/−23
• src/Web/Routes/Nested/FileExtListener.hs +56/−38
• src/Web/Routes/Nested/VerbListener.hs +46/−36

@@ -1,5 +1,5 @@ Name:                   nested-routes-Version:                0.0.1.1+Version:                0.0.2 Author:                 Athan Clark <athan.clark@gmail.com> Maintainer:             Athan Clark <athan.clark@gmail.com> License:                BSD3@@ -27,6 +27,9 @@                       , pseudo-trie >= 0.0.4                       , text                       , aeson+                      , blaze-html+                      , lucid+                      , bytestring  Test-Suite spec   Type:                 exitcode-stdio-1.0

@@ -6,7 +6,12 @@ {-# LANGUAGE TypeOperators              #-} {-# LANGUAGE OverloadedStrings          #-} -module Web.Routes.Nested where+module Web.Routes.Nested+  ( module Web.Routes.Nested.FileExtListener+  , module Web.Routes.Nested.VerbListener+  , handle+  , route+  ) where  import           Web.Routes.Nested.FileExtListener import           Web.Routes.Nested.VerbListener@@ -29,20 +34,21 @@ import qualified Data.Text                         as T import qualified Data.Map.Lazy                     as M -newtype HandlerT m a = HandlerT-  { runHandler :: WriterT (MergeRooted T.Text (Verbs Response)) m a }++newtype HandlerT z m a = HandlerT+  { runHandler :: WriterT (MergeRooted T.Text (Verbs z Response)) m a }   deriving (Functor) -deriving instance Applicative m => Applicative (HandlerT m)-deriving instance Monad m =>       Monad       (HandlerT m)-deriving instance MonadIO m =>     MonadIO     (HandlerT m)-deriving instance                  MonadTrans   HandlerT+deriving instance Applicative m => Applicative (HandlerT z m)+deriving instance Monad m =>       Monad       (HandlerT z m)+deriving instance MonadIO m =>     MonadIO     (HandlerT z m)+deriving instance                  MonadTrans  (HandlerT z)   handle :: Monad m =>           [T.Text]-       -> VerbListenerT Response m ()-       -> HandlerT m ()+       -> VerbListenerT z Response m ()+       -> HandlerT z m () handle ts vl = do   vfrs <- lift $ execWriterT $ runVerbListenerT vl @@ -51,32 +57,56 @@       [] -> MergeRooted $ Rooted (Just vfrs) []       _  -> MergeRooted $ Rooted Nothing [Rest (NE.fromList ts) vfrs] -route :: (Functor m, Monad m) =>-         HandlerT m a+route :: (Functor m, Monad m, MonadIO m) =>+         HandlerT z m a       -> Request -> (Response -> m b) -> m b route h req respond = do   trie <- unMergeRooted <$> (execWriterT $ runHandler h)   let mMethod = httpMethodToMSym $ requestMethod req-      mFileext = possibleExts $ T.pack $ getFileExt $-                                T.unpack $ last $ pathInfo req+      mFileext = case pathInfo req of+                   [] -> Just Html+                   xs -> possibleExts $ getFileExt $ last xs    case (mFileext, mMethod) of-    (Just f, Just m) -> case R.lookup (pathInfo req) trie of-      Just map -> case M.lookup (f,m) $ unVerbs map of-        Just r  -> respond r+    (Just f, Just v) -> let cleanedPathInfo = applyToLast trimFileExt (pathInfo req) in+                        case R.lookup cleanedPathInfo trie of+      Just vmap -> 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+                Just reqbf -> do+                  body <- liftIO $ strictRequestBody req+                  return $ reqbf body+                  respond r+            Nothing -> respond notFound         Nothing -> respond notFound       Nothing  -> respond notFound     _ -> respond notFound    where-    getFileExt :: String -> String-    getFileExt s = case foldr go Nothing s of-                     Nothing -> ""-                     Just x  -> x+    lookupMin k map | all (k <) (M.keys map) = M.lookup (minimum $ M.keys map) map+                    | otherwise              = M.lookup k map++    getFileExt :: T.Text -> T.Text+    getFileExt s =+      let mfound = foldl go Nothing $ T.unpack s in+      case mfound of+        Nothing -> T.pack ""+        Just x  -> T.pack x       where-        go '.' _         = Just "."-        go x   (Just xs) = Just $ xs ++ [x]-        go x   Nothing   = Nothing+        go Nothing x | x == '.'  = Just "."+                     | otherwise = Nothing+        go (Just xs) x = Just $ xs ++ [x]++    applyToLast :: (a -> a) -> [a] -> [a]+    applyToLast f [] = []+    applyToLast f (x:[]) = f x : []+    applyToLast f (x:xs) = x : applyToLast f xs++    trimFileExt :: T.Text -> T.Text+    trimFileExt s = T.pack $ takeWhile (/= '.') $ T.unpack s      httpMethodToMSym :: Method -> Maybe Verb     httpMethodToMSym x | x == methodGet    = Just Get

@@ -10,7 +10,12 @@ import qualified Data.Text               as T import qualified Data.Text.Lazy          as LT import qualified Data.Text.Lazy.Encoding as LT-import           Network.HTTP.Types      (status200)+import qualified Data.ByteString.Lazy    as B+import qualified Data.ByteString.Builder as BU+import qualified Text.Blaze.Html         as H+import qualified Text.Blaze.Html.Renderer.Text as H+import qualified Lucid.Base              as L+import           Network.HTTP.Types      (status200, RequestHeaders) import           Network.Wai  import           Control.Applicative@@ -27,11 +32,16 @@              | Text   deriving (Show, Eq, Ord) + possibleExts :: T.Text -> Maybe FileExt-possibleExts x | x `elem` ["", ".htm", ".html"] = Just Html-               | x `elem` [".json"]             = Just Json-               | x `elem` [".txt"]              = Just Text-               | otherwise                      = Nothing+possibleExts x | x `elem` htmls = Just Html+               | x `elem` jsons = Just Json+               | x `elem` texts = Just Text+               | otherwise      = Nothing+  where+    htmls = ["", ".htm", ".html"]+    jsons = [".json"]+    texts = [".txt"]  newtype FileExts a = FileExts { unFileExts :: Map FileExt a }   deriving (Show, Eq, Functor, Traversable)@@ -51,55 +61,63 @@   json :: (A.ToJSON j, Monad m) =>-        j-     -> FileExtListenerT Response m ()+        j -> FileExtListenerT Response m () json i =   let r = responseLBS status200 [("Content-Type", "application/json")] $-            A.encode i-  in+            A.encode i in   FileExtListenerT $ tell $     FileExts $ singleton Json r + jsonp :: (A.ToJSON j, Monad m) =>-         j-      -> FileExtListenerT Response m ()+         j -> FileExtListenerT Response m () jsonp i =   let r = responseLBS status200 [("Content-Type", "application/javascript")] $-            A.encode i-  in+            A.encode i in   FileExtListenerT $ tell $     FileExts $ singleton Json r + text :: (Monad m) =>-        LT.Text-     -> FileExtListenerT Response m ()+        LT.Text -> FileExtListenerT Response m () text i =   let r = responseLBS status200 [("Content-Type", "text/plain")] $-            LT.encodeUtf8 i-  in+            LT.encodeUtf8 i in   FileExtListenerT $ tell $     FileExts $ singleton Text r------ blaze :: Html -> Response--- blaze = HR.renderHtml------ lucid :: Monad m => HtmlT m () -> Response--- lucid = L.renderTextT --- json :: ToJSON a => a -> Response--- json = lazy-bytestring . encode --- text :: T.Text -> Response--- text = bytestring . TR.encodeUtf8+blaze :: (Monad m ) =>+         H.Html -> FileExtListenerT Response m ()+blaze i =+  let r = responseLBS status200 [("Content-Type", "text/html")] $+            LT.encodeUtf8 $ H.renderHtml i in+  FileExtListenerT $ tell $+    FileExts $ singleton Html r --- lazy-text :: LT.Text -> Response--- lazy-text = lazy-bytestring . LTR.encodeUtf8------ builder :: Builder -> Response--- builder = responseBuilder------ bytestring :: B.ByteString -> Response--- bytestring = lazy-bytestring . LB.fromStrict------ lazy-bytestring :: LB.ByteString -> Response--- lazy-bytestring = responseLBS++lucid :: (Monad m) =>+         L.HtmlT m () -> FileExtListenerT Response m ()+lucid i = do+  i' <- lift $ L.renderBST i+  let r = responseLBS status200 [("Content-Type", "text/html")] $ i'+  FileExtListenerT $ tell $+    FileExts $ singleton Html r+++builder :: (Monad m) =>+           BU.Builder -> RequestHeaders+        -> FileExt -> FileExtListenerT Response m ()+builder i hs e =+  let r = responseBuilder status200 hs i in+  FileExtListenerT $ tell $+    FileExts $ singleton e r+++bytestring :: (Monad m) =>+              B.ByteString -> RequestHeaders+           -> FileExt -> FileExtListenerT Response m ()+bytestring i hs e =+  let r = responseLBS status200 hs i in+  FileExtListenerT $ tell $+    FileExts $ singleton e r

@@ -1,5 +1,6 @@ {-# LANGUAGE DeriveFunctor              #-} {-# LANGUAGE DeriveTraversable          #-}+{-# LANGUAGE DeriveFoldable             #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables        #-} {-# LANGUAGE StandaloneDeriving         #-}@@ -17,6 +18,7 @@ import           Data.Foldable import           Data.Traversable import           Data.Map.Lazy+import qualified Data.ByteString.Lazy                 as BL   data Verb = Get@@ -25,52 +27,60 @@           | Delete   deriving (Show, Eq, Ord) -newtype Verbs a = Verbs { unVerbs :: Map (FileExt, Verb) a }-  deriving (Show, Eq, Functor, Traversable)+type ReqBodyT z = BL.ByteString -> z -deriving instance Monoid      (Verbs a)-deriving instance Foldable     Verbs+newtype Verbs z a = Verbs { unVerbs :: Map Verb (Maybe (ReqBodyT z), FileExts a) }+  deriving (Functor, Traversable) +deriving instance             Monoid    (Verbs z a)+deriving instance             Foldable  (Verbs z) -newtype VerbListenerT r m a =-  VerbListenerT { runVerbListenerT :: WriterT (Verbs r) m a }+newtype VerbListenerT z r m a =+  VerbListenerT { runVerbListenerT :: WriterT (Verbs z r) m a }     deriving (Functor) -deriving instance Applicative m => Applicative (VerbListenerT r m)-deriving instance Monad m =>       Monad       (VerbListenerT r m)-deriving instance MonadIO m =>     MonadIO     (VerbListenerT r m)-deriving instance                  MonadTrans  (VerbListenerT r)+deriving instance Applicative m => Applicative (VerbListenerT z r m)+deriving instance Monad m =>       Monad       (VerbListenerT z r m)+deriving instance MonadIO m =>     MonadIO     (VerbListenerT z r m)+deriving instance                  MonadTrans  (VerbListenerT z r)   get :: (Monad m) =>        FileExtListenerT Response m a-    -> VerbListenerT Response m ()+    -> VerbListenerT z Response m () get flistener = do-  (fileexts :: FileExts Response) <--      lift $ execWriterT $ runFileExtListenerT flistener-  let new = foldrWithKey (\k -> insert (k, Get)) empty $ unFileExts fileexts+  (fileexts :: FileExts Response) <- lift $ execWriterT $+                                     runFileExtListenerT flistener+  let new = singleton Get (Nothing, fileexts)+  VerbListenerT $ tell $ Verbs new -  VerbListenerT $ tell $ Verbs $ new --- post :: MonadIO m =>---         (ByteString -> m ())---      -> FileExtListener ()---      -> VerbListener ()--- post fl =---   VerbListener $ tell $---     Verbs [(Post, fl)]------ put :: MonadIO m =>---        (ByteString -> m ())---     -> FileExtListener ()---     -> VerbListener ()--- put fl =---   VerbListener $ tell $---     Verbs [(Put, fl)]+post :: (Monad m, MonadIO m) =>+        (BL.ByteString -> z)+     -> FileExtListenerT Response m a+     -> VerbListenerT z Response m ()+post handle flistener = do+  (fileexts :: FileExts Response) <- lift $ execWriterT $+                                     runFileExtListenerT flistener+  let new = singleton Post (Just handle, fileexts)+  VerbListenerT $ tell $ Verbs new --- delete :: (Monad m) =>---           FileExtListenerT m ()---        -> VerbListenerT m ()--- delete fl =---   VerbListenerT $ tell $---     Verbs [(Post, fl)]++put :: (Monad m, MonadIO m) =>+       (BL.ByteString -> z)+    -> FileExtListenerT Response m a+    -> VerbListenerT z Response m ()+put handle flistener = do+  (fileexts :: FileExts Response) <- lift $ execWriterT $+                                     runFileExtListenerT flistener+  let new = singleton Put (Just handle, fileexts)+  VerbListenerT $ tell $ Verbs new++delete :: (Monad m) =>+          FileExtListenerT Response m a+       -> VerbListenerT z Response m ()+delete flistener = do+  (fileexts :: FileExts Response) <- lift $ execWriterT $+                                     runFileExtListenerT flistener+  let new = singleton Delete (Nothing, fileexts)+  VerbListenerT $ tell $ Verbs new