nested-routes 5.0.0 → 6.0.0

raw patch · 8 files changed

+216/−234 lines, 8 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• examples/Main.hs +18/−22
• examples/STM.hs +18/−23
• examples/STM/Auth.hs +33/−31
• nested-routes.cabal +1/−1
• src/Web/Routes/Nested.hs +75/−105
• src/Web/Routes/Nested/Types.hs +5/−17
• src/Web/Routes/Nested/Types/UrlChunks.hs +48/−17
• test/Web/Routes/NestedSpec/Basic.hs +18/−18

@@ -22,20 +22,19 @@ data AuthErr = NeedsAuth deriving (Show, Eq)  -- | If you fail here and throw an AuthErr, then the user was not authorized to--- under the conditions set by @ss :: [AuthRole]@, and based on the authentication--- of that user's session from the @Request@ object. Note that we could have a--- shared cache of authenticated sessions, by adding more constraints on @m@ like+-- under the conditions set by @ss :: [AuthRole]@, and based o_n the authentication+-- o_f that user's session from the @Request@ o_bject. Note that we could have a+-- shared cache o_f authenticated sessions, by adding more constraints o_n @m@ like -- @MonadIO@. -- For instance, even if there are [] auth roles, we could still include a header/timestamp--- pair to uniquely identify the guest. Or, we could equally change @Checksum ~ Maybe Token@,+-- pair to uniquely identify the guest. o_r, we could equally change @Checksum ~ Maybe Token@, -- so a guest just returns Nothing, and we could handle the case in @putAuth@ to -- not do anything. authorize :: ( Monad m-             , MonadError AuthErr m-             ) => Request -> [AuthRole] -> m (Response -> Response)+             ) => Request -> [AuthRole] -> m (Response -> Response, Maybe AuthErr) -- authorize _ _ = return id -- uncomment to force constant authorization-authorize req ss | null ss   = return id-                 | otherwise = throwError NeedsAuth+authorize req ss | null ss   = return (id, Nothing)+                 | otherwise = return (id, Just NeedsAuth)  defApp :: Application defApp _ respond = respond $ textOnlyStatus status404 "404 :("@@ -43,39 +42,36 @@ main :: IO () main =   let app = routeActionAuth authorize routes-      routes =-        handleAction o (Just rootHandle) $ Just $ do-          handleAction fooRoute (Just fooHandle) $ Just $ do-            auth AuthRole unauthHandle ProtectChildren-            handleAction barRoute    (Just barHandle)    Nothing-            handleAction doubleRoute (Just doubleHandle) Nothing-          handleAction emailRoute (Just emailHandle) Nothing-          handleAction bazRoute (Just bazHandle) Nothing-          notFoundAction o (Just notFoundHandle) Nothing+      routes = do+        hereAction rootHandle+        parent ("foo" </> o_) $ do+          hereAction fooHandle+          auth AuthRole unauthHandle DontProtectHere+          handleAction ("bar" </> o_) barHandle+          handleAction (p_ ("double", double) </> o_) doubleHandle+        handleAction emailRoute emailHandle+        handleAction ("baz" </> o_) bazHandle+        notFoundAction notFoundHandle   in run 3000 $ app defApp   where     rootHandle = get $ text "Home"      -- `/foo`-    fooRoute = l "foo" </> o     fooHandle = get $ text "foo!"      -- `/foo/bar`-    barRoute = l "bar" </> o     barHandle = get $ do       text "bar!"       json ("json bar!" :: LT.Text)      -- `/foo/1234e12`, uses attoparsec-    doubleRoute = p ("double", double) </> o     doubleHandle d = get $ text $ LT.pack (show d) <> " foos"      -- `/athan@foo.com`-    emailRoute = r ("email", mkRegex "(^[-a-zA-Z0-9_.]+@[-a-zA-Z0-9]+\\.[-a-zA-Z0-9.]+$)") </> o+    emailRoute = r_ ("email", mkRegex "(^[-a-zA-Z0-9_.]+@[-a-zA-Z0-9]+\\.[-a-zA-Z0-9.]+$)") </> o_     emailHandle e = get $ text $ LT.pack (show e) <> " email"      -- `/baz`, uses regex-compat-    bazRoute = l "baz" </> o     bazHandle = do       get $ text "baz!"       let uploader req = do liftIO $ print =<< strictRequestBody req

@@ -22,12 +22,10 @@ import qualified Data.ByteString as BS import qualified Data.IntMap as IntMap import Data.ByteArray (convert)-import Data.Function.Syntax  import Control.Concurrent.STM import Control.Error.Util-import Control.Monad.Error.Class-import Control.Monad.IO.Class+import Control.Monad.Except import Control.Monad.Reader import Control.Monad.Trans.Maybe import Crypto.Random@@ -47,43 +45,42 @@              let n' = hash n :: Digest SHA512                  n'' = convert n' :: BS.ByteString              return n''-  let app a r1 r2 = runReaderT (routeActionAuth authenticate routes (liftIO .* a) r1 r2) $ AuthEnv cacheVar uIdVar salt+  let routedApp app req resp = runReaderT (routeActionAuth authenticate routes app req resp) $ AuthEnv cacheVar uIdVar salt       routes = do-        handleAction o (Just rootHandle) Nothing-        handleAction fooRoute (Just fooHandle) $ Just $ do-          auth ShouldBeLoggedIn unauthHandle ProtectChildren-          handleAction barRoute    (Just barHandle)    Nothing-          handleAction doubleRoute (Just doubleHandle) Nothing-        handleAction emailRoute (Just emailHandle) Nothing-        handleAction bazRoute (Just bazHandle) Nothing-        handleAction loginRoute (Just loginHandle) Nothing-        handleAction logoutRoute (Just logoutHandle) $ Just $-          auth ShouldBeLoggedIn unauthHandle ProtectParent-        notFoundAction o (Just notFoundHandle) Nothing-  run 3000 $ app defApp+        hereAction rootHandle+        parent ("foo" </> o_) $ do+          hereAction fooHandle+          auth ShouldBeLoggedIn unauthHandle DontProtectHere+          handleAction ("bar" </> o_) barHandle+          handleAction doubleRoute doubleHandle+        handleAction emailRoute emailHandle+        handleAction ("baz" </> o_) bazHandle+        handleAction ("login" </> o_) loginHandle+        parent ("logout" </> o_) $ do+          hereAction logoutHandle+          auth ShouldBeLoggedIn unauthHandle ProtectHere+        notFoundAction notFoundHandle+  run 3000 $ routedApp $ liftApplication defApp   where     rootHandle = get $ text "Home"      -- `/foo`-    fooRoute = l "foo" </> o     fooHandle = get $ text "foo!"      -- `/foo/bar`-    barRoute = l "bar" </> o     barHandle = get $ do       text "bar!"       json ("json bar!" :: LT.Text)      -- `/foo/1234e12`-    doubleRoute = p ("double", double) </> o+    doubleRoute = p_ ("double", double) </> o_     doubleHandle d = get $ text $ LT.pack (show d) <> " foos"      -- `/athan@foo.com`-    emailRoute = r ("email", mkRegex "(^[-a-zA-Z0-9_.]+@[-a-zA-Z0-9]+\\.[-a-zA-Z0-9.]+$)") </> o+    emailRoute = r_ ("email", mkRegex "(^[-a-zA-Z0-9_.]+@[-a-zA-Z0-9]+\\.[-a-zA-Z0-9.]+$)") </> o_     emailHandle e = get $ text $ LT.pack (show e) <> " email"      -- `/baz`-    bazRoute = l "baz" </> o     bazHandle = do       get $ text "baz!"       let uploader req = do liftIO $ print =<< strictRequestBody req@@ -94,7 +91,6 @@           -- Hidden flaw ^ UserSession & LoginError are only options       post uploader uploadHandle -    loginRoute = "login" </> o     loginHandle = do       get $ lucid loginPage       postReq (login 128) loginResp@@ -124,7 +120,6 @@         firstIs f (x:_) = f x  -    logoutRoute = "logout" </> o     logoutHandle = getReq $ \req -> do       resp <- case getUserSession $ requestHeaders req of         Nothing -> return "no session :s"

@@ -6,43 +6,30 @@ module STM.Auth where  import Network.Wai.Trans-import Network.Wai.Handler.Warp-import Network.Wai.Session import Network.HTTP.Types-import Web.Routes.Nested import Web.Cookie import Data.Attoparsec.Text-import Text.Regex import Data.Monoid import qualified Data.Text as T import qualified Data.Text.Encoding as T-import qualified Data.Text.Lazy as LT import qualified Data.ByteString as BS import qualified Data.ByteString.Base64 as BS import Blaze.ByteString.Builder (toByteString) import qualified Data.IntMap as IntMap-import Data.ByteString.UTF8 (fromString, toString)+import Data.ByteString.UTF8 (fromString) import Data.ByteArray (convert) import Data.Time import Data.Time.ISO8601 import Data.Maybe-import Data.Default  import Control.Concurrent.STM-import Control.Monad.STM-import Control.Monad.Error.Class import Control.Error.Util import Control.Monad.Except-import Control.Monad.IO.Class import Control.Monad.Reader-import Control.Monad-import Crypto.Random-import Crypto.Random.Types+import Control.Monad.State import Crypto.Hash -import Debug.Trace - -- | @sec@ data SecurityLayer = ShouldBeLoggedIn                    | ShouldBeModerator@@ -190,36 +177,51 @@   authenticate :: ( MonadIO m-                , MonadError AuthenticationError m                 , MonadReader AuthEnv m-                ) => Request -> [SecurityLayer] -> m (Response -> Response)-authenticate _ [] = return id-authenticate req _ = do+                ) => Request -> [SecurityLayer] -> m (Response -> Response, Maybe AuthenticationError)+authenticate _ [] = return (id, Nothing)+authenticate req _ = flip runStateT Nothing $ do   liftIO $ putStrLn "<!> Auth Attempt <!>"   liftIO $ putStrLn "--- Headers ----------- \n" >> print (requestHeaders req) >> putStrLn "\n"-  userSession        <- note' NoSessionHeaders $ getUserSession $ requestHeaders req-  userSessionIsValid <- checkUserSession userSession+  let mUserSession = getUserSession $ requestHeaders req+  put $ Just NoSessionHeaders <* mUserSession+  maybe (return id) hasUserSession mUserSession++hasUserSession userSession = do   liftIO $ putStrLn "--- User Session ------ \n" >> print userSession >> putStrLn "\n"   cacheKey <- authEnvCache <$> ask   cache <- liftIO $ readTVarIO cacheKey   liftIO $ putStrLn "--- Cache ------------- \n" >> print cache >> putStrLn "\n"-  mCachedSession     <- lookupUserSession (userSessID userSession)-  (UserSession i cachedTime cachedNonce) <- note' SessionNotInCache mCachedSession-  newUserSess'       <- newUserSession+  mCachedSession <- lookupUserSession (userSessID userSession)+  put $ Just SessionNotInCache <* mCachedSession+  maybe (return id) (hasCachedSession userSession) mCachedSession++hasCachedSession userSession (UserSession i cachedTime cachedNonce) = do+  newUserSess' <- newUserSession   let newUserSess = newUserSess' {userSessID = i}+  userSessionIsValid <- checkUserSession userSession   case () of-    () | diffUTCTime (userSessTime newUserSess) cachedTime >= 60 -> do deleteUserSession i-                                                                       throwError SessionTimedOut-       | cachedNonce /= userSessNonce userSession -> throwError SessionMismatch-       | not userSessionIsValid                   -> throwError InvalidRequestNonce-       | otherwise -> do writeUserSession newUserSess-                         return $ mapResponseHeaders (++ makeSessionCookies newUserSess)-                                . clearSessionResponse+    () | diffUTCTime (userSessTime newUserSess) cachedTime >= 60 -> do+           deleteUserSession i+           put $ Just SessionTimedOut+           return id+       | cachedNonce /= userSessNonce userSession -> do+           put $ Just SessionMismatch+           return id+       | not userSessionIsValid -> do+           put $ Just InvalidRequestNonce+           return id+       | otherwise -> do+           writeUserSession newUserSess+           return $ mapResponseHeaders (++ makeSessionCookies newUserSess)+                      . clearSessionResponse  +note' :: MonadError e m => e -> Maybe a -> m a note' e mx = fromMaybe (throwError e) $ pure <$> mx  +insert :: Eq k => k -> a -> [(k,a)] -> [(k,a)] insert k v [] = [(k,v)] insert k v ((k',v'):xs) | k == k' = (k,v):xs                         | otherwise = (k',v'): insert k v xs

@@ -1,5 +1,5 @@ Name:                   nested-routes-Version:                5.0.0+Version:                6.0.0 Author:                 Athan Clark <athan.clark@gmail.com> Maintainer:             Athan Clark <athan.clark@gmail.com> License:                BSD3

@@ -78,6 +78,10 @@   -- * Combinators   , handle   , handleAction+  , here+  , hereAction+  , handleAny+  , handleAnyAction   , parent   , auth   , notFound@@ -120,7 +124,6 @@ import           Control.Monad import           Control.Monad.IO.Class import           Control.Monad.Trans-import           Control.Monad.Trans.Except import qualified Control.Monad.State                as S  @@ -170,68 +173,75 @@ -- it to a @MiddlewareT@. handleAction :: ( Monad m                 , Functor m-                , cleanxs ~ CatMaybes xs                 , HasResult childContent (ActionT ue u m ())-                , HasResult childErr     (e -> ActionT ue u m ())-                , ExpectArity cleanxs childContent-                , ExpectArity cleanxs childSec-                , ExpectArity cleanxs childErr+                , HasResult err          (e -> ActionT ue u m ())                 , Singleton (UrlChunks xs)                     childContent                     (RootedPredTrie T.Text resultContent)-                , ExtrudeSoundly cleanxs xs childContent resultContent-                , ExtrudeSoundly cleanxs xs childSec     resultSec-                , ExtrudeSoundly cleanxs xs childErr     resultErr+                , cleanxs ~ CatMaybes xs+                , ArityTypeListIso childContent cleanxs resultContent                 ) => UrlChunks xs-                  -> Maybe childContent-                  -> Maybe (HandlerT childContent  childSec  childErr  (e,u,ue) m ())-                  ->        HandlerT resultContent resultSec resultErr (e,u,ue) m ()-handleAction ts (Just vl) Nothing = tell' (singleton ts vl, mempty, mempty, mempty)-handleAction ts mvl (Just cs) = do-  (RootedPredTrie _ trieContent,trieNotFound,trieSec,trieErr) <- lift $ execHandlerT cs-  tell' ( extrude ts $ RootedPredTrie mvl trieContent-        , extrude ts trieNotFound-        , extrude ts trieSec-        , extrude ts trieErr-        )-handleAction _ Nothing Nothing = return ()+                  -> childContent+                  -> HandlerT resultContent sec err (e,u,ue) m ()+handleAction ts vl = tell' (singleton ts vl, mempty, mempty, mempty) + -- | Embed a @MiddlewareT@ into a set of routes. handle :: ( Monad m           , Functor m-          , cleanxs ~ CatMaybes xs           , HasResult childContent (MiddlewareT m)-          , HasResult childErr     (e -> MiddlewareT m)-          , ExpectArity cleanxs childContent-          , ExpectArity cleanxs childSec-          , ExpectArity cleanxs childErr+          , HasResult err     (e -> MiddlewareT m)           , Singleton (UrlChunks xs)               childContent               (RootedPredTrie T.Text resultContent)-          , ExtrudeSoundly cleanxs xs childContent resultContent-          , ExtrudeSoundly cleanxs xs childSec     resultSec-          , ExtrudeSoundly cleanxs xs childErr     resultErr+          , cleanxs ~ CatMaybes xs+          , ArityTypeListIso childContent cleanxs resultContent           ) => UrlChunks xs-            -> Maybe childContent-            -> Maybe (HandlerT childContent  childSec  childErr  (e,u,ue) m ())-            ->        HandlerT resultContent resultSec resultErr (e,u,ue) m ()-handle ts (Just vl) Nothing = tell' (singleton ts vl, mempty, mempty, mempty)-handle ts mvl (Just cs) = do-  (RootedPredTrie _ trieContent,trieNotFound,trieSec,trieErr) <- lift $ execHandlerT cs-  tell' ( extrude ts $ RootedPredTrie mvl trieContent-        , extrude ts trieNotFound-        , extrude ts trieSec-        , extrude ts trieErr-        )-handle _ Nothing Nothing = return ()+            -> childContent+            -> HandlerT resultContent sec err (e,u,ue) m ()+handle ts vl = tell' (singleton ts vl, mempty, mempty, mempty) ++hereAction :: ( Monad m+              , Functor m+              , HasResult content (ActionT ue u m ())+              , HasResult err     (e -> ActionT ue u m ())+              ) => content+                -> HandlerT content sec err (e,u,ue) m ()+hereAction = handleAction origin_++-- | Create a handle for the present route - an alias for @\h -> handle o (Just h)@.+here :: ( Monad m+        , Functor m+        , HasResult content (MiddlewareT m)+        , HasResult err     (e -> MiddlewareT m)+        ) => content+          -> HandlerT content sec err (e,u,ue) m ()+here = handle origin_+++handleAnyAction :: ( Monad m+                   , Functor m+                   , HasResult content (ActionT ue u m ())+                   , HasResult err     (e -> ActionT ue u m ())+                   ) => content+                     -> HandlerT content sec err (e,u,ue) m ()+handleAnyAction vl = tell' (mempty, singleton origin_ vl, mempty, mempty)++-- | Match against any route, as a last resort against all failing @handle@s.+handleAny :: ( Monad m+             , Functor m+             , HasResult content (MiddlewareT m)+             , HasResult err     (e -> MiddlewareT m)+             ) => content+               -> HandlerT content sec err (e,u,ue) m ()+handleAny vl = tell' (mempty, singleton origin_ vl, mempty, mempty)++ -- | Prepend a path to an existing set of routes. parent :: ( Monad m           , Functor m           , cleanxs ~ CatMaybes xs-          , Singleton (UrlChunks xs)-              childContent-              (RootedPredTrie T.Text resultContent)           , ExtrudeSoundly cleanxs xs childContent resultContent           , ExtrudeSoundly cleanxs xs childSec     resultSec           , ExtrudeSoundly cleanxs xs childErr     resultErr@@ -250,7 +260,7 @@ -- | Designate the scope of security to the set of routes - either only the adjacent -- routes, or the adjacent /and/ the parent container node (root node if not -- declared).-data AuthScope = ProtectParent | ProtectChildren+data AuthScope = ProtectHere | DontProtectHere   deriving (Show, Eq)  -- | Sets the security role and error handler for a set of routes, optionally@@ -273,62 +283,23 @@ -- it to a @MiddlewareT@. notFoundAction :: ( Monad m                   , Functor m-                  , cleanxs ~ CatMaybes xs-                  , HasResult childContent (ActionT ue u m ())-                  , HasResult childErr     (e -> ActionT ue u m ())-                  , ExpectArity cleanxs childContent-                  , ExpectArity cleanxs childSec-                  , ExpectArity cleanxs childErr-                  , Singleton (UrlChunks xs)-                      childContent-                      (RootedPredTrie T.Text resultContent)-                  , ExtrudeSoundly cleanxs xs childContent resultContent-                  , ExtrudeSoundly cleanxs xs childSec     resultSec-                  , ExtrudeSoundly cleanxs xs childErr     resultErr-                  ) => UrlChunks xs-                    -> Maybe childContent-                    -> Maybe (HandlerT childContent  childSec  childErr  (e,u,ue) m ())-                    ->        HandlerT resultContent resultSec resultErr (e,u,ue) m ()-notFoundAction ts (Just vl) Nothing = tell' (mempty, singleton ts vl, mempty, mempty)-notFoundAction ts mvl (Just cs) = do-  (trieContent,RootedPredTrie _ trieNotFound,trieSec,trieErr) <- lift $ execHandlerT cs-  tell' ( extrude ts trieContent-        , extrude ts $ RootedPredTrie mvl trieNotFound-        , extrude ts trieSec-        , extrude ts trieErr-        )-notFoundAction _ Nothing Nothing = return ()+                  , HasResult content (ActionT ue u m ())+                  , HasResult err     (e -> ActionT ue u m ())+                  ) => content+                    -> HandlerT content sec err (e,u,ue) m ()+notFoundAction = handleAnyAction  -- | Embed a @MiddlewareT@ as a not-found handler into a set of routes. notFound :: ( Monad m             , Functor m-            , cleanxs ~ CatMaybes xs-            , HasResult childContent (MiddlewareT m)-            , HasResult childErr     (e -> MiddlewareT m)-            , ExpectArity cleanxs childContent-            , ExpectArity cleanxs childSec-            , ExpectArity cleanxs childErr-            , Singleton (UrlChunks xs)-                childContent-                (RootedPredTrie T.Text resultContent)-            , ExtrudeSoundly cleanxs xs childContent resultContent-            , ExtrudeSoundly cleanxs xs childSec     resultSec-            , ExtrudeSoundly cleanxs xs childErr     resultErr-            ) => UrlChunks xs-              -> Maybe childContent-              -> Maybe (HandlerT childContent  childSec  childErr  (e,u,ue) m ())-              ->        HandlerT resultContent resultSec resultErr (e,u,ue) m ()-notFound ts (Just vl) Nothing = tell' (mempty, singleton ts vl, mempty, mempty)-notFound ts mvl (Just cs) = do-  (trieContent,RootedPredTrie _ trieNotFound,trieSec,trieErr) <- lift $ execHandlerT cs-  tell' ( extrude ts trieContent-        , extrude ts $ RootedPredTrie mvl trieNotFound-        , extrude ts trieSec-        , extrude ts trieErr-        )-notFound _ Nothing Nothing = return ()+            , HasResult content (MiddlewareT m)+            , HasResult err     (e -> MiddlewareT m)+            ) => content+              -> HandlerT content sec err (e,u,ue) m ()+notFound = handleAny  + -- * Routing ---------------------------------------  -- | Turns a @HandlerT@ containing @MiddlewareT@s into a @MiddlewareT@.@@ -346,7 +317,7 @@ routeAuth :: ( Functor m              , Monad m              , MonadIO m-             ) => (Request -> [sec] -> ExceptT e m (Response -> Response)) -- ^ authorize+             ) => (Request -> [sec] -> m (Response -> Response, Maybe e)) -- ^ authorize                -> RoutableT sec e u ue m () -- ^ Assembled @handle@ calls                -> MiddlewareT m routeAuth authorize hs = extractAuth authorize hs . route hs@@ -364,7 +335,7 @@ routeActionAuth :: ( Functor m                    , Monad m                    , MonadIO m-                   ) => (Request -> [sec] -> ExceptT e m (Response -> Response)) -- ^ authorize+                   ) => (Request -> [sec] -> m (Response -> Response, Maybe e)) -- ^ authorize                      -> RoutableActionT sec e u ue m () -- ^ Assembled @handle@ calls                      -> MiddlewareT m routeActionAuth authorize = routeAuth authorize . actionToMiddleware@@ -414,25 +385,24 @@   (_,_,trie,_) <- execHandlerT hs   return $ foldl go [] (PT.matchesRPT (pathInfo req) trie)   where-    go ys (_,(_,ProtectChildren),[]) = ys+    go ys (_,(_,DontProtectHere),[]) = ys     go ys (_,(x,_              ),_ ) = ys ++ [x]  -- | Extracts only the security handling logic into a @MiddlewareT@. extractAuth :: ( Functor m                , Monad m                , MonadIO m-               ) => (Request -> [sec] -> ExceptT e m (Response -> Response)) -- authorization method+               ) => (Request -> [sec] -> m (Response -> Response, Maybe e)) -- authorization method                  -> HandlerT x (sec, AuthScope) (e -> MiddlewareT m) aux m a                  -> MiddlewareT m extractAuth authorize hs app req respond = do   (_,_,_,trie) <- execHandlerT hs   ss <- extractAuthSym hs req-  ef <- runExceptT $ authorize req ss-  either (\e -> maybe (app req respond)-                      (\mid -> mid app req respond)-                    $ (getResultsFromMatch <$> PT.matchRPT (pathInfo req) trie) <$~> e)-         (\f -> app req (respond . f))-         ef+  (f,me) <- authorize req ss+  fromMaybe (app req (respond . f)) $ do+    e <- me+    (_,mid,_) <- PT.matchRPT (pathInfo req) trie+    return $ mid e app req (respond . f)  -- | Extracts only the @notFound@ responses into a @MiddlewareT@. extractNotFound :: ( Functor m

@@ -41,13 +41,13 @@  -- Basis instance Singleton (UrlChunks '[]) a (RootedPredTrie T.Text a) where-  singleton Root r' = RootedPredTrie (Just r') emptyPT+  singleton Root r = RootedPredTrie (Just r) emptyPT  -- Successor instance ( Singleton (UrlChunks xs) a trie0          , Extend (EitherUrlChunk x) trie0 trie1          ) => Singleton (UrlChunks (x ': xs)) a trie1 where-  singleton (Cons u us) r' = extend u (singleton us r')+  singleton (Cons u us) r = extend u (singleton us r)   -- | Turn a list of tries (@Rooted@) into a node with those children@@ -62,9 +62,7 @@ -- | Existentially quantified case instance Extend (EitherUrlChunk ('Just r)) (RootedPredTrie T.Text (r -> a)) (RootedPredTrie T.Text a) where   extend ((:~) (i,q)) (RootedPredTrie mx xs) = RootedPredTrie Nothing $-    PredTrie mempty $ PredSteps [PredStep i (eitherToMaybe . parseOnly q) mx xs]-  extend ((:*) (i,q)) (RootedPredTrie mx xs) = RootedPredTrie Nothing $-    PredTrie mempty $ PredSteps [PredStep i (matchRegex q . T.unpack) mx xs]+    PredTrie mempty (PredSteps [PredStep i q mx xs])   -- | @FoldR Extend start chunks ~ result@@@ -73,20 +71,10 @@  -- Basis instance Extrude (UrlChunks '[]) (RootedPredTrie T.Text a) (RootedPredTrie T.Text a) where-  extrude Root r' = r'+  extrude Root r = r  -- Successor instance ( Extrude (UrlChunks xs) trie0 trie1          , Extend (EitherUrlChunk x) trie1 trie2 ) => Extrude (UrlChunks (x ': xs)) trie0 trie2 where-  extrude (Cons u us) r' = extend u (extrude us r')---eitherToMaybe :: Either String r -> Maybe r-eitherToMaybe (Right r') = Just r'-eitherToMaybe _         = Nothing+  extrude (Cons u us) r = extend u (extrude us r) --- restAreLits :: UrlChunks xs -> Bool--- restAreLits Root = False--- restAreLits (Cons ((:=) _) Root) = True--- restAreLits (Cons ((:=) _) us)   = restAreLits us--- restAreLits (Cons _ _) = False

@@ -6,7 +6,22 @@   , DataKinds   #-} -module Web.Routes.Nested.Types.UrlChunks where+module Web.Routes.Nested.Types.UrlChunks+  ( -- * Path Combinators+    o_+  , origin_+  , l_+  , literal_+  , p_+  , parse_+  , r_+  , regex_+  , pred_+  , (</>)+  , -- * Path Types+    EitherUrlChunk (..)+  , UrlChunks (..)+  ) where  import Data.Attoparsec.Text import Text.Regex@@ -16,31 +31,42 @@  -- | Constrained to AttoParsec, Regex-Compat and T.Text data EitherUrlChunk (x :: Maybe *) where-  (:=) :: T.Text             -> EitherUrlChunk 'Nothing-  (:~) :: (T.Text, Parser r) -> EitherUrlChunk ('Just r)-  (:*) :: (T.Text, Regex)    -> EitherUrlChunk ('Just [String])+  (:=) :: T.Text                      -> EitherUrlChunk 'Nothing+  (:~) :: (T.Text, T.Text -> Maybe r) -> EitherUrlChunk ('Just r)  -- | Use raw strings instead of prepending @l@ instance x ~ 'Nothing => IsString (EitherUrlChunk x) where-  fromString = l . T.pack+  fromString = literal_ . T.pack +o_ = origin_+ -- | The /Origin/ chunk - the equivalent to @[]@-o :: UrlChunks '[]-o = Root+origin_ :: UrlChunks '[]+origin_ = Root +l_ = literal_+ -- | Match against a /Literal/ chunk-l :: T.Text -> EitherUrlChunk 'Nothing-l = (:=)+literal_ :: T.Text -> EitherUrlChunk 'Nothing+literal_ = (:=) --- | Match against a /Parsed/ chunk-p :: (T.Text, Parser r) -> EitherUrlChunk ('Just r)-p = (:~)+p_ = parse_ --- | Match against a /Regular expression/ chunk-r :: (T.Text, Regex) -> EitherUrlChunk ('Just [String])-r = (:*)+-- | Match against a /Parsed/ chunk, with <https://hackage.haskell.org/package/attoparsec attoparsec>.+parse_ :: (T.Text, Parser r) -> EitherUrlChunk ('Just r)+parse_ (i,q) = (:~) (i, eitherToMaybe . parseOnly q) --- | Glue two chunks together+r_ = regex_++-- | Match against a /Regular expression/ chunk, with <https://hackage.haskell.org/package/regex-compat regex-compat>.+regex_ :: (T.Text, Regex) -> EitherUrlChunk ('Just [String])+regex_ (i,q) = (:~) (i, matchRegex q . T.unpack)++-- | Match with a predicate against the url chunk directly.+pred_ :: (T.Text, T.Text -> Maybe r) -> EitherUrlChunk ('Just r)+pred_ = (:~)++-- | Prefix a routable path by more predicative lookup data. (</>) :: EitherUrlChunk mx -> UrlChunks xs -> UrlChunks (mx ': xs) (</>) = Cons @@ -49,4 +75,9 @@ -- | Container when defining route paths data UrlChunks (xs :: [Maybe *]) where   Cons :: EitherUrlChunk mx -> UrlChunks xs -> UrlChunks (mx ': xs) -- stack is left-to-right-  Root  :: UrlChunks '[]+  Root :: UrlChunks '[]+++eitherToMaybe :: Either String r -> Maybe r+eitherToMaybe (Right r') = Just r'+eitherToMaybe _         = Nothing

@@ -30,11 +30,10 @@ -- so a guest just returns Nothing, and we could handle the case in @putAuth@ to -- not do anything. authorize :: ( Monad m-             , MonadError AuthErr m-             ) => Request -> [AuthRole] -> m (Response -> Response)+             ) => Request -> [AuthRole] -> m (Response -> Response, Maybe AuthErr) -- authorize _ _ = return id -- uncomment to force constant authorization-authorize req ss | null ss   = return id-                 | otherwise = throwError NeedsAuth+authorize req ss | null ss   = return (id, Nothing)+                 | otherwise = return (id, Just NeedsAuth)  defApp :: Application defApp _ respond = respond $ textOnlyStatus status404 "404 :("@@ -42,39 +41,40 @@ app :: Application app =   let yoDawgIHeardYouLikeYoDawgsYo = routeActionAuth authorize routes-      routes =-        handleAction o (Just rootHandle) $ Just $ do-          handleAction fooRoute (Just fooHandle) $ Just $ do-            auth AuthRole unauthHandle ProtectChildren-            handleAction barRoute    (Just barHandle)    Nothing-            handleAction doubleRoute (Just doubleHandle) Nothing-          handleAction emailRoute (Just emailHandle) Nothing-          handleAction bazRoute (Just bazHandle) Nothing-          notFoundAction o (Just notFoundHandle) Nothing+      routes = do+        hereAction rootHandle+        parent fooRoute $ do+          hereAction fooHandle+          auth AuthRole unauthHandle DontProtectHere+          handleAction barRoute    barHandle+          handleAction doubleRoute doubleHandle+        handleAction emailRoute emailHandle+        handleAction bazRoute bazHandle+        notFoundAction notFoundHandle   in yoDawgIHeardYouLikeYoDawgsYo defApp   where     rootHandle = get $ text "Home"      -- `/foo`-    fooRoute = l "foo" </> o+    fooRoute = l_ "foo" </> o_     fooHandle = get $ text "foo!"      -- `/foo/bar`-    barRoute = l "bar" </> o+    barRoute = l_ "bar" </> o_     barHandle = get $ do       text "bar!"       json ("json bar!" :: LT.Text)      -- `/foo/1234e12`, uses attoparsec-    doubleRoute = p ("double", double) </> o+    doubleRoute = p_ ("double", double) </> o_     doubleHandle d = get $ text $ LT.pack (show d) <> " foos"      -- `/athan@foo.com`-    emailRoute = r ("email", mkRegex "(^[-a-zA-Z0-9_.]+@[-a-zA-Z0-9]+\\.[-a-zA-Z0-9.]+$)") </> o+    emailRoute = r_ ("email", mkRegex "(^[-a-zA-Z0-9_.]+@[-a-zA-Z0-9]+\\.[-a-zA-Z0-9.]+$)") </> o_     emailHandle e = get $ text $ LT.pack (show e) <> " email"      -- `/baz`, uses regex-compat-    bazRoute = l "baz" </> o+    bazRoute = l_ "baz" </> o_     bazHandle = do       get $ text "baz!"       let uploader req = do liftIO $ print =<< strictRequestBody req