nested-routes 0.2.2.2 → 0.3

raw patch · 6 files changed

+262/−127 lines, 6 filesdep +constraintsdep +poly-aritydep ~basedep ~pred-triePVP ok

version bump matches the API change (PVP)

Dependencies added: constraints, poly-arity

Dependency ranges changed: base, pred-trie

API changes (from Hackage documentation)

Files

• nested-routes.cabal +98/−4
• src/Web/Routes/Nested.hs +138/−81
• src/Web/Routes/Nested/FileExtListener.hs +2/−2
• src/Web/Routes/Nested/Types.hs +9/−9
• src/Web/Routes/Nested/Types/UrlChunks.hs +1/−17
• src/Web/Routes/Nested/VerbListener.hs +14/−14

@@ -1,11 +1,103 @@ Name:                   nested-routes-Version:                0.2.2.2+Version:                0.3 Author:                 Athan Clark <athan.clark@gmail.com> Maintainer:             Athan Clark <athan.clark@gmail.com> License:                BSD3 License-File:           LICENSE Synopsis:               Declarative, compositional Wai responses--- Description:+Description:+  A method to writing Wai responses+  .+  This library attempts to make it easier to write nice Wai response handlers+  by giving us a Sinatra/+  <https://hackage.haskell.org/package/scotty Scotty>-like syntax for declaring HTTP-verb oriented+  routes, in addition to file-extension handling and rose-tree like composition.+  Not only do we have literal route specification, like+  <https://hackage.haskell.org/package/scotty Scotty> &+  <https://hackage.haskell.org/package/spock Spock>, but we+  can also embed+  <https://hackage.haskell.org/package/attoparsec Attoparsec>+  parsers /directly/ in our routes, with our handlers+  reflecting their results. As an example:+  .+  > router :: Application+  > router = route handlers+  >   where+  >     handlers = do+  >       handleLit o+  >         (Left $ get $ text "home")+  >         Nothing+  >       handleLit (l "foo" </> l "bar" </> o)+  >         (Left $ get $ text "foobar") $ Just $+  >         handleParse (p ("baz",double) </> o)+  >           (\d -> Right $ get $ textOnly $ LT.pack (show d) `LT.append` " bazs")+  >           Nothing+  >       handleParse (p ("num",double) </> o)+  >         (\d -> Right $ get $ textOnly $ LT.pack $ show d) $ Just $+  >         handleLit (l "bar" </> o)+  >            (\d -> Left $ get $ text $ (LT.pack $ show d) `LT.append` " bars")+  >            Nothing+  .+  The route specification syntax is a little strange right now - @l@ specifies+  a "literal chunk" of a handlable url (ie - @l \"foo\" \<\/\> l \"bar\" \<\/\> o@ would+  represent the url @\/foo\/bar@), while @p@ represents a "parsable" url chunk,+  which expects a pair - the left element being merely a reference name for the+  parser during internal plumbing, and the right being the actual @Parser@. @o@ represents+  the end of a url string, and can be used alone in a handler to capture requests+  to the root path.+  .+  Each route being handled needs some kind of content - that's where the @Either@+  stuff comes in to play. For every parsed url chunk, the route expects a function+  of arity matching 1-for-1 with the parsed contents. For example, @\d -> ...@ in the+  demonstration above is such a function, where @d :: Double@.+  .+  We use the @Either@ for a subtle reason - literal url strings may have a file+  extension, while url strings ending with a parser would not. @get@, @post@, etc.+  are all monadic expressions, accumulating a @Map@ for HTTP verbs, likewise with+  @text@, @lucid@, @json@, @bytestring@ etc., where they may also match a particular+  file extension. @textOnly@ and the other @-Only@ variants are not monadic, and+  simply give us a convenient unwrapper. Basically, url paths ending with a literal+  chunk are @Left@ and contain a @VerbListenerT z (FileExtListenerT Response m ()) m ()@,+  while paths ending with a parser are @Right@ and contain @VerbListenerT z Response m ()@.+  .+  When we test our application:+  .+  >  λ> curl localhost:3000/+  >  ↪ "home"+  .+  requests may end with index+  .+  >  λ> curl localhost:3000/index+  >  ↪ "home"+  .+  and specify the file extension+  .+  >  λ> curl localhost:3000/index.txt+  >  ↪ "home"+  .+  each responding with the "closest" available file type+  .+  >  λ> curl localhost:3000/index.html+  >  ↪ "home"+  .+  >  λ> curl localhost:3000/foo/bar+  >  ↪ "foobar"+  .+  >  λ> curl localhost:3000/foo/bar.txt+  >  ↪ "foobar"+  .+  >  λ> curl localhost:3000/foo/bar/5678.5678+  >  ↪ "5678.5678 bazs"+  .+  >  λ> curl localhost:3000/1234.1234+  >  ↪ "1234.1234"+  .+  >  λ> curl localhost:3000/2e5+  >  ↪ "200000.0"+  .+  >  λ> curl localhost:3000/1234.1234/bar+  >  ↪ "1234.1234 bars"+ Cabal-Version:          >= 1.10 Build-Type:             Simple @@ -18,13 +110,14 @@                         Web.Routes.Nested.Types.UrlChunks                         Web.Routes.Nested.VerbListener                         Web.Routes.Nested.FileExtListener-  Build-Depends:        base >= 4 && < 5+  Build-Depends:        base >= 4.6 && < 5                       , wai                       , wai-extra                       , http-types                       , mtl                       , transformers                       , semigroups+                      , constraints                       , containers                       , text                       , aeson@@ -32,7 +125,8 @@                       , lucid                       , bytestring                       , attoparsec-                      , pred-trie >= 0.0.8.1+                      , pred-trie >= 0.0.12+                      , poly-arity >= 0.0.3  Test-Suite spec   Type:                 exitcode-stdio-1.0

@@ -9,6 +9,13 @@   , DataKinds   , TupleSections   , FlexibleContexts+  , ConstraintKinds+  , DataKinds+  , KindSignatures+  , TypeFamilies+  , RankNTypes+  , PolyKinds+  , UndecidableInstances   #-}  module Web.Routes.Nested@@ -16,9 +23,11 @@   , module Web.Routes.Nested.VerbListener   , module Web.Routes.Nested.Types   , HandlerT (..)+  , EitherResponse   , handleLit   , handleParse-  , notFound+  , notFoundLit+  , notFoundParse   , route   ) where @@ -45,115 +54,163 @@ import qualified Data.Map.Lazy                     as M import qualified Data.ByteString.Lazy              as BL import           Data.Maybe                        (fromMaybe)+import           Data.Constraint -import Debug.Trace import Data.Trie.Pred.Unified-import Data.Trie.Pred.Unified.Tail-import Data.List (intercalate)+import Data.Function.Poly  -newtype HandlerT z m a = HandlerT-  { runHandler :: WriterT ( RUPTrie T.Text (Either (VerbListenerT z (FileExtListenerT Response m ()) m ()) (VerbListenerT z Response m ()))-                          , RUPTrie T.Text (Either (VerbListenerT z (FileExtListenerT Response m ()) m ()) (VerbListenerT z Response m ())) ) m a }+newtype HandlerT z x m a = HandlerT+  { runHandler :: WriterT ( RUPTrie T.Text x+                          , RUPTrie T.Text x ) m a }   deriving (Functor) -deriving instance Applicative m => Applicative (HandlerT z m)-deriving instance Monad m =>       Monad       (HandlerT z m)-deriving instance MonadIO m =>     MonadIO     (HandlerT z m)-instance MonadTrans (HandlerT z) where+deriving instance Applicative m => Applicative (HandlerT z x m)+deriving instance Monad m =>       Monad       (HandlerT z x m)+deriving instance MonadIO m =>     MonadIO     (HandlerT z x m)+instance MonadTrans (HandlerT z x) where   lift ma = HandlerT $ lift ma  +type EitherResponse z m = Either (VerbListenerT z (FileExtListenerT Response m ()) m ())+                                 (VerbListenerT z Response m ())++type family LastIsNothing (xs :: [Maybe *]) :: Constraint where+  LastIsNothing '[] = ()+  LastIsNothing ('Nothing ': '[]) = ()+  LastIsNothing (x ': xs) = LastIsNothing xs++type family LastIsJust (xs :: [Maybe *]) :: Constraint where+  LastIsJust (('Just x) ': '[]) = ()+  LastIsJust (x ': xs) = LastIsJust xs++-- | For routes ending with a literal. handleLit :: ( Monad m+             , Functor m+             , cleanxs ~ OnlyJusts xs+             , HasResult childType (EitherResponse z m)+             , ExpectArity cleanxs childType              , Singleton (UrlChunks xs)-                 (ExpectArity xs-                           (Either-                              (VerbListenerT z (FileExtListenerT Response m ()) m ())-                              (VerbListenerT z Response m ())))-                 (RUPTrie T.Text-                           (Either-                              (VerbListenerT z (FileExtListenerT Response m ()) m ())-                              (VerbListenerT z Response m ())))+                 childType+                 (RUPTrie T.Text result)              , Extrude (UrlChunks xs)-                 (RUPTrie T.Text-                           (Either-                              (VerbListenerT z (FileExtListenerT Response m ()) m ())-                              (VerbListenerT z Response m ())))-                 (RUPTrie T.Text-                           (Either-                              (VerbListenerT z (FileExtListenerT Response m ()) m ())-                              (VerbListenerT z Response m ())))+                 (RUPTrie T.Text childType)+                 (RUPTrie T.Text result)+             , (ArityMinusTypeList childType cleanxs) ~ result+             , childType ~ TypeListToArity cleanxs result+             , LastIsNothing xs              ) =>-             UrlChunks xs-          -> ExpectArity xs (Either (VerbListenerT z (FileExtListenerT Response m ()) m ()) (VerbListenerT z Response m ()))-          -> [HandlerT z m ()]-          -> HandlerT z m ()-handleLit ts vl [] =+             UrlChunks xs -- ^ Path to match against+          -> childType -- ^ Possibly a function, ending in @EitherResponse z m@+          -> Maybe (HandlerT z childType m ()) -- ^ Potential child routes+          -> HandlerT z result m ()+handleLit ts vl Nothing =   HandlerT $ tell (singleton ts vl, mempty)-handleLit ts vl cs = do-  (child,_) <- lift $ foldM (\acc c -> (acc <>) <$> (execWriterT $ runHandler c)) mempty cs+handleLit ts vl (Just cs) = do+  ((Rooted _ ctrie),_) <- lift $ execWriterT $ runHandler cs    HandlerT $ tell $ let-                      child' = extrude ts child+                      child = extrude ts $ Rooted (Just vl) ctrie                     in-                    (P.merge child' $ singleton ts vl, mempty)+                    (child, mempty) +-- | For routes ending with a parser. handleParse :: ( Monad m+               , Functor m+               , cleanxs ~ OnlyJusts xs+               , HasResult childType (EitherResponse z m)+               , ExpectArity cleanxs childType                , Singleton (UrlChunks xs)-                   (ExpectArity xs-                           (Either-                              (VerbListenerT z (FileExtListenerT Response m ()) m ())-                              (VerbListenerT z Response m ())))-                   (RUPTrie T.Text-                           (Either-                              (VerbListenerT z (FileExtListenerT Response m ()) m ())-                              (VerbListenerT z Response m ())))-              --  , Extrude (UrlChunks xs)-              --      (RUPTrie T.Text-              --              (ExpectArity xs (Either-              --                 (VerbListenerT z (FileExtListenerT Response m ()) m ())-              --                 (VerbListenerT z Response m ()))))-              --      (RUPTrie T.Text-              --              (Either-              --                 (VerbListenerT z (FileExtListenerT Response m ()) m ())-              --                 (VerbListenerT z Response m ())))+                   childType+                   (RUPTrie T.Text result)+               , Extrude (UrlChunks xs)+                   (RUPTrie T.Text childType)+                   (RUPTrie T.Text result)+               , (ArityMinusTypeList childType cleanxs) ~ result+               , childType ~ TypeListToArity cleanxs result+               , LastIsJust xs                ) =>                UrlChunks xs-            -> ExpectArity xs (Either (VerbListenerT z (FileExtListenerT Response m ()) m ()) (VerbListenerT z Response m ()))-            -- -> [HandlerT z m ()] TODO: Encode contained arity top-level? Can't poop the right butt atm-            -> HandlerT z m ()-handleParse ts vl =+            -> childType+            -> Maybe (HandlerT z childType m ())+            -> HandlerT z result m ()+handleParse ts vl Nothing =   HandlerT $ tell (singleton ts vl, mempty)--- handleParse ts vl cs = do---   (child,_) <- lift $ foldM (\acc c -> (acc <>) <$> (execWriterT $ runHandler c)) mempty cs------   HandlerT $ tell $ let---                       child' = extrude ts child---                     in---                     (P.merge child' $ singleton ts vl, mempty)+handleParse ts vl (Just cs) = do+  ((Rooted _ ctrie),_) <- lift $ execWriterT $ runHandler cs +  HandlerT $ tell $ let+                      child = extrude ts $ Rooted (Just vl) ctrie+                    in+                    (child, mempty) -notFound :: ( Monad m-            , Singleton (UrlChunks xs)-                (ExpectArity xs-                           (Either-                              (VerbListenerT z (FileExtListenerT Response m ()) m ())-                              (VerbListenerT z Response m ())))-                (RUPTrie T.Text-                           (Either-                              (VerbListenerT z (FileExtListenerT Response m ()) m ())-                              (VerbListenerT z Response m ())))-            ) =>-            UrlChunks xs-         -> ExpectArity xs (Either (VerbListenerT z (FileExtListenerT Response m ()) m ()) (VerbListenerT z Response m ()))-         -> HandlerT z m ()-notFound ts vl = do++notFoundLit :: ( Monad m+               , Functor m+               , cleanxs ~ OnlyJusts xs+               , HasResult childType (EitherResponse z m)+               , ExpectArity cleanxs childType+               , Singleton (UrlChunks xs)+                   childType+                   (RUPTrie T.Text result)+               , Extrude (UrlChunks xs)+                   (RUPTrie T.Text childType)+                   (RUPTrie T.Text result)+               , (ArityMinusTypeList childType cleanxs) ~ result+               , childType ~ TypeListToArity cleanxs result+               , LastIsNothing xs+               ) =>+               UrlChunks xs+            -> childType+            -> Maybe (HandlerT z childType m ())+            -> HandlerT z result m ()+notFoundLit ts vl Nothing = do   HandlerT $ tell (mempty, singleton ts vl)+notFoundLit ts vl (Just cs) = do+  ((Rooted _ ctrie),_) <- lift $ execWriterT $ runHandler cs +  HandlerT $ tell $ let+                      child = extrude ts $ Rooted (Just vl) ctrie+                    in+                    (mempty, child) ++notFoundParse :: ( Monad m+                 , Functor m+                 , cleanxs ~ OnlyJusts xs+                 , HasResult childType (EitherResponse z m)+                 , ExpectArity cleanxs childType+                 , Singleton (UrlChunks xs)+                     childType+                     (RUPTrie T.Text result)+                 , Extrude (UrlChunks xs)+                     (RUPTrie T.Text childType)+                     (RUPTrie T.Text result)+                 , (ArityMinusTypeList childType cleanxs) ~ result+                 , childType ~ TypeListToArity cleanxs result+                 , LastIsJust xs+                 ) =>+                 UrlChunks xs+              -> childType+              -> Maybe (HandlerT z childType m ())+              -> HandlerT z result m ()+notFoundParse ts vl Nothing = do+  HandlerT $ tell (mempty, singleton ts vl)+notFoundParse ts vl (Just cs) = do+  ((Rooted _ ctrie),_) <- lift $ execWriterT $ runHandler cs++  HandlerT $ tell $ let+                      child = extrude ts $ Rooted (Just vl) ctrie+                    in+                    (mempty, child)++ -- | Turns a @HandlerT@ into a Wai @Application@-route :: (Functor m, Monad m, MonadIO m) =>-         HandlerT z m a -- ^ Assembled @handle@ calls+route :: ( Functor m+         , Monad m+         , MonadIO m+         ) =>+         HandlerT z (EitherResponse z m) m a -- ^ Assembled @handle@ calls       -> Request       -> (Response -> IO ResponseReceived) -> m ResponseReceived route h req respond = do

@@ -114,7 +114,7 @@          L.HtmlT m () -> FileExtListenerT Response m () lucid i = do   i' <- lift $ L.renderBST i-  let r = responseLBS status200 [("Content-Type", "text/html")] $ i'+  let r = responseLBS status200 [("Content-Type", "text/html")] i'   FileExtListenerT $ tell $     FileExts $ singleton Html r @@ -122,7 +122,7 @@              L.HtmlT m () -> m Response lucidOnly i = do   i' <- L.renderBST i-  return $ responseLBS status200 [("Content-Type", "text/html")] $ i'+  return $ responseLBS status200 [("Content-Type", "text/html")] i'  builder :: (Monad m) =>            BU.Builder -> RequestHeaders

@@ -10,17 +10,18 @@   , OverlappingInstances   , MultiParamTypeClasses   , FunctionalDependencies+  , ConstraintKinds   #-}  module Web.Routes.Nested.Types   ( Singleton (..)   , Extend (..)   , Extrude (..)+  , OnlyJusts   , eitherToMaybe   , restAreLits   , ToNE (..)   , ToL (..)-  , ExpectArity   , module Web.Routes.Nested.Types.UrlChunks   ) where @@ -33,9 +34,14 @@ import           Data.List.NonEmpty import qualified Data.List.NonEmpty as NE import Data.Trie.Pred.Unified-import Data.Trie.Pred.Unified.Tail+import Data.Function.Poly  +type family OnlyJusts (xs :: [Maybe *]) :: [*] where+  OnlyJusts '[] = '[]+  OnlyJusts ('Nothing  ': xs) = OnlyJusts xs+  OnlyJusts (('Just x) ': xs) = x ': OnlyJusts xs+ class Singleton chunks a trie | chunks a -> trie where   singleton :: chunks -> a -> trie @@ -51,7 +57,7 @@ class Extend eitherUrlChunk child result | eitherUrlChunk child -> result where   extend :: eitherUrlChunk -> child -> result -instance Extend (EitherUrlChunk  'Nothing) (RUPTrie T.Text a)        (RUPTrie T.Text a) where+instance Extend (EitherUrlChunk  'Nothing) (RUPTrie T.Text a) (RUPTrie T.Text a) where   extend ((:=) t) (Rooted mx xs) = Rooted Nothing [UMore t mx xs]  instance Extend (EitherUrlChunk ('Just r)) (RUPTrie T.Text (r -> a)) (RUPTrie T.Text a) where@@ -97,10 +103,4 @@  instance ToL (UrlChunks xs) => ToL (UrlChunks ('Nothing ': xs)) where   toL (Cons ((:=) t) us) = t : toL us---type family ExpectArity (xs :: [Maybe *]) (r :: *) :: * where-  ExpectArity '[] r = r-  ExpectArity ('Nothing  ': xs) r = ExpectArity xs r-  ExpectArity (('Just x) ': xs) r = x -> (ExpectArity xs r) 

@@ -22,24 +22,8 @@  -- | Container when defining route paths data UrlChunks (xs :: [Maybe *]) where-  Cons :: EitherUrlChunk mx -> UrlChunks xs -> UrlChunks (mx ': xs) -- unpacks left-to-right+  Cons :: EitherUrlChunk mx -> UrlChunks xs -> UrlChunks (mx ': xs) -- stack is left-to-right   Root  :: UrlChunks '[]---- `foldChunks :: (forall mx. EitherUrlChunk mx -> acc -> acc) -> acc -> UrlChunks xs -> acc--- `foldChunks f i Root = i--- `foldChunks f i (Cons u us) = foldChunks f (f u i) us--- `--- `appendChunks :: UrlChunks xs -> UrlChunks ys -> UrlChunks (xs :++ ys)--- `appendChunks Root ys = ys--- `appendChunks (Cons x xs) ys = Cons x $ appendChunks xs ys--- `--- `lastChunk :: UrlChunks xs -> EitherUrlChunk (Last xs)--- `lastChunk (Cons u Root) = u--- `lastChunk (Cons u us)   = lastChunk us--- `--- `initChunks :: UrlChunks xs -> UrlChunks (Init xs)--- `initChunks (Cons u Root) = Root--- `initChunks (Cons u us)   = Cons u $ initChunks us  (</>) = Cons 

@@ -1,12 +1,12 @@-{-# LANGUAGE DeriveFunctor              #-}-{-# LANGUAGE DeriveTraversable          #-}-{-# LANGUAGE DeriveFoldable             #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE StandaloneDeriving         #-}-{-# LANGUAGE BangPatterns               #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE FunctionalDependencies     #-}+{-# LANGUAGE+    DeriveFunctor+  , DeriveTraversable+  , DeriveFoldable+  , GeneralizedNewtypeDeriving+  , ScopedTypeVariables+  , StandaloneDeriving+  , MultiParamTypeClasses+  #-}  module Web.Routes.Nested.VerbListener where @@ -52,7 +52,7 @@   foldMWithKey :: Monad m => (acc -> Verb -> a -> m acc) -> acc -> Map Verb a -> m acc-foldMWithKey f i map = foldlWithKey (\macc k a -> (\mer -> f mer k a) =<< macc) (return i) map+foldMWithKey f i = foldlWithKey (\macc k a -> (\mer -> f mer k a) =<< macc) (return i)   get :: (Monad m) =>@@ -68,7 +68,7 @@      -> a      -> VerbListenerT z a m () post handle r = do-  let new = singleton Post (Just $ (ReaderT handle, Nothing), r)+  let new = singleton Post (Just (ReaderT handle, Nothing), r)   VerbListenerT $ tell $ Verbs new  @@ -78,7 +78,7 @@         -> a         -> VerbListenerT z a m () postMax bl handle r = do-  let new = singleton Post (Just $ (ReaderT handle, Just bl), r)+  let new = singleton Post (Just (ReaderT handle, Just bl), r)   VerbListenerT $ tell $ Verbs new  @@ -87,7 +87,7 @@     -> a     -> VerbListenerT z a m () put handle r = do-  let new = singleton Put (Just $ (ReaderT handle, Nothing), r)+  let new = singleton Put (Just (ReaderT handle, Nothing), r)   VerbListenerT $ tell $ Verbs new  @@ -97,7 +97,7 @@        -> a        -> VerbListenerT z a m () putMax bl handle r = do-  let new = singleton Put (Just $ (ReaderT handle, Just bl), r)+  let new = singleton Put (Just (ReaderT handle, Just bl), r)   VerbListenerT $ tell $ Verbs new