diff --git a/nested-routes.cabal b/nested-routes.cabal --- a/nested-routes.cabal +++ b/nested-routes.cabal @@ -1,11 +1,103 @@ Name: nested-routes -Version: 0.2.2.2 +Version: 0.3 Author: Athan Clark Maintainer: Athan Clark 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/ + -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 + & + , but we + can also embed + + 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 diff --git a/src/Web/Routes/Nested.hs b/src/Web/Routes/Nested.hs --- a/src/Web/Routes/Nested.hs +++ b/src/Web/Routes/Nested.hs @@ -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 diff --git a/src/Web/Routes/Nested/FileExtListener.hs b/src/Web/Routes/Nested/FileExtListener.hs --- a/src/Web/Routes/Nested/FileExtListener.hs +++ b/src/Web/Routes/Nested/FileExtListener.hs @@ -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 diff --git a/src/Web/Routes/Nested/Types.hs b/src/Web/Routes/Nested/Types.hs --- a/src/Web/Routes/Nested/Types.hs +++ b/src/Web/Routes/Nested/Types.hs @@ -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) diff --git a/src/Web/Routes/Nested/Types/UrlChunks.hs b/src/Web/Routes/Nested/Types/UrlChunks.hs --- a/src/Web/Routes/Nested/Types/UrlChunks.hs +++ b/src/Web/Routes/Nested/Types/UrlChunks.hs @@ -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 diff --git a/src/Web/Routes/Nested/VerbListener.hs b/src/Web/Routes/Nested/VerbListener.hs --- a/src/Web/Routes/Nested/VerbListener.hs +++ b/src/Web/Routes/Nested/VerbListener.hs @@ -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