nested-routes 6.1.0 → 7.0.0

raw patch · 11 files changed

+588/−1087 lines, 11 filesdep +exceptionsdep +hashabledep +unordered-containersdep −base64-bytestringdep −blaze-builderdep −containersdep ~basedep ~composition-extradep ~nested-routessetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: exceptions, hashable, unordered-containers

Dependencies removed: base64-bytestring, blaze-builder, containers, cookie, cryptonite, data-default, iso8601-time, lucid, memory, stm, time, utf8-string, wai-extra, wai-session

Dependency ranges changed: base, composition-extra, nested-routes, poly-arity, pred-trie, wai-middleware-content-type, wai-middleware-verbs, wai-transformers

API changes (from Hackage documentation)

Files

• Setup.hs +2/−0
• examples/Main.hs +113/−49
• examples/STM.hs +0/−137
• examples/STM/Auth.hs +0/−227
• nested-routes.cabal +22/−70
• src/Web/Routes/Nested.hs +237/−378
• src/Web/Routes/Nested/Match.hs +100/−0
• src/Web/Routes/Nested/Types.hs +60/−63
• src/Web/Routes/Nested/Types/UrlChunks.hs +0/−93
• test/Web/Routes/NestedSpec.hs +14/−24
• test/Web/Routes/NestedSpec/Basic.hs +40/−46

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -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 :("

@@ -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 :("-

@@ -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

@@ -1,5 +1,5 @@ Name:                   nested-routes-Version:                6.1.0+Version:                7.0.0 Author:                 Athan Clark <athan.clark@gmail.com> Maintainer:             Athan Clark <athan.clark@gmail.com> License:                BSD3@@ -20,9 +20,7 @@   <https://hackage.haskell.org/package/attoparsec Attoparsec>   parsers and <https://hackage.haskell.org/package/regex-compat Regular Expressions>   /directly/ in our routes, with our handlers-  reflecting their results. You can find more information in the-  <https://www.fpcomplete.com/user/AthanClark/nested-routes demo>.-  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

@@ -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 <https://hackage.haskell.org/package/wai-middleware-verbs wai-middleware-verbs>--- (routing for the incoming HTTP method) and--- <https://hackage.haskell.org/package/wai-middleware-content-type wai-middleware-content-type>--- (routing for the incoming Accept header, and implied file extension),--- <https://hackage.haskell.org/package/wai WAI> itself, and--- <https://hackage.haskell.org/package/wai-transformers wai-transformers> - 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 <https://hackage.haskell.org/package/regex-compat regex-compat>),--- or an <https://hackage.haskell.org/package/attoparsec attoparsec> 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 <https://hackage.haskell.org/package/wai-middleware-verbs wai-middleware-verbs>+(routing for the incoming HTTP method) and+<https://hackage.haskell.org/package/wai-middleware-content-type wai-middleware-content-type>+(routing for the incoming Accept header, and implied file extension),+<https://hackage.haskell.org/package/wai WAI> itself, and+<https://hackage.haskell.org/package/wai-transformers wai-transformers> - 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 <https://hackage.haskell.org/package/regex-compat regex-compat>),+or an <https://hackage.haskell.org/package/attoparsec attoparsec> 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')-       }

@@ -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 <https://hackage.haskell.org/package/attoparsec attoparsec>.+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 <https://hackage.haskell.org/package/regex-compat regex-compat>.+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 </>++

@@ -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

@@ -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 <https://hackage.haskell.org/package/attoparsec attoparsec>.-parse_ (i,q) = (:~) (i, eitherToMaybe . parseOnly q)---r_, regex_ :: (T.Text, Regex) -> EitherUrlChunk ('Just [String])-r_ = regex_---- | Match against a /Regular expression/ chunk, with <https://hackage.haskell.org/package/regex-compat regex-compat>.-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

@@ -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  

@@ -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 []