diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/examples/Main.hs b/examples/Main.hs --- a/examples/Main.hs +++ b/examples/Main.hs @@ -2,6 +2,8 @@ OverloadedStrings , ScopedTypeVariables , FlexibleContexts + , DeriveDataTypeable + , DataKinds #-} @@ -12,74 +14,136 @@ import Network.Wai.Handler.Warp import Network.HTTP.Types import Text.Regex +import qualified Data.Text as T import qualified Data.Text.Lazy as LT -import Data.Attoparsec.Text +import Data.Attoparsec.Text hiding (match) import Data.Monoid -import Control.Monad.Except +import Data.Typeable +import Control.Monad.IO.Class +import Control.Monad.Catch -data AuthRole = AuthRole deriving (Show, Eq) -data AuthErr = NeedsAuth deriving (Show, Eq) +defApp :: Application +defApp _ respond = respond + $ textOnly "404 :(" status404 [] --- | If you fail here and throw an AuthErr, then the user was not authorized to --- 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. 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. +main :: IO () +main = run 3000 $ + (routeAuth authorize routes + `catchMiddlewareT` handleUploadError + `catchMiddlewareT` handleAuthError + ) defApp + where + handleUploadError u = fileExtsToMiddleware $ + overFileExts [Text] (mapStatus $ const status400) $ + case u of + NoChunkedBody -> text "No chunked body allowed!" + UploadTooLarge -> text "Upload too large" + + handleAuthError e = fileExtsToMiddleware $ + overFileExts [Text] (mapStatus $ const status400) $ + case e of + NeedsAuth -> text "Authentication needed" + +-- | A set of symbolic security roles +data AuthRole = AuthRole + deriving (Show, Eq) + +-- | The error thrown during authentication or authorization. +-- +-- I would encourage other security-related error schemes: +-- +-- - one data type for user authority errors - like when a logged-in user tries to access +-- the admin console +-- - one for types of failed authentication, during login (user doesn't exist, +-- incorrect password, etc.) +-- - one for malicious attacks - for instance if someone has tried (and failed) to login +-- 5 times in the last minute, or multiple requests to the same resource +data AuthError = NeedsAuth + deriving (Show, Eq, Typeable) + +instance Exception AuthError + +-- | Simple function that returns a response modification function - like +-- something that adds to the response headers - to maintain a session cookie, +-- for instance. +-- +-- You can use 'Control.Monad.Catch.throwM' to throw arbitrary errors, but +-- you should also catch them with 'Network.Wai.Trans.catchMiddlewareT' to +-- avoid runtime exceptions. authorize :: ( Monad m - ) => Request -> [AuthRole] -> m (Response -> Response, Maybe AuthErr) -authorize _ _ = return (id, Nothing) -- uncomment to force constant authorization --- authorize req ss | null ss = return (id, Nothing) --- | otherwise = return (id, Just NeedsAuth) + , MonadThrow m + ) => Request -> [AuthRole] -> m () +authorize req ss | null ss = return () + | otherwise = throwM NeedsAuth -defApp :: Application -defApp _ respond = respond $ textOnlyStatus status404 "404 :(" +-- | The error thrown during the uploading function +data UploadError = NoChunkedBody + | UploadTooLarge + deriving (Show, Typeable) -main :: IO () -main = - let app = routeActionAuth authorize routes - 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 +instance Exception UploadError + + +routes :: ( MonadIO m + , MonadThrow m + ) => HandlerT (MiddlewareT m) (SecurityToken AuthRole) m () +routes = do + matchHere (action rootHandle) + matchGroup (l_ "foo" o_) $ do + matchHere (action fooHandle) + auth AuthRole DontProtectHere + match (l_ "bar" o_) (action barHandle) + match (p_ "double" double o_) doubleHandle + match emailRoute emailHandle + match (l_ "baz" o_) (action bazHandle) + matchAny (action notFoundHandle) where - rootHandle = get $ text "Home" + rootHandle :: MonadIO m => ActionT m () + rootHandle = + get $ do + text "Home" + json ("Home" :: T.Text) -- `/foo` + fooHandle :: MonadIO m => ActionT m () fooHandle = get $ text "foo!" -- `/foo/bar` - barHandle = get $ do - text "bar!" - json ("json bar!" :: LT.Text) + barHandle :: MonadIO m => ActionT m () + barHandle = + get $ do + text "bar!" + json ("json bar!" :: T.Text) -- `/foo/1234e12`, uses attoparsec - doubleHandle d = get $ text $ LT.pack (show d) <> " foos" + doubleHandle :: MonadIO m => Double-> MiddlewareT m + doubleHandle d = action $ 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_ - emailHandle e = get $ text $ LT.pack (show e) <> " email" + emailRoute :: UrlChunks '[ 'Just [String] ] + emailRoute = r_ "email" (mkRegex "(^[-a-zA-Z0-9_.]+@[-a-zA-Z0-9]+\\.[-a-zA-Z0-9.]+$)") o_ - -- `/baz`, uses regex-compat + emailHandle :: MonadIO m => [String] -> MiddlewareT m + emailHandle e = action $ get $ text $ LT.pack (show e) <> " email" + + -- `/baz + bazHandle :: ( MonadIO m + , MonadThrow m + ) => ActionT m () bazHandle = do get $ text "baz!" - let uploader req = do liftIO $ print =<< strictRequestBody req - return () - uploadHandle (Left Nothing) = text "Upload Failed" - uploadHandle (Left (Just _)) = text "Impossible - no errors thrown in uploader" - uploadHandle (Right ()) = text "Woah! Upload content!" - post uploader uploadHandle + post uploader $ text "uploaded!" + where + uploader :: (MonadIO m, MonadThrow m) => Request -> m () + uploader req = + case requestBodyLength req of + ChunkedBody -> throwM NoChunkedBody + KnownLength l | l > 1024 -> throwM UploadTooLarge + | otherwise -> liftIO $ print =<< strictRequestBody req - unauthHandle NeedsAuth = get $ textStatus status401 "Unauthorized!" - notFoundHandle = get $ textStatus status404 "Not Found :(" + + notFoundHandle :: MonadIO m => ActionT m () + notFoundHandle = get $ + overFileExts [Text] (mapStatus $ const status400) $ + text "Not Found :(" diff --git a/examples/STM.hs b/examples/STM.hs deleted file mode 100644 --- a/examples/STM.hs +++ /dev/null @@ -1,137 +0,0 @@ -{-# LANGUAGE - OverloadedStrings - , ScopedTypeVariables - , FlexibleContexts - #-} - - -module Main where - -import STM.Auth -import STM.Templates - -import Network.Wai.Trans -import Network.Wai.Handler.Warp -import Network.Wai.Parse -import Network.HTTP.Types -import Web.Routes.Nested -import Data.Attoparsec.Text -import Text.Regex -import Data.Monoid -import qualified Data.Text.Lazy as LT -import qualified Data.ByteString as BS -import qualified Data.IntMap as IntMap -import Data.ByteArray (convert) - -import Control.Concurrent.STM -import Control.Error.Util -import Control.Monad.Except -import Control.Monad.Reader -import Control.Monad.Trans.Maybe -import Crypto.Random -import Crypto.Hash - - -data LoginError = InvalidLoginAttempt - -defApp :: Application -defApp _ respond = respond $ textOnlyStatus status404 "404 :(" - -main :: IO () -main = do - cacheVar <- newTVarIO IntMap.empty - uIdVar <- newTVarIO 0 - salt <- do (n :: BS.ByteString) <- liftIO $ getRandomBytes 256 - let n' = hash n :: Digest SHA512 - n'' = convert n' :: BS.ByteString - return n'' - let routedApp app req resp = runReaderT (routeActionAuth authenticate routes app req resp) $ AuthEnv cacheVar uIdVar salt - routes = do - 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` - fooHandle = get $ text "foo!" - - -- `/foo/bar` - barHandle = get $ do - text "bar!" - json ("json bar!" :: LT.Text) - - -- `/foo/1234e12` - 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_ - emailHandle e = get $ text $ LT.pack (show e) <> " email" - - -- `/baz` - bazHandle = do - get $ text "baz!" - let uploader req = do liftIO $ print =<< strictRequestBody req - return undefined - uploadHandle (Left Nothing) = text "Upload Failed" - uploadHandle (Left (Just _)) = text "Should never happen" - uploadHandle (Right _) = text "Woah! Upload content!" - -- Hidden flaw ^ UserSession & LoginError are only options - post uploader uploadHandle - - loginHandle = do - get $ lucid loginPage - postReq (login 128) loginResp - where - loginResp _ (Left Nothing) = textStatus status500 "Server malfunction :E" - loginResp _ (Left (Just InvalidLoginAttempt)) = textStatusWith clearSessionResponse status403 "Bad login" - loginResp _ (Right u) = textWith (mapResponseHeaders (++ makeSessionCookies u)) "logged-in" - - login s req = - case requestBodyLength req of - KnownLength b | b <= s -> do - (ps,_) <- liftIO $ parseRequestBody (const $ const $ const $ return ()) req - if firstIs (\(x,y) -> BS.null x || BS.null y) ps || length ps < 2 - then throwError $ Just InvalidLoginAttempt - else do - mSuccess <- runMaybeT $ do - user <- hoistMaybe $ lookup "user" ps - pass <- hoistMaybe $ lookup "password" ps - liftIO $ putStrLn $ "<~!~> Attempted Login: " ++ show user ++ ", " ++ show pass ++ "\n" - nUserSess <- newUserSession - lift $ writeUserSession nUserSess - return nUserSess - note' (Just InvalidLoginAttempt) mSuccess - _ -> throwError $ Just InvalidLoginAttempt - where - firstIs _ [] = True - firstIs f (x:_) = f x - - - logoutHandle = getReq $ \req -> do - resp <- case getUserSession $ requestHeaders req of - Nothing -> return "no session :s" - Just userSession -> do - lift $ deleteUserSession (userSessID userSession) - return "logged-out" - textWith clearSessionResponse resp - - unauthHandle SessionNotInCache = get $ textStatusWith clearSessionResponse status401 "Unauthorized! - session not in cache" - unauthHandle SessionTimedOut = get $ textStatusWith clearSessionResponse status401 "Unauthorized! - session timed out" - unauthHandle SessionMismatch = get $ textStatusWith clearSessionResponse status401 "Unauthorized! - session mismatch" - unauthHandle InvalidRequestNonce = get $ textStatusWith clearSessionResponse status401 "Unauthorized! - you're doing something sneaky!" - unauthHandle NoSessionHeaders = get $ textStatusWith clearSessionResponse status401 "Unauthorized! - are you sure you're logged in?" - notFoundHandle = get $ textStatus status404 "Not Found :(" - diff --git a/examples/STM/Auth.hs b/examples/STM/Auth.hs deleted file mode 100644 --- a/examples/STM/Auth.hs +++ /dev/null @@ -1,227 +0,0 @@ -{-# LANGUAGE - FlexibleContexts - , OverloadedStrings - #-} - -module STM.Auth where - -import Network.Wai.Trans -import Network.HTTP.Types -import Web.Cookie -import Data.Attoparsec.Text -import Data.Monoid -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -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) -import Data.ByteArray (convert) -import Data.Time -import Data.Time.ISO8601 -import Data.Maybe - -import Control.Concurrent.STM -import Control.Error.Util -import Control.Monad.Except -import Control.Monad.Reader -import Control.Monad.State -import Crypto.Hash - - --- | @sec@ -data SecurityLayer = ShouldBeLoggedIn - | ShouldBeModerator - | ShouldBeAdmin - deriving (Show, Eq, Ord) - -data AuthEnv = AuthEnv - { authEnvCache :: TVar (IntMap.IntMap (UTCTime, BS.ByteString)) - , authEnvFreshId :: TVar Int - , authEnvSalt :: BS.ByteString - } - - -sessionId :: BS.ByteString -sessionId = "security-id" - -sessionNonce :: BS.ByteString -sessionNonce = "security-token" - -sessionTime :: BS.ByteString -sessionTime = "security-token-time" - -makeSessionCookies :: UserSession BS.ByteString -> RequestHeaders -makeSessionCookies (UserSession i t c) = repeat "Set-Cookie" `zip` cookies - where - cookies = - [ toByteString $ - renderSetCookie $ def { setCookieName = sessionId - , setCookieMaxAge = Just 60 - , setCookieValue = fromString $ show i } - , toByteString $ - renderSetCookie $ def { setCookieName = sessionTime - , setCookieMaxAge = Just 60 - , setCookieValue = T.encodeUtf8 $ T.pack $ formatISO8601 t } - , toByteString $ - renderSetCookie $ def { setCookieName = sessionNonce - , setCookieMaxAge = Just 60 - , setCookieValue = c } - ] - -clearSessionResponse :: Response -> Response -clearSessionResponse = mapResponseHeaders $ - filter $ \(a,b) -> - let cookieName = setCookieName $ parseSetCookie b - in not $ a == "Set-Cookie" && ( cookieName == sessionId - || cookieName == sessionTime - || cookieName == sessionNonce ) - -clearSessionRequest :: Request -> Request -clearSessionRequest req = - req {requestHeaders = go $ requestHeaders req} - where - go = filter $ \(a,b) -> - let cookies = parseCookies b - hasSession (k,_) = k == sessionId || k == sessionTime || k == sessionNonce - in not $ a == "Cookie" && any hasSession cookies - -getUserSession :: RequestHeaders -> Maybe (UserSession BS.ByteString) -getUserSession hs = - let (mi,mt,mc) = foldr go (Nothing,Nothing,Nothing) hs - in UserSession <$> mi <*> mt <*> mc - where - go (k,c) (mi,mt,mc) | k == "Cookie" = - let cs = parseCookies c - go' (k',c') (mi',mt',mc') - | k' == sessionId = (hush $ parseOnly integer $ T.decodeUtf8 c', mt', mc') - | k' == sessionTime = (mi', parseISO8601 $ T.unpack $ T.decodeUtf8 c', mc') - | k' == sessionNonce = (mi', mt', Just c') - | otherwise = (mi',mt',mc') - in foldr go' (mi,mt,mc) cs - | otherwise = (mi,mt,mc) - - -integer :: Parser Int -integer = do - xs <- double - return $ floor xs - - - -data UserSession a = UserSession - { userSessID :: Int - , userSessTime :: UTCTime - , userSessNonce :: a - } deriving (Show, Eq, Ord) - -newUserSession :: ( MonadIO m - , MonadReader AuthEnv m - ) => m (UserSession BS.ByteString) -newUserSession = do - salt <- authEnvSalt <$> ask - uIdKey <- authEnvFreshId <$> ask - uId <- liftIO $ atomically $ do - i <- readTVar uIdKey - modifyTVar' uIdKey (+1) - return i - now <- liftIO getCurrentTime - return $ UserSession uId now $ BS.encode $ convert $ go now salt - where - go :: UTCTime -> BS.ByteString -> Digest SHA512 - go now salt = hash $ salt <> fromString (formatISO8601 now) - - -lookupUserSession :: ( MonadIO m - , MonadReader AuthEnv m - ) => Int -> m (Maybe (UserSession BS.ByteString)) -lookupUserSession i = do - cacheKey <- authEnvCache <$> ask - liftIO $ atomically $ do - cache <- readTVar cacheKey - return $ do (t,c) <- IntMap.lookup i cache - return $ UserSession i t c - -deleteUserSession :: ( MonadIO m - , MonadReader AuthEnv m - ) => Int -> m () -deleteUserSession i = do - cacheKey <- authEnvCache <$> ask - liftIO $ atomically $ modifyTVar' cacheKey (IntMap.delete i) - - -writeUserSession :: ( MonadIO m - , MonadReader AuthEnv m - ) => UserSession BS.ByteString -> m () -writeUserSession (UserSession i t c) = do - cacheKey <- authEnvCache <$> ask - liftIO $ atomically $ modifyTVar' cacheKey $ IntMap.insert i (t, c) - - -checkUserSession :: MonadReader AuthEnv m => - UserSession BS.ByteString - -> m Bool -checkUserSession (UserSession _ t c) = do - salt <- authEnvSalt <$> ask - let old = hash $ salt <> fromString (formatISO8601 t) :: Digest SHA512 - old' = BS.encode $ convert old :: BS.ByteString - return $ c == old' - - -data AuthenticationError = NoSessionHeaders - | InvalidRequestNonce - | SessionNotInCache - | SessionMismatch - | SessionTimedOut - - -authenticate :: ( MonadIO m - , MonadReader AuthEnv m - ) => 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" - 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) - 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 - 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: 6.1.0 +Version: 7.0.0 Author: Athan Clark Maintainer: Athan Clark License: BSD3 @@ -20,9 +20,7 @@ parsers and /directly/ in our routes, with our handlers - reflecting their results. You can find more information in the - . - and the examples. + reflecting their results. Cabal-Version: >= 1.10 Build-Type: Simple @@ -31,34 +29,32 @@ Description: Build the trivial example. Default: False -Flag Example-STM - Description: Build the Sha512 / STM nonce cache example. - Default: False - - Library Default-Language: Haskell2010 HS-Source-Dirs: src GHC-Options: -Wall Exposed-Modules: Web.Routes.Nested + Web.Routes.Nested.Match Web.Routes.Nested.Types - Web.Routes.Nested.Types.UrlChunks - Build-Depends: base >= 4.6 && < 5 + Build-Depends: base >= 4.8 && < 5 , attoparsec , bytestring , composition-extra >= 2.0.0 - , containers + , errors + , exceptions + , hashable , mtl , poly-arity >= 0.0.7 - , pred-trie >= 0.3 + , pred-trie >= 0.5.0 , regex-compat , semigroups , text , transformers , tries - , wai-transformers >= 0.0.3 - , wai-middleware-content-type >= 0.0.3.1 - , wai-middleware-verbs >= 0.0.4 + , unordered-containers + , wai-transformers >= 0.0.4 + , wai-middleware-content-type >= 0.4.0 + , wai-middleware-verbs >= 0.2.0 Test-Suite test @@ -73,13 +69,14 @@ Web.Routes.NestedSpec.Basic Web.Routes.Nested Web.Routes.Nested.Types - Web.Routes.Nested.Types.UrlChunks Build-Depends: base , nested-routes , attoparsec , bytestring , composition-extra - , containers + , errors + , exceptions + , hashable , http-types , mtl , poly-arity @@ -89,6 +86,7 @@ , text , transformers , tries + , unordered-containers , wai-transformers , wai-middleware-content-type , wai-middleware-verbs @@ -108,13 +106,14 @@ Main-Is: Main.hs Other-Modules: Web.Routes.Nested Web.Routes.Nested.Types - Web.Routes.Nested.Types.UrlChunks Build-Depends: base - , nested-routes + , nested-routes >= 7 , attoparsec , bytestring , composition-extra - , containers + , errors + , exceptions + , hashable , http-types , mtl , poly-arity @@ -124,60 +123,13 @@ , text , transformers , tries + , unordered-containers , wai-transformers , wai-middleware-content-type , wai-middleware-verbs , warp -Executable example-stm - if flag(Example-STM) - Buildable: True - else - Buildable: False - Default-Language: Haskell2010 - HS-Source-Dirs: src - , examples - GHC-Options: -Wall - Main-Is: STM.hs - Other-Modules: STM.Auth - Web.Routes.Nested - Web.Routes.Nested.Types - Web.Routes.Nested.Types.UrlChunks - Build-Depends: base - , base64-bytestring - , blaze-builder - , nested-routes - , attoparsec - , bytestring - , composition-extra - , containers - , cookie - , cryptonite - , data-default - , errors - , http-types - , iso8601-time - , lucid - , memory - , mtl - , poly-arity - , pred-trie - , regex-compat - , semigroups - , stm - , text - , time - , transformers - , tries - , wai-extra - , wai-middleware-content-type - , wai-middleware-verbs - , wai-transformers - , wai-session - , warp - , utf8-string - Source-Repository head Type: git - Location: git://github.com/athanclark/nested-routes.git + Location: https://github.com/athanclark/nested-routes.git 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 @@ -2,7 +2,7 @@ GADTs , PolyKinds , TypeFamilies - , DeriveFunctor + , BangPatterns , TypeOperators , TupleSections , DoAndIfThenElse @@ -10,486 +10,345 @@ , FlexibleContexts , OverloadedStrings , ScopedTypeVariables - , GeneralizedNewtypeDeriving #-} --- | --- Module : Web.Routes.Nested --- Copyright : (c) 2015 Athan Clark --- --- License : BSD-style --- Maintainer : athan.clark@gmail.com --- Stability : experimental --- Portability : GHC --- --- This module exports most of what you'll need for sophisticated routing - --- all the tools from --- (routing for the incoming HTTP method) and --- --- (routing for the incoming Accept header, and implied file extension), --- itself, and --- - some simple --- type aliases wrapped around WAI's @Application@ and @Middleware@ types, allowing us --- to embed monad transformer stacks for our applications. --- --- The routing system lets you embed these complicated HTTP verb / content-type --- sensative responses just as easily as a WAI @Middleware@. There is enough --- tooling provided to use one paradigm or the other. Note - nested-routes --- does not affect the @pathInfo@ of the incoming @Request@ in any way, but merely --- matches on it and passes control to the designated response. --- --- To match a route, you have a few options - you can match against a string literal, --- a regular expression (via ), --- or an parser. This list --- will most likely grow in the future, depending on demand. --- --- There is also support for embedding security layers in your routes, in the same --- nested manner. By "tagging" a set of routes with an authorization role (with @auth@), --- you populate a list of roles breached during any request. In the authentication --- parameter in @routeAuth@ and @routeActionAuth@, the function --- keeps the session integrity in-place, while @auth@ lets you create your authorization --- boundaries. Both are symbiotic and neccessary for establishing security, and both allow --- you to tap into the monad transformer stack to do logging, STM, database queries, --- etc. --- --- To use your set of routes in a WAI application, you need to "extract" the --- functionality from your route set - using the @route@, @routeAuth@, @routeAction@, --- and @routeActionAuth@ --- functions, you can create monolithic apps very easily. --- But, if you would like to extract the security middleware to place before --- say, a /static/ middleware you already have in place, use the @extractAuth@ --- functions, and others for their respective purposes. This way, you can decompose --- the routing system into each subject matter, and re-compose (@.@) them in whichever --- order you like for your application. +{- | +Module : Web.Routes.Nested +Copyright : (c) 2015 Athan Clark +License : BSD-style +Maintainer : athan.clark@gmail.com +Stability : experimental +Portability : GHC +This module exports most of what you'll need for sophisticated routing - +all the tools from +(routing for the incoming HTTP method) and + +(routing for the incoming Accept header, and implied file extension), + itself, and + - some simple +type aliases wrapped around WAI's @Application@ and @Middleware@ types, allowing us +to embed monad transformer stacks for our applications. +To match a route, you have a few options - you can match against a string literal, +a regular expression (via ), +or an parser. This list +will most likely grow in the future, depending on demand. + +There is also support for embedding security layers in your routes, in the same +nested manner. By "tagging" a set of routes with an authorization role (with @auth@), +you populate a list of roles breached during any request. The function argument to +'routeAuth' guards a Request to pass or fail at the high level, while 'auth' lets +you create your authorization boundaries on a case-by-case basis. Both allow +you to tap into the monad transformer stack for logging, STM variables, database queries, +etc. +-} + + module Web.Routes.Nested - ( module X - -- * Types - , Tries - , HandlerT (..) - , execHandlerT - , ActionT - , RoutableT - , RoutableActionT - , AuthScope (..) - , ExtrudeSoundly - -- * Combinators - , handle - , handleAction - , here - , hereAction - , handleAny - , handleAnyAction - , parent + ( -- * Combinators + match + , matchHere + , matchAny + , matchGroup , auth - , notFound - , notFoundAction - , action - -- * Routing - , route + , -- * Routing + route , routeAuth - , routeAction - , routeActionAuth - -- * Extraction - , extractContent - , extractNotFound + , extractMatch + , extractMatchAny , extractAuthSym , extractAuth , extractNearestVia - , actionToMiddleware + , -- * Metadata + SecurityToken (..) + , AuthScope (..) + , -- * Re-Exports + module Web.Routes.Nested.Match + , module Web.Routes.Nested.Types + , module Network.Wai.Middleware.Verbs + , module Network.Wai.Middleware.ContentType ) where -import Web.Routes.Nested.Types as X -import Network.Wai.Trans as X -import Network.Wai.Middleware.Verbs as X -import Network.Wai.Middleware.ContentType as X +import Web.Routes.Nested.Match +import Web.Routes.Nested.Types +import Network.Wai.Trans +import Network.Wai.Middleware.Verbs +import Network.Wai.Middleware.ContentType hiding (responseStatus, responseHeaders, responseData) -import Data.Trie.Pred (RootedPredTrie (..), PredTrie (..)) -import qualified Data.Trie.Pred as PT -- only using lookups -import Data.Trie.Pred.Step (PredStep (..), PredSteps (..)) +import qualified Data.Trie.Pred.Base as PT -- only using lookups +import Data.Trie.Pred.Base (RootedPredTrie (..), PredTrie (..)) +import Data.Trie.Pred.Base.Step (PredStep (..), PredSteps (..)) +import Data.Trie.Pred.Interface.Types (Singleton (..), Extrude (..), CatMaybes) import qualified Data.Trie.Class as TC -import Data.Trie.Map (MapStep (..)) -import qualified Data.Map as Map -import Data.List (stripPrefix) +import Data.Trie.HashMap (HashMapStep (..), HashMapChildren (..)) +import qualified Data.HashMap.Lazy as HM import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE import qualified Data.Text as T -import Data.Maybe (fromMaybe) +import Data.Hashable import Data.Monoid -import Data.Foldable import Data.Functor.Syntax import Data.Function.Poly import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Trans import qualified Control.Monad.State as S +import Control.Monad.Catch +import Control.Monad.Trans -type Tries x s e = ( RootedPredTrie T.Text x - , RootedPredTrie T.Text x - , RootedPredTrie T.Text s - , RootedPredTrie T.Text e - ) - -newtype HandlerT x sec err aux m a = HandlerT - { runHandlerT :: S.StateT (Tries x sec err) m a } - deriving ( Functor - , Applicative - , Monad - , MonadIO - , MonadTrans - , S.MonadState (Tries x sec err) - ) - -execHandlerT :: Monad m => HandlerT x sec err aux m a -> m (Tries x sec err) -execHandlerT hs = S.execStateT (runHandlerT hs) mempty - -type ActionT e u m a = VerbListenerT (FileExtListenerT (MiddlewareT m) m a) e u m a - --- | Turn an @ActionT@ into a @MiddlewareT@ - could be used to make middleware-based --- route sets cooperate with the content-type and verb combinators. -action :: MonadIO m => ActionT e u m () -> MiddlewareT m -action xs = verbsToMiddleware $ mapVerbs fileExtsToMiddleware xs +-- | Embed a 'Network.Wai.Trans.MiddlewareT' into a set of routes via a matching string. You should +-- expect the match to create /arity/ in your handler - the @childContent@ variable. +-- The arity of @childContent@ may grow or shrink, depending on the heterogeneous +-- list created from the list of parsers, regular expressions, or arbitrary predicates +-- /in the order written/ - so something like: +-- +-- > match (p_ "double-parser" double o_) +-- > handler +-- +-- ...then @handler@ /must/ have arity @Double ->@. If this +-- route was at the top level, then the total arity __must__ be @Double -> MiddlewareT m@. +-- +-- Generally, if the routes you are building get grouped +-- by a predicate with 'matchGroup', +-- then we would need another level of arity /before/ the @Double@. +match :: ( Monad m + , Singleton (UrlChunks xs) + childContent + (RootedPredTrie T.Text resultContent) + , cleanxs ~ CatMaybes xs + , ArityTypeListIso childContent cleanxs resultContent + ) => UrlChunks xs + -> childContent + -> HandlerT resultContent sec m () +match !ts !vl = + tell' $ Tries (singleton ts vl) + mempty + mempty -type RoutableT s e u ue m a = - HandlerT (MiddlewareT m) (s, AuthScope) (e -> MiddlewareT m) (e,u,ue) m a - -type RoutableActionT s e u ue m a = - HandlerT (ActionT ue u m ()) (s, AuthScope) (e -> ActionT ue u m ()) (e,u,ue) m a - -type ExtrudeSoundly cleanxs xs c r = - ( cleanxs ~ CatMaybes xs - , ArityTypeListIso c cleanxs r - , Extrude (UrlChunks xs) - (RootedPredTrie T.Text c) - (RootedPredTrie T.Text r) - ) +{-# INLINEABLE match #-} +-- | Create a handle for the /current/ route - an alias for @\h -> match o_ h@. +matchHere :: ( Monad m + ) => content + -> HandlerT content sec m () +matchHere = match origin_ --- | Embed an @ActionT@ into a set of routes directly, without first converting --- it to a @MiddlewareT@. -handleAction :: ( Monad m - , Functor m - , HasResult childContent (ActionT ue u m ()) - , HasResult err (e -> ActionT ue u m ()) - , Singleton (UrlChunks xs) - childContent - (RootedPredTrie T.Text resultContent) - , cleanxs ~ CatMaybes xs - , ArityTypeListIso childContent cleanxs resultContent - ) => UrlChunks xs - -> childContent - -> HandlerT resultContent sec err (e,u,ue) m () -handleAction ts vl = tell' (singleton ts vl, mempty, mempty, mempty) +{-# INLINEABLE matchHere #-} --- | Embed a @MiddlewareT@ into a set of routes. -handle :: ( Monad m - , Functor m - , HasResult childContent (MiddlewareT m) - , HasResult err (e -> MiddlewareT m) - , Singleton (UrlChunks xs) - childContent - (RootedPredTrie T.Text resultContent) - , cleanxs ~ CatMaybes xs - , ArityTypeListIso childContent cleanxs resultContent - ) => UrlChunks xs - -> childContent - -> HandlerT resultContent sec err (e,u,ue) m () -handle ts vl = tell' (singleton ts vl, mempty, mempty, mempty) +-- | Match against any route, as a last resort against all failing matches - +-- use this for a catch-all at some level in their routes, something +-- like a @not-found 404@ page is useful. +matchAny :: ( Monad m + ) => content + -> HandlerT content sec m () +matchAny !vl = + tell' $ Tries mempty + (singleton origin_ vl) + 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_ +{-# INLINEABLE matchAny #-} -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) +-- | Prepends a common route to an existing set of routes. You should note that +-- doing this with a parser or regular expression will necessitate the existing +-- arity in the handlers before the progam can compile. +matchGroup :: ( Monad m + , cleanxs ~ CatMaybes xs + , ExtrudeSoundly cleanxs xs childContent resultContent + , ExtrudeSoundly cleanxs xs childSec resultSec + ) => UrlChunks xs + -> HandlerT childContent childSec m () + -> HandlerT resultContent resultSec m () +matchGroup !ts cs = do + (Tries trieContent trieNotFound trieSec) <- lift $ execHandlerT cs + tell' $ Tries (extrude ts trieContent) + (extrude ts trieNotFound) + (extrude ts trieSec) --- | Prepend a path to an existing set of routes. -parent :: ( Monad m - , Functor m - , cleanxs ~ CatMaybes xs - , ExtrudeSoundly cleanxs xs childContent resultContent - , ExtrudeSoundly cleanxs xs childSec resultSec - , ExtrudeSoundly cleanxs xs childErr resultErr - ) => UrlChunks xs - -> HandlerT childContent childSec childErr aux m () - -> HandlerT resultContent resultSec resultErr aux m () -parent ts cs = do - (trieContent,trieNotFound,trieSec,trieErr) <- lift $ execHandlerT cs - tell' ( extrude ts trieContent - , extrude ts trieNotFound - , extrude ts trieSec - , extrude ts trieErr - ) +{-# INLINEABLE matchGroup #-} +-- | Use a custom security token type and an 'AuthScope' to define +-- /where/ and /what kind/ of security should take place. +data SecurityToken s = SecurityToken + { securityToken :: !s + , securityScope :: !AuthScope + } deriving (Show) -- | 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 = ProtectHere | DontProtectHere +data AuthScope + = ProtectHere + | DontProtectHere deriving (Show, Eq) -- | Sets the security role and error handler for a set of routes, optionally -- including its parent route. auth :: ( Monad m - , Functor m ) => sec - -> err -> AuthScope - -> HandlerT content (sec, AuthScope) err aux m () -auth token handleFail scope = - tell' ( mempty - , mempty - , RootedPredTrie (Just (token,scope)) mempty - , RootedPredTrie (Just handleFail) mempty - ) + -> HandlerT content (SecurityToken sec) m () +auth !token !scope = + tell' $ Tries mempty + mempty + (singleton origin_ $ SecurityToken token scope) --- | Embed an @ActionT@ as a not-found handler into a set of routes, without first converting --- it to a @MiddlewareT@. -notFoundAction :: ( 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 () -notFoundAction = handleAnyAction - --- | Embed a @MiddlewareT@ as a not-found handler into a set of routes. -notFound :: ( Monad m - , Functor m - , HasResult content (MiddlewareT m) - , HasResult err (e -> MiddlewareT m) - ) => content - -> HandlerT content sec err (e,u,ue) m () -notFound = handleAny - +{-# INLINEABLE auth #-} -- * Routing --------------------------------------- --- | Turns a @HandlerT@ containing @MiddlewareT@s into a @MiddlewareT@. -route :: ( Functor m - , Monad m - , MonadIO m - ) => HandlerT (MiddlewareT m) sec err aux m () -- ^ Assembled @handle@ calls +route :: ( Monad m + ) => HandlerT (MiddlewareT m) sec m a -> MiddlewareT m -route hs = extractContent hs . extractNotFound hs - +route hs app req resp = do + let path = pathInfo req + mMatch <- extractMatch path hs + case mMatch of + Nothing -> do + mMatch <- extractMatchAny path hs + maybe + (app req resp) + (\mid -> mid app req resp) + mMatch + Just mid -> mid app req resp --- | Given a security verification function that returns a method to updating the session, --- turn a set of routes containing @MiddlewareT@s into a @MiddlewareT@, where a session --- is secured before responding. -routeAuth :: ( Functor m - , Monad m - , MonadIO m - ) => (Request -> [sec] -> m (Response -> Response, Maybe e)) -- ^ authorize - -> RoutableT sec e u ue m () -- ^ Assembled @handle@ calls +routeAuth :: ( Monad m + , MonadThrow m + ) => (Request -> [sec] -> m ()) + -> HandlerT (MiddlewareT m) (SecurityToken sec) m a -> MiddlewareT m -routeAuth authorize hs = extractAuth authorize hs . route hs +routeAuth authorize hs app req resp = do + extractAuth authorize req hs + route hs app req resp --- | Exactly like @route@, except specialized to route sets that contain @ActionT@s - --- essentially @fmap@ing @action@ to each element. -routeAction :: ( Functor m - , Monad m - , MonadIO m - ) => RoutableActionT sec e u ue m () - -> MiddlewareT m -routeAction = route . actionToMiddleware +-- * Extraction ------------------------------- --- | Exactly like @routeAuth@, but specialized for @ActionT@. -routeActionAuth :: ( Functor m - , Monad m - , MonadIO m - ) => (Request -> [sec] -> m (Response -> Response, Maybe e)) -- ^ authorize - -> RoutableActionT sec e u ue m () -- ^ Assembled @handle@ calls - -> MiddlewareT m -routeActionAuth authorize = routeAuth authorize . actionToMiddleware +-- | Extracts only the normal 'match' and 'matchHere' +extractMatch :: ( Monad m + ) => [T.Text] + -> HandlerT r sec m a + -> m (Maybe r) +extractMatch path !hs = do + trie <- trieContent <$> execHandlerT hs + case matchWithLRPT trimFileExt path trie of + Nothing -> return $ do + guard $ not (null path) + guard $ trimFileExt (last path) == "index" + TC.lookup (init path) trie + Just (_,r) -> return (Just r) +{-# INLINEABLE extractMatch #-} --- | Turns a @HandlerT@ containing @ActionT@s into a @HandlerT@ containing @MiddlewareT@s. -actionToMiddleware :: MonadIO m => - RoutableActionT sec e u ue m () - -> RoutableT sec e u ue m () -actionToMiddleware hs = do - (rtrie,nftrie,strie,errtrie) <- lift $ execHandlerT hs - tell' ( action <$> rtrie - , action <$> nftrie - , strie - , (action .) <$> errtrie - ) +-- | Extracts only the @notFound@ responses +extractMatchAny :: ( Monad m + ) => [T.Text] + -> HandlerT r sec m a + -> m (Maybe r) +extractMatchAny path = extractNearestVia path (\x -> trieCatchAll <$> execHandlerT x) --- * Extraction ------------------------------- +{-# INLINEABLE extractMatchAny #-} --- | Extracts only the normal @handle@ (content) routes into --- a @MiddlewareT@, disregarding security and not-found responses. -extractContent :: ( Functor m - , Monad m - , MonadIO m - ) => HandlerT (MiddlewareT m) sec err aux m a - -> MiddlewareT m -extractContent hs app req respond = do - (trie,_,_,_) <- execHandlerT hs - case matchWithLRPT trimFileExt (pathInfo req) trie of - Nothing -> fromMaybe (app req respond) $ do - guard $ not . null $ pathInfo req - guard $ trimFileExt (last $ pathInfo req) == "index" - mid <- TC.lookup (init $ pathInfo req) trie - Just $ mid app (adjustPathInfo (init $ pathInfo req) req) respond - Just (prefix,mid) -> mid app (adjustPathInfo prefix req) respond -- | Find the security tokens / authorization roles affiliated with --- a request for a set of routes. -extractAuthSym :: ( Functor m - , Monad m - ) => HandlerT x (sec, AuthScope) err aux m a - -> Request +-- a request for a set of routes. +extractAuthSym :: ( Monad m + ) => [T.Text] + -> HandlerT x (SecurityToken sec) m a -> m [sec] -extractAuthSym hs req = do - (_,_,trie,_) <- execHandlerT hs - return $ foldl go [] (PT.matchesRPT (pathInfo req) trie) +extractAuthSym path hs = do + trie <- trieSecurity <$> execHandlerT hs + return $! foldr go [] $ PT.matchesRPT path trie where - go ys (_,(_,DontProtectHere),[]) = ys - go ys (_,(x,_ ),_ ) = ys ++ [x] + go (_,SecurityToken _ DontProtectHere,[]) ys = ys + go (_,SecurityToken x _ ,_ ) ys = x:ys --- | Extracts only the security handling logic into a @MiddlewareT@. -extractAuth :: ( Functor m - , Monad m - , MonadIO m - ) => (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 - (f,me) <- authorize req ss - fromMaybe (app req (respond . f)) $ do - e <- me - (prefix,mid,_) <- PT.matchRPT (pathInfo req) trie - return $ mid e app (adjustPathInfo prefix req) (respond . f) +{-# INLINEABLE extractAuthSym #-} +-- | Extracts only the security handling logic, and turns it into a guard +extractAuth :: ( Monad m + , MonadThrow m + ) => (Request -> [sec] -> m ()) -- authorization method + -> Request + -> HandlerT x (SecurityToken sec) m a + -> m () +extractAuth authorize req hs = do + ss <- extractAuthSym (pathInfo req) hs + authorize req ss --- | Extracts only the @notFound@ responses into a @MiddlewareT@. -extractNotFound :: ( Functor m - , Monad m - , MonadIO m - ) => HandlerT (MiddlewareT m) sec err aux m a - -> MiddlewareT m -extractNotFound = extractNearestVia (execHandlerT >=> \(_,t,_,_) -> return t) +{-# INLINEABLE extractAuth #-} -- | Given a way to draw out a special-purpose trie from our route set, route --- to the responses based on a /furthest-reached/ method. -extractNearestVia :: ( Functor m - , Monad m - , MonadIO m - ) => (HandlerT (MiddlewareT m) sec err aux m a -> m (RootedPredTrie T.Text (MiddlewareT m))) - -> HandlerT (MiddlewareT m) sec err aux m a - -> MiddlewareT m -extractNearestVia extr hs app req respond = do +-- to the responses based on a /furthest-reached/ method. +extractNearestVia :: ( Monad m + ) => [T.Text] + -> (HandlerT r sec m a -> m (RootedPredTrie T.Text r)) + -> HandlerT r sec m a + -> m (Maybe r) +extractNearestVia path extr hs = do trie <- extr hs - maybe (app req respond) - (\(prefix, mid,_) -> mid app (adjustPathInfo prefix req) respond) - $ PT.matchRPT (pathInfo req) trie + pure (mid <$> PT.matchRPT path trie) + where + mid (_,r,_) = r +{-# INLINEABLE extractNearestVia #-} + -- * Pred-Trie related ----------------- -- | Removes @.txt@ from @foo.txt@ trimFileExt :: T.Text -> T.Text -trimFileExt s = - let lastExt = getLastExt (T.unpack s) - in if lastExt `elem` possibleExts - then T.pack lastExt - else s - where - possibleExts = [ ".html",".htm",".txt",".json",".lucid" - , ".julius",".css",".cassius",".lucius" - ] - getLastExt ts = S.evalState (foldrM go [] ts) False - where - go c soFar = do - sawPeriod <- S.get - if sawPeriod - then return soFar - else if c == '.' - then do S.put True - return ('.' : soFar) - else return (c : soFar) +trimFileExt !s = fst $! T.breakOn "." s +{-# INLINEABLE trimFileExt #-} + -- | A quirky function for processing the last element of a lookup path, only -- on /literal/ matches. -matchWithLPT :: Ord s => (s -> s) -> NonEmpty s -> PredTrie s a -> Maybe ([s], a) -matchWithLPT f (t:|ts) (PredTrie (MapStep ls) (PredSteps ps)) - | null ts = getFirst $ First (goLit (f t) ls) <> foldMap (First . goPred) ps - | otherwise = getFirst $ First (goLit t ls) <> foldMap (First . goPred) ps +matchWithLPT :: ( Hashable s + , Eq s + ) => (s -> s) -> NonEmpty s -> PredTrie s a -> Maybe ([s], a) +matchWithLPT f (t:|ts) (PredTrie (HashMapStep ls) (PredSteps ps)) + | null ts = getFirst $ First ((goLit $! f t) ls) <> foldMap (First . goPred) ps + | otherwise = getFirst $ First (goLit t ls) <> foldMap (First . goPred) ps where goLit t' xs = do - (mx,mxs) <- Map.lookup t' xs + (HashMapChildren mx mxs) <- HM.lookup t' xs if null ts then ([t],) <$> mx - else (\(ts',x) -> (t:ts',x)) <$> (matchWithLPT f (NE.fromList ts) =<< mxs) - --- TODO: Need `match` for Map? idk actually, `t` should be enough for this step. + else fmap (\(ts',x) -> (t:ts',x)) $! matchWithLPT f (NE.fromList ts) =<< mxs goPred (PredStep _ predicate mx xs) = do d <- predicate t if null ts then ([t],) <$> (mx <$~> d) - else (\(ts',x) -> (t:ts',x d)) <$> (matchWithLPT f (NE.fromList ts) xs) + else fmap (\(ts',x) -> (t:ts',x d)) $! matchWithLPT f (NE.fromList ts) xs -matchWithLRPT :: Ord s => (s -> s) -> [s] -> RootedPredTrie s a -> Maybe ([s], a) +{-# INLINEABLE matchWithLPT #-} + + +matchWithLRPT :: ( Hashable s + , Eq s + ) => (s -> s) -> [s] -> RootedPredTrie s a -> Maybe ([s], a) matchWithLRPT _ [] (RootedPredTrie mx _) = ([],) <$> mx matchWithLRPT f ts (RootedPredTrie _ xs) = matchWithLPT f (NE.fromList ts) xs +{-# INLINEABLE matchWithLRPT #-} + tell' :: (Monoid w, S.MonadState w m) => w -> m () -tell' x = do - xs <- S.get - S.put $ xs <> x +tell' x = S.modify' (<> x) +{-# INLINEABLE tell' #-} -adjustPathInfo :: [T.Text] -> Request -> Request -adjustPathInfo matched req' = - req' { pathInfo = fromMaybe (error "non-prefix on match") $ - stripPrefix matched (pathInfo req') - } diff --git a/src/Web/Routes/Nested/Match.hs b/src/Web/Routes/Nested/Match.hs new file mode 100644 --- /dev/null +++ b/src/Web/Routes/Nested/Match.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE + GADTs + , DataKinds + , RankNTypes + , TypeOperators + , OverloadedStrings + #-} + +{- | +Module : Web.Routes.Nested.Match +Copyright : (c) 2015 Athan Clark + +License : BSD-style +Maintainer : athan.clark@gmail.com +Stability : experimental +Portability : GHC +-} + +module Web.Routes.Nested.Match + ( -- * Path Combinators + o_ + , origin_ + , l_ + , literal_ + , f_ + , file_ + , p_ + , parse_ + , r_ + , regex_ + , pred_ + , () + , -- ** Path Types + EitherUrlChunk + , UrlChunks + ) where + +import Prelude hiding (pred) +import Data.Attoparsec.Text +import Text.Regex +import qualified Data.Text as T +import Control.Monad +import Control.Error (hush) +import Data.Trie.Pred + + +o_, origin_ :: UrlChunks '[] +o_ = origin_ + +-- | The /Origin/ chunk - the equivalent to @[]@ +origin_ = nil + + +l_, literal_ :: T.Text -> EitherUrlChunk 'Nothing +l_ = literal_ + +-- | Match against a /Literal/ chunk +literal_ = only + +f_, file_ :: T.Text -> EitherUrlChunk ('Just T.Text) +f_ = file_ + +-- | Removes file extension from the matched route +file_ f = pred_ f (\t -> t <$ guard (fst (T.breakOn "." t) == f)) + + +p_, parse_ :: T.Text -> Parser r -> EitherUrlChunk ('Just r) +p_ = parse_ + +-- | Match against a /Parsed/ chunk, with . +parse_ i q = pred_ i (hush . parseOnly q) + + +r_, regex_ :: T.Text -> Regex -> EitherUrlChunk ('Just [String]) +r_ = regex_ + +-- | Match against a /Regular expression/ chunk, with . +regex_ i q = pred_ 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_ = pred + + +-- | Constrained to AttoParsec, Regex-Compat and T.Text +type EitherUrlChunk = PathChunk T.Text + + +-- | Container when defining route paths +type UrlChunks = PathChunks T.Text + + + +-- | Prefix a routable path by more predicative lookup data. +() :: EitherUrlChunk mx -> UrlChunks xs -> UrlChunks (mx ': xs) +() = (./) + +infixr 9 + + 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 @@ -1,78 +1,75 @@ {-# LANGUAGE - GADTs - , TypeOperators - , TypeFamilies - , KindSignatures - , DataKinds - , RankNTypes - , FlexibleInstances - , UndecidableInstances - , MultiParamTypeClasses - , FunctionalDependencies + DeriveFunctor , ConstraintKinds + , TypeFamilies + , FlexibleContexts + , GeneralizedNewtypeDeriving #-} -module Web.Routes.Nested.Types - ( Singleton (..) - , Extend (..) - , Extrude (..) - , CatMaybes - , module Web.Routes.Nested.Types.UrlChunks - ) where - -import Web.Routes.Nested.Types.UrlChunks -import qualified Data.Text as T -import Data.Trie.Pred -import Data.Trie.Pred.Step -import qualified Data.Trie.Map as MT -import qualified Data.Map as Map - - -type family CatMaybes (xs :: [Maybe *]) :: [*] where - CatMaybes '[] = '[] - CatMaybes ('Nothing ': xs) = CatMaybes xs - CatMaybes (('Just x) ': xs) = x ': CatMaybes xs - --- | Creates a string of nodes - a trie with a width of 1. -class Singleton chunks a trie | chunks a -> trie where - singleton :: chunks -> a -> trie +module Web.Routes.Nested.Types where --- Basis -instance Singleton (UrlChunks '[]) a (RootedPredTrie T.Text a) where - singleton Root r = RootedPredTrie (Just r) emptyPT +import Web.Routes.Nested.Match +import Network.Wai.Middleware.Verbs +import Network.Wai.Middleware.ContentType +import Network.Wai.Trans +import Data.Trie.Pred.Base (RootedPredTrie (..)) +import Data.Trie.Pred.Interface.Types (Extrude (..), CatMaybes) --- 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) +import Data.Monoid +import qualified Data.Text as T +import Data.Function.Poly +import Control.Monad.Trans +import qualified Control.Monad.State as S --- | Turn a list of tries (@Rooted@) into a node with those children -class Extend eitherUrlChunk child result | eitherUrlChunk child -> result where - extend :: eitherUrlChunk -> child -> result +-- | The internal data structure built during route declaration. +data Tries x s = Tries + { trieContent :: !(RootedPredTrie T.Text x) + , trieCatchAll :: !(RootedPredTrie T.Text x) + , trieSecurity :: !(RootedPredTrie T.Text s) + } --- | Literal case -instance Extend (EitherUrlChunk 'Nothing) (RootedPredTrie T.Text a) (RootedPredTrie T.Text a) where - extend ((:=) t) (RootedPredTrie mx xs) = RootedPredTrie Nothing $ - PredTrie (MT.MapStep $ Map.singleton t (mx, Just xs)) mempty +instance Monoid (Tries x s) where + mempty = Tries mempty mempty mempty + mappend (Tries x1 x2 x3) (Tries y1 y2 y3) = + ((Tries $! x1 <> y1) + $! x2 <> y2) + $! x3 <> y3 --- | 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 q mx xs]) +-- | The return type of a route building expression like `match` - +-- it should have a shape of @HandlerT (MiddlewareT m) (SecurityToken s) m a@ +-- when used with `route`. +newtype HandlerT x sec m a = HandlerT + { runHandlerT :: S.StateT (Tries x sec) m a + } deriving ( Functor, Applicative, Monad, MonadIO, MonadTrans + , S.MonadState (Tries x sec)) +-- | Run the monad, only getting the built state and throwing away @a@. +execHandlerT :: Monad m => HandlerT x sec m a -> m (Tries x sec) +execHandlerT hs = S.execStateT (runHandlerT hs) mempty --- | @FoldR Extend start chunks ~ result@ -class Extrude chunks start result | chunks start -> result where - extrude :: chunks -> start -> result +{-# INLINEABLE execHandlerT #-} --- Basis -instance Extrude (UrlChunks '[]) (RootedPredTrie T.Text a) (RootedPredTrie T.Text a) where - extrude Root r = r +-- | Deductive proof that prepending a list of types to a function as arity +-- can be deconstructed. +type ExtrudeSoundly cleanxs xs c r = + ( cleanxs ~ CatMaybes xs + , ArityTypeListIso c cleanxs r + , Extrude (UrlChunks xs) + (RootedPredTrie T.Text c) + (RootedPredTrie T.Text 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) +-- | The type of content builders. +type ActionT m a = VerbListenerT (FileExtListenerT m a) m a +-- | Run the content builder into a middleware that responds when the content +-- is satisfiable (i.e. @Accept@ headers are O.K., etc.) +action :: Monad m => ActionT m () -> MiddlewareT m +action xs app req respond = do + vmap <- execVerbListenerT (mapVerbs fileExtsToMiddleware xs) + let v = getVerb req + mMid <- lookupVerb req v vmap + case mMid of + Nothing -> app req respond + Just mid -> mid app req respond diff --git a/src/Web/Routes/Nested/Types/UrlChunks.hs b/src/Web/Routes/Nested/Types/UrlChunks.hs deleted file mode 100644 --- a/src/Web/Routes/Nested/Types/UrlChunks.hs +++ /dev/null @@ -1,93 +0,0 @@ -{-# LANGUAGE - KindSignatures - , GADTs - , RankNTypes - , TypeOperators - , DataKinds - #-} - -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 -import Data.String (IsString (..)) -import qualified Data.Text as T - - - -o_, origin_ :: UrlChunks '[] -o_ = origin_ - --- | The /Origin/ chunk - the equivalent to @[]@ -origin_ = Root - - -l_, literal_ :: T.Text -> EitherUrlChunk 'Nothing -l_ = literal_ - --- | Match against a /Literal/ chunk -literal_ = (:=) - - -p_, parse_ :: (T.Text, Parser r) -> EitherUrlChunk ('Just r) -p_ = parse_ - --- | Match against a /Parsed/ chunk, with . -parse_ (i,q) = (:~) (i, eitherToMaybe . parseOnly q) - - -r_, regex_ :: (T.Text, Regex) -> EitherUrlChunk ('Just [String]) -r_ = regex_ - --- | Match against a /Regular expression/ chunk, with . -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_ = (:~) - - --- | Constrained to AttoParsec, Regex-Compat and T.Text -data EitherUrlChunk (x :: Maybe *) where - (:=) :: 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 = literal_ . T.pack - - --- | 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 '[] - - - --- | Prefix a routable path by more predicative lookup data. -() :: EitherUrlChunk mx -> UrlChunks xs -> UrlChunks (mx ': xs) -() = Cons - -infixr 9 - - --- Utils - -eitherToMaybe :: Either String r -> Maybe r -eitherToMaybe (Right r') = Just r' -eitherToMaybe _ = Nothing diff --git a/test/Web/Routes/NestedSpec.hs b/test/Web/Routes/NestedSpec.hs --- a/test/Web/Routes/NestedSpec.hs +++ b/test/Web/Routes/NestedSpec.hs @@ -21,44 +21,34 @@ get "/" `shouldRespondWith` 200 describe "GET /foo" $ - it "should respond with 200 and 'foo!'" $ + it "should respond with 200" $ get "/foo" `shouldRespondWith` - "" { matchStatus = 200 - , matchBody = Just "foo!" - } + 200 describe "GET /baz" $ - it "should respond with 200 and 'baz!'" $ + it "should respond with 200" $ get "/baz" `shouldRespondWith` - "" { matchStatus = 200 - , matchBody = Just "baz!" - } + 200 describe "GET /borked" $ it "should respond with 404" $ get "/borked" `shouldRespondWith` 404 + describe "Attoparsec Routes" $ + with (return app) $ do + describe "GET /12.34" $ + it "should respond with 200" $ + get "/12.34" `shouldRespondWith` + 200 describe "Regex Routes" $ with (return app) $ do describe "GET /athan@emails.com" $ - it "should respond with 200 and '[\"athan@emails.com\"] email'" $ + it "should respond with 200" $ get "/athan@emails.com" `shouldRespondWith` - "" { matchStatus = 200 - , matchBody = Just "[\"athan@emails.com\"] email" - } - describe "Upload Routes" $ - with (return app) $ do - describe "POST /baz" $ - it "should respond with 200 and 'Woah! Upload content!'" $ - post "/baz" "anything" `shouldRespondWith` - "" { matchStatus = 200 - , matchBody = Just "Woah! Upload content!" - } + 200 describe "Secure Routes" $ with (return app) $ do describe "GET /foo/bar" $ - it "should respond with 401 and 'Unauthorized!'" $ + it "should respond with 401" $ get "/foo/bar" `shouldRespondWith` - "" { matchStatus = 401 - , matchBody = Just "Unauthorized!" - } + 401 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 @@ -2,6 +2,7 @@ OverloadedStrings , ScopedTypeVariables , FlexibleContexts + , DeriveGeneric #-} @@ -12,77 +13,70 @@ import Network.HTTP.Types import Text.Regex import qualified Data.Text.Lazy as LT -import Data.Attoparsec.Text +import Data.Attoparsec.Text hiding (match) import Data.Monoid -import Control.Monad.Except +import Control.Monad.Catch +import Control.Monad.IO.Class +import GHC.Generics data AuthRole = AuthRole deriving (Show, Eq) -data AuthErr = NeedsAuth deriving (Show, Eq) +data AuthErr = NeedsAuth deriving (Show, Eq, Generic) +instance Exception AuthErr + -- | 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 --- @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@, --- so a guest just returns Nothing, and we could handle the case in @putAuth@ to --- not do anything. -authorize :: ( Monad m - ) => Request -> [AuthRole] -> m (Response -> Response, Maybe AuthErr) +-- 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 +-- @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@, +-- so a guest just returns Nothing, and we could handle the case in @putAuth@ to +-- not do anything. +authorize :: ( MonadThrow m + ) => Request -> [AuthRole] -> m () -- authorize _ _ = return id -- uncomment to force constant authorization -authorize req ss | null ss = return (id, Nothing) - | otherwise = return (id, Just NeedsAuth) +authorize req ss | null ss = return () + | otherwise = throwM NeedsAuth defApp :: Application -defApp _ respond = respond $ textOnlyStatus status404 "404 :(" +defApp _ respond = respond $ + textOnly "404 :(" status404 [] +successMiddleware :: Middleware +successMiddleware _ _ respond = respond $ textOnly "200!" status200 [] + app :: Application app = - let yoDawgIHeardYouLikeYoDawgsYo = routeActionAuth authorize routes + let yoDawgIHeardYouLikeYoDawgsYo = + (routeAuth authorize routes) `catchMiddlewareT` unauthHandle 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 + matchHere successMiddleware + matchGroup fooRoute $ do + matchHere successMiddleware + auth AuthRole DontProtectHere + match barRoute successMiddleware + match doubleRoute (\_ -> successMiddleware) + match emailRoute (\_ -> successMiddleware) + match bazRoute successMiddleware in yoDawgIHeardYouLikeYoDawgsYo 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" + doubleRoute = p_ "double" double o_ -- `/athan@foo.com` - 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" + emailRoute = r_ "email" (mkRegex "(^[-a-zA-Z0-9_.]+@[-a-zA-Z0-9]+\\.[-a-zA-Z0-9.]+$)") o_ -- `/baz`, uses regex-compat bazRoute = l_ "baz" o_ - bazHandle = do - get $ text "baz!" - let uploader req = do liftIO $ print =<< strictRequestBody req - return () - uploadHandle (Left Nothing) = text "Upload Failed" - uploadHandle (Left (Just _)) = text "Impossible - no errors thrown in uploader" - uploadHandle (Right ()) = text "Woah! Upload content!" - post uploader uploadHandle - unauthHandle NeedsAuth = get $ textStatus status401 "Unauthorized!" - notFoundHandle = get $ textStatus status404 "Not Found :(" +unauthHandle :: AuthErr -> Middleware +unauthHandle NeedsAuth _ _ respond = respond $ + textOnly "Unauthorized!" status401 []