diff --git a/examples/Main.hs b/examples/Main.hs --- a/examples/Main.hs +++ b/examples/Main.hs @@ -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 diff --git a/examples/STM.hs b/examples/STM.hs --- a/examples/STM.hs +++ b/examples/STM.hs @@ -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" diff --git a/examples/STM/Auth.hs b/examples/STM/Auth.hs --- a/examples/STM/Auth.hs +++ b/examples/STM/Auth.hs @@ -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 diff --git a/nested-routes.cabal b/nested-routes.cabal --- a/nested-routes.cabal +++ b/nested-routes.cabal @@ -1,5 +1,5 @@ Name: nested-routes -Version: 5.0.0 +Version: 6.0.0 Author: Athan Clark Maintainer: Athan Clark License: BSD3 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 @@ -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 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 @@ -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 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 @@ -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 . +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 . +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 diff --git a/test/Web/Routes/NestedSpec/Basic.hs b/test/Web/Routes/NestedSpec/Basic.hs --- a/test/Web/Routes/NestedSpec/Basic.hs +++ b/test/Web/Routes/NestedSpec/Basic.hs @@ -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