nested-routes 4.0.0 → 5.0.0

raw patch · 23 files changed

+626/−1326 lines, 23 filesdep +nested-routesdep +wai-middleware-content-typedep +wai-middleware-verbsdep −aesondep −bifunctorsdep −blaze-htmldep ~poly-arityPVP ok

version bump matches the API change (PVP)

Dependencies added: nested-routes, wai-middleware-content-type, wai-middleware-verbs, wai-transformers

Dependencies removed: aeson, bifunctors, blaze-html, clay, composition, constraints, http-media, sets, shakespeare, wai, wai-util, witherable

Dependency ranges changed: poly-arity

API changes (from Hackage documentation)

Files

• examples/Main.hs +20/−22
• examples/STM.hs +25/−32
• examples/STM/Auth.hs +1/−1
• nested-routes.cabal +80/−131
• src/Web/Routes/Nested.hs +330/−303
• src/Web/Routes/Nested/FileExtListener.hs +0/−11
• src/Web/Routes/Nested/FileExtListener/Blaze.hs +0/−61
• src/Web/Routes/Nested/FileExtListener/Builder.hs +0/−41
• src/Web/Routes/Nested/FileExtListener/ByteString.hs +0/−44
• src/Web/Routes/Nested/FileExtListener/Cassius.hs +0/−61
• src/Web/Routes/Nested/FileExtListener/Clay.hs +0/−62
• src/Web/Routes/Nested/FileExtListener/Json.hs +0/−110
• src/Web/Routes/Nested/FileExtListener/Julius.hs +0/−61
• src/Web/Routes/Nested/FileExtListener/Lucid.hs +0/−63
• src/Web/Routes/Nested/FileExtListener/Lucius.hs +0/−61
• src/Web/Routes/Nested/FileExtListener/Text.hs +0/−63
• src/Web/Routes/Nested/FileExtListener/Types.hs +0/−53
• src/Web/Routes/Nested/Types/UrlChunks.hs +12/−12
• src/Web/Routes/Nested/VerbListener.hs +0/−133
• test/Spec.hs +1/−1
• test/Test.hs +5/−0
• test/Web/Routes/NestedSpec.hs +64/−0
• test/Web/Routes/NestedSpec/Basic.hs +88/−0

@@ -7,18 +7,15 @@  module Main where -import Network.Wai+import Web.Routes.Nested+import Network.Wai.Trans import Network.Wai.Handler.Warp import Network.HTTP.Types-import Web.Routes.Nested-import Data.Attoparsec.Text-import Text.Regex-import Data.Monoid+import           Text.Regex import qualified Data.Text.Lazy as LT-import Control.Monad.Error.Class-import Control.Monad.IO.Class--import Debug.Trace+import           Data.Attoparsec.Text+import Data.Monoid+import Control.Monad.Except   data AuthRole = AuthRole deriving (Show, Eq)@@ -45,16 +42,16 @@  main :: IO () main =-  let app = routeAuth authorize routes+  let app = routeActionAuth authorize routes       routes =-        handle o (Just rootHandle) $ Just $ do-          handle fooRoute (Just fooHandle) $ Just $ do+        handleAction o (Just rootHandle) $ Just $ do+          handleAction fooRoute (Just fooHandle) $ Just $ do             auth AuthRole unauthHandle ProtectChildren-            handle barRoute    (Just barHandle)    Nothing-            handle doubleRoute (Just doubleHandle) Nothing-          handle emailRoute (Just emailHandle) Nothing-          handle bazRoute (Just bazHandle) Nothing-          notFound o (Just notFoundHandle) Nothing+            handleAction barRoute    (Just barHandle)    Nothing+            handleAction doubleRoute (Just doubleHandle) Nothing+          handleAction emailRoute (Just emailHandle) Nothing+          handleAction bazRoute (Just bazHandle) Nothing+          notFoundAction o (Just notFoundHandle) Nothing   in run 3000 $ app defApp   where     rootHandle = get $ text "Home"@@ -69,7 +66,7 @@       text "bar!"       json ("json bar!" :: LT.Text) -    -- `/foo/1234e12`+    -- `/foo/1234e12`, uses attoparsec     doubleRoute = p ("double", double) </> o     doubleHandle d = get $ text $ LT.pack (show d) <> " foos" @@ -77,14 +74,15 @@     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`+    -- `/baz`, uses regex-compat     bazRoute = l "baz" </> o     bazHandle = do       get $ text "baz!"       let uploader req = do liftIO $ print =<< strictRequestBody req-                            return $ Just ()-          uploadHandle Nothing = text "Upload Failed"-          uploadHandle (Just ()) = text "Woah! Upload content!"+                            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!"

@@ -10,13 +10,11 @@ import STM.Auth import STM.Templates -import Network.Wai+import Network.Wai.Trans import Network.Wai.Handler.Warp-import Network.Wai.Session import Network.Wai.Parse import Network.HTTP.Types import Web.Routes.Nested-import Web.Cookie import Data.Attoparsec.Text import Text.Regex import Data.Monoid@@ -24,8 +22,6 @@ import qualified Data.ByteString as BS import qualified Data.IntMap as IntMap import Data.ByteArray (convert)-import Data.Time-import Data.Maybe import Data.Function.Syntax  import Control.Concurrent.STM@@ -35,13 +31,10 @@ import Control.Monad.Reader import Control.Monad.Trans.Maybe import Crypto.Random-import Crypto.Random.Types import Crypto.Hash  -data LoginError a = InvalidLoginAttempt-                  | Success a-+data LoginError = InvalidLoginAttempt  defApp :: Application defApp _ respond = respond $ textOnlyStatus status404 "404 :("@@ -54,22 +47,19 @@              let n' = hash n :: Digest SHA512                  n'' = convert n' :: BS.ByteString              return n''-  let app a r1 r2 = runReaderT (routeAuth authenticate routes (liftIO .* a) r1 r2) $ AuthEnv cacheVar uIdVar salt-      -- routes :: ( MonadReader AuthEnv m-      --           , MonadIO m-      --           ) => RoutesT (LoginError (UserSession BS.ByteString)) SecurityLayer AuthenticationError m ()+  let app a r1 r2 = runReaderT (routeActionAuth authenticate routes (liftIO .* a) r1 r2) $ AuthEnv cacheVar uIdVar salt       routes = do-        handle o (Just rootHandle) Nothing-        handle fooRoute (Just fooHandle) $ Just $ do+        handleAction o (Just rootHandle) Nothing+        handleAction fooRoute (Just fooHandle) $ Just $ do           auth ShouldBeLoggedIn unauthHandle ProtectChildren-          handle barRoute    (Just barHandle)    Nothing-          handle doubleRoute (Just doubleHandle) Nothing-        handle emailRoute (Just emailHandle) Nothing-        handle bazRoute (Just bazHandle) Nothing-        handle loginRoute (Just loginHandle) Nothing-        handle logoutRoute (Just logoutHandle) $ Just $+          handleAction barRoute    (Just barHandle)    Nothing+          handleAction doubleRoute (Just doubleHandle) Nothing+        handleAction emailRoute (Just emailHandle) Nothing+        handleAction bazRoute (Just bazHandle) Nothing+        handleAction loginRoute (Just loginHandle) Nothing+        handleAction logoutRoute (Just logoutHandle) $ Just $           auth ShouldBeLoggedIn unauthHandle ProtectParent-        notFound o (Just notFoundHandle) Nothing+        notFoundAction o (Just notFoundHandle) Nothing   run 3000 $ app defApp   where     rootHandle = get $ text "Home"@@ -97,9 +87,11 @@     bazHandle = do       get $ text "baz!"       let uploader req = do liftIO $ print =<< strictRequestBody req-                            return Nothing-          uploadHandle Nothing = text "Upload Failed"-          uploadHandle (Just _) = text "Woah! Upload content!"+                            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      loginRoute = "login" </> o@@ -107,16 +99,16 @@       get $ lucid loginPage       postReq (login 128) loginResp         where-          loginResp _ Nothing = textStatus status500 "Server malfunction :E"-          loginResp _ (Just InvalidLoginAttempt) = textStatusWith clearSessionResponse status403 "Bad login"-          loginResp _ (Just (Success u)) = textWith (mapResponseHeaders (++ makeSessionCookies u)) "logged-in"+          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 return $ Just InvalidLoginAttempt+          then throwError $ Just InvalidLoginAttempt           else do             mSuccess <- runMaybeT $ do               user <- hoistMaybe $ lookup "user" ps@@ -124,9 +116,9 @@               liftIO $ putStrLn $ "<~!~> Attempted Login: " ++ show user ++ ", " ++ show pass ++ "\n"               nUserSess <- newUserSession               lift $ writeUserSession nUserSess-              return $ Success nUserSess-            return $ Just $ fromMaybe InvalidLoginAttempt mSuccess-        _ -> return $ Just InvalidLoginAttempt+              return nUserSess+            note' (Just InvalidLoginAttempt) mSuccess+        _ -> throwError $ Just InvalidLoginAttempt       where         firstIs _ [] = True         firstIs f (x:_) = f x@@ -147,3 +139,4 @@     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 :("+

@@ -5,7 +5,7 @@  module STM.Auth where -import Network.Wai+import Network.Wai.Trans import Network.Wai.Handler.Warp import Network.Wai.Session import Network.HTTP.Types

@@ -1,5 +1,5 @@ Name:                   nested-routes-Version:                4.0.0+Version:                5.0.0 Author:                 Athan Clark <athan.clark@gmail.com> Maintainer:             Athan Clark <athan.clark@gmail.com> License:                BSD3@@ -43,84 +43,57 @@   Exposed-Modules:      Web.Routes.Nested                         Web.Routes.Nested.Types                         Web.Routes.Nested.Types.UrlChunks-                        Web.Routes.Nested.VerbListener-                        Web.Routes.Nested.FileExtListener-                        Web.Routes.Nested.FileExtListener.Types-                        Web.Routes.Nested.FileExtListener.Text-                        Web.Routes.Nested.FileExtListener.Json-                        Web.Routes.Nested.FileExtListener.Builder-                        Web.Routes.Nested.FileExtListener.Blaze-                        Web.Routes.Nested.FileExtListener.ByteString-                        Web.Routes.Nested.FileExtListener.Lucid-                        Web.Routes.Nested.FileExtListener.Clay-                        Web.Routes.Nested.FileExtListener.Julius-                        Web.Routes.Nested.FileExtListener.Lucius-                        Web.Routes.Nested.FileExtListener.Cassius   Build-Depends:        base >= 4.6 && < 5-                      , wai-                      , wai-extra-                      , wai-util-                      , http-types-                      , http-media-                      , mtl-                      , transformers-                      , witherable-                      , composition+                      , attoparsec+                      , bytestring                       , composition-extra >= 2.0.0-                      , semigroups-                      , constraints                       , containers-                      , text-                      , aeson-                      , blaze-html-                      , lucid-                      , shakespeare-                      , clay-                      , bytestring-                      , bifunctors-                      , attoparsec-                      , regex-compat+                      , mtl+                      , poly-arity >= 0.0.7                       , pred-trie >= 0.3+                      , regex-compat+                      , semigroups+                      , text+                      , transformers                       , tries-                      , poly-arity >= 0.0.6-                      , sets >= 0.0.5-                      , errors+                      , wai-transformers+                      , wai-middleware-content-type >= 0.0.3+                      , wai-middleware-verbs >= 0.0.4 -Test-Suite spec-  Type:                 exitcode-stdio-1.0++Test-Suite test+  Type:                exitcode-stdio-1.0   Default-Language:     Haskell2010-  Hs-Source-Dirs:       src+  HS-Source-Dirs:       src                       , test-  Ghc-Options:          -Wall-  Main-Is:              Spec.hs+  GHC-Options:          -Wall -threaded+  Main-Is:              Test.hs+  Other-Modules:        Spec+                        Web.Routes.NestedSpec+                        Web.Routes.NestedSpec.Basic+                        Web.Routes.Nested+                        Web.Routes.Nested.Types+                        Web.Routes.Nested.Types.UrlChunks   Build-Depends:        base-                      , hspec-                      , hspec-wai-                      , shakespeare-                      , lucid+                      , nested-routes                       , attoparsec-                      , regex-compat-                      , containers-                      , composition-                      , composition-extra-                      , semigroups-                      , text-                      , aeson-                      , wai-util-                      , blaze-html                       , bytestring+                      , composition-extra+                      , containers+                      , http-types+                      , mtl                       , poly-arity-                      , witherable-                      , constraints                       , pred-trie-                      , mtl-                      , wai-                      , warp+                      , regex-compat+                      , semigroups+                      , text                       , transformers-                      , http-media-                      , http-types-                      , sets-                      , errors+                      , tries+                      , wai-transformers+                      , wai-middleware-content-type+                      , wai-middleware-verbs+                      , hspec+                      , hspec-wai   Executable example@@ -133,36 +106,30 @@                       , examples   GHC-Options:          -Wall   Main-Is:              Main.hs+  Other-Modules:        Web.Routes.Nested+                        Web.Routes.Nested.Types+                        Web.Routes.Nested.Types.UrlChunks   Build-Depends:        base-                      , wai-                      , wai-extra-                      , wai-util-                      , warp+                      , nested-routes+                      , attoparsec+                      , bytestring+                      , composition-extra+                      , containers                       , http-types-                      , http-media                       , mtl-                      , transformers-                      , witherable-                      , composition-                      , composition-extra+                      , poly-arity+                      , pred-trie+                      , regex-compat                       , semigroups-                      , constraints-                      , containers                       , text-                      , aeson-                      , blaze-html-                      , lucid-                      , shakespeare-                      , clay-                      , bytestring-                      , attoparsec-                      , regex-compat-                      , pred-trie+                      , transformers                       , tries-                      , poly-arity-                      , sets-                      , errors+                      , wai-transformers+                      , wai-middleware-content-type+                      , wai-middleware-verbs+                      , warp + Executable example-stm   if flag(Example-STM)     Buildable: True@@ -175,59 +142,41 @@   Main-Is:              STM.hs   Other-Modules:        STM.Auth                         Web.Routes.Nested-                        Web.Routes.Nested.FileExtListener-                        Web.Routes.Nested.FileExtListener.Blaze-                        Web.Routes.Nested.FileExtListener.Builder-                        Web.Routes.Nested.FileExtListener.ByteString-                        Web.Routes.Nested.FileExtListener.Json-                        Web.Routes.Nested.FileExtListener.Lucid-                        Web.Routes.Nested.FileExtListener.Text-                        Web.Routes.Nested.FileExtListener.Types                         Web.Routes.Nested.Types                         Web.Routes.Nested.Types.UrlChunks-                        Web.Routes.Nested.VerbListener   Build-Depends:        base-                      , wai-                      , wai-extra-                      , wai-session+                      , base64-bytestring+                      , blaze-builder+                      , nested-routes+                      , attoparsec+                      , bytestring+                      , composition-extra+                      , containers                       , cookie-                      , wai-util-                      , warp+                      , cryptonite+                      , data-default+                      , errors                       , http-types-                      , http-media+                      , iso8601-time+                      , lucid+                      , memory                       , mtl-                      , transformers-                      , witherable-                      , composition-                      , composition-extra+                      , poly-arity+                      , pred-trie+                      , regex-compat                       , semigroups-                      , constraints-                      , containers+                      , stm                       , text-                      , aeson-                      , blaze-html-                      , lucid-                      , shakespeare-                      , clay-                      , bytestring-                      , attoparsec-                      , regex-compat-                      , pred-trie-                      , tries-                      , poly-arity-                      , sets-                      , errors-                      , cryptonite-                      , memory                       , time-                      , iso8601-time+                      , transformers+                      , tries+                      , wai-extra+                      , wai-middleware-content-type+                      , wai-middleware-verbs+                      , wai-transformers+                      , wai-session+                      , warp                       , utf8-string-                      , stm-                      , errors-                      , cookie-                      , data-default-                      , blaze-builder-                      , base64-bytestring  Source-Repository head   Type:                 git

@@ -1,297 +1,413 @@ {-# LANGUAGE-    DeriveFunctor-  , GADTs-  , GeneralizedNewtypeDeriving-  , ScopedTypeVariables+    GADTs+  , PolyKinds+  , TypeFamilies+  , DeriveFunctor   , TypeOperators-  , OverloadedStrings   , TupleSections+  , DoAndIfThenElse+  , ConstraintKinds   , FlexibleContexts-  , TypeFamilies-  , PolyKinds-  , UndecidableInstances+  , 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-  ( -- * Types-    module X+  ( module X+  -- * Types   , Tries   , HandlerT (..)+  , execHandlerT   , ActionT-  , RoutesT-  , ApplicationT-  , MiddlewareT+  , RoutableT+  , RoutableActionT   , AuthScope (..)+  , ExtrudeSoundly   -- * Combinators   , handle+  , handleAction   , parent   , auth   , notFound-  -- * Entry Point+  , notFoundAction+  , action+  -- * Routing   , route   , routeAuth+  , routeAction+  , routeActionAuth   -- * Extraction   , extractContent   , extractNotFound   , extractAuthSym   , extractAuth   , extractNearestVia-  -- * Utilities   , actionToMiddleware-  , lookupVerb-  , lookupFileExt-  , lookupUpload-  , lookupResponse-  -- ** File Extensions-  , possibleFileExts-  , trimFileExt-  , getFileExt-  , httpMethodToMSym   ) where -import           Web.Routes.Nested.Types as X-import           Web.Routes.Nested.FileExtListener as X-import           Web.Routes.Nested.FileExtListener.Types as X-import           Web.Routes.Nested.VerbListener as X--import           Network.HTTP.Types-import           Network.HTTP.Media-import           Network.Wai+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           Data.Trie.Pred (RootedPredTrie (..), PredTrie (..))-import qualified Data.Trie.Pred                    as PT -- only using lookups-import           Data.Trie.Pred.Step (PredSteps (..), PredStep (..))-import qualified Data.Trie.Class                   as TC-import qualified Data.Text                         as T-import qualified Data.Map                          as Map-import           Data.Trie.Map (MapStep (..))-import qualified Data.ByteString                   as B-import           Data.List.NonEmpty (NonEmpty (..))-import qualified Data.List.NonEmpty                as NE-import           Data.Maybe                        (fromMaybe)-import           Data.Witherable hiding (filter)+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.Class                    as TC+import           Data.Trie.Map                      (MapStep (..))+import qualified Data.Map                           as Map+import           Data.List.NonEmpty                 (NonEmpty (..))+import qualified Data.List.NonEmpty                 as NE+import qualified Data.Text                          as T+import           Data.Maybe                         (fromMaybe)+import           Data.Monoid+import           Data.Foldable import           Data.Functor.Syntax import           Data.Function.Poly-import           Data.List hiding (filter) -import           Control.Error.Util import           Control.Monad import           Control.Monad.IO.Class import           Control.Monad.Trans import           Control.Monad.Trans.Except-import           Control.Monad.Trans.Maybe-import           Control.Monad.Writer+import qualified Control.Monad.State                as S  -type Tries x s e e' = ( RootedPredTrie T.Text x-                      , RootedPredTrie T.Text x-                      , RootedPredTrie T.Text s-                      , RootedPredTrie T.Text e-                      )+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 errSym uploadSym m a = HandlerT-  { runHandlerT :: WriterT (Tries x sec err errSym) m a }+newtype HandlerT x sec err aux m a = HandlerT+  { runHandlerT :: S.StateT (Tries x sec err) m a }   deriving ( Functor            , Applicative            , Monad            , MonadIO            , MonadTrans-           , MonadWriter (Tries x sec err errSym)+           , S.MonadState (Tries x sec err)            ) -execHandlerT :: Monad m => HandlerT x sec err errSym uploadSym m a -> m (Tries x sec err errSym)-execHandlerT = execWriterT . runHandlerT+execHandlerT :: Monad m => HandlerT x sec err aux m a -> m (Tries x sec err)+execHandlerT hs = S.execStateT (runHandlerT hs) mempty -type ActionT u m a = VerbListenerT (FileExtListenerT Response m a) u m a+type ActionT e u m a = VerbListenerT (FileExtListenerT (MiddlewareT m) m a) e u m a -type RoutesT u s e m a = HandlerT (ActionT u m a) (s, AuthScope) (e -> ActionT u 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 --- | For routes ending with a literal.++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)+  )+++-- | Embed an @ActionT@ into a set of routes directly, without first converting+-- it to a @MiddlewareT@.+handleAction :: ( Monad m+                , Functor m+                , cleanxs ~ CatMaybes xs+                , HasResult childContent (ActionT ue u m ())+                , HasResult childErr     (e -> ActionT ue u m ())+                , ExpectArity cleanxs childContent+                , ExpectArity cleanxs childSec+                , ExpectArity cleanxs childErr+                , Singleton (UrlChunks xs)+                    childContent+                    (RootedPredTrie T.Text resultContent)+                , ExtrudeSoundly cleanxs xs childContent resultContent+                , ExtrudeSoundly cleanxs xs childSec     resultSec+                , ExtrudeSoundly cleanxs xs childErr     resultErr+                ) => UrlChunks xs+                  -> Maybe childContent+                  -> Maybe (HandlerT childContent  childSec  childErr  (e,u,ue) m ())+                  ->        HandlerT resultContent resultSec resultErr (e,u,ue) m ()+handleAction ts (Just vl) Nothing = tell' (singleton ts vl, mempty, mempty, mempty)+handleAction ts mvl (Just cs) = do+  (RootedPredTrie _ trieContent,trieNotFound,trieSec,trieErr) <- lift $ execHandlerT cs+  tell' ( extrude ts $ RootedPredTrie mvl trieContent+        , extrude ts trieNotFound+        , extrude ts trieSec+        , extrude ts trieErr+        )+handleAction _ Nothing Nothing = return ()++-- | Embed a @MiddlewareT@ into a set of routes. handle :: ( Monad m           , Functor m           , cleanxs ~ CatMaybes xs-          , HasResult childContent (ActionT u m ())-          , HasResult childErr     (e -> ActionT u m ())+          , HasResult childContent (MiddlewareT m)+          , HasResult childErr     (e -> MiddlewareT m)           , ExpectArity cleanxs childContent           , ExpectArity cleanxs childSec           , ExpectArity cleanxs childErr           , Singleton (UrlChunks xs)               childContent               (RootedPredTrie T.Text resultContent)-          , Extrude (UrlChunks xs)-              (RootedPredTrie T.Text childContent)-              (RootedPredTrie T.Text resultContent)-          , Extrude (UrlChunks xs)-              (RootedPredTrie T.Text childSec)-              (RootedPredTrie T.Text resultSec)-          , Extrude (UrlChunks xs)-              (RootedPredTrie T.Text childErr)-              (RootedPredTrie T.Text resultErr)-          , (ArityMinusTypeList childContent cleanxs) ~ resultContent-          , (ArityMinusTypeList childSec cleanxs) ~ resultSec-          , (ArityMinusTypeList childErr cleanxs) ~ resultErr-          , childContent ~ TypeListToArity cleanxs resultContent-          , childSec ~ TypeListToArity cleanxs resultSec-          , childErr ~ TypeListToArity cleanxs resultErr+          , ExtrudeSoundly cleanxs xs childContent resultContent+          , ExtrudeSoundly cleanxs xs childSec     resultSec+          , ExtrudeSoundly cleanxs xs childErr     resultErr           ) => UrlChunks xs             -> Maybe childContent-            -> Maybe (HandlerT childContent  childSec  childErr  e u m ())-            ->        HandlerT resultContent resultSec resultErr e u m ()-handle ts (Just vl) Nothing = tell (singleton ts vl, mempty, mempty, mempty)+            -> Maybe (HandlerT childContent  childSec  childErr  (e,u,ue) m ())+            ->        HandlerT resultContent resultSec resultErr (e,u,ue) m ()+handle ts (Just vl) Nothing = tell' (singleton ts vl, mempty, mempty, mempty) handle ts mvl (Just cs) = do   (RootedPredTrie _ trieContent,trieNotFound,trieSec,trieErr) <- lift $ execHandlerT cs-  tell ( extrude ts $ RootedPredTrie mvl trieContent-       , extrude ts trieNotFound-       , extrude ts trieSec-       , extrude ts trieErr-       )+  tell' ( extrude ts $ RootedPredTrie mvl trieContent+        , extrude ts trieNotFound+        , extrude ts trieSec+        , extrude ts trieErr+        ) handle _ Nothing Nothing = return () +-- | Prepend a path to an existing set of routes. parent :: ( Monad m           , Functor m           , cleanxs ~ CatMaybes xs           , Singleton (UrlChunks xs)               childContent               (RootedPredTrie T.Text resultContent)-          , Extrude (UrlChunks xs)-              (RootedPredTrie T.Text childContent)-              (RootedPredTrie T.Text resultContent)-          , Extrude (UrlChunks xs)-              (RootedPredTrie T.Text childErr)-              (RootedPredTrie T.Text resultErr)-          , Extrude (UrlChunks xs)-              (RootedPredTrie T.Text childSec)-              (RootedPredTrie T.Text resultSec)-          , (ArityMinusTypeList childContent cleanxs) ~ resultContent-          , (ArityMinusTypeList childSec cleanxs) ~ resultSec-          , (ArityMinusTypeList childErr cleanxs) ~ resultErr-          , childContent ~ TypeListToArity cleanxs resultContent-          , childSec ~ TypeListToArity cleanxs resultSec-          , childErr ~ TypeListToArity cleanxs resultErr+          , ExtrudeSoundly cleanxs xs childContent resultContent+          , ExtrudeSoundly cleanxs xs childSec     resultSec+          , ExtrudeSoundly cleanxs xs childErr     resultErr           ) => UrlChunks xs-            -> HandlerT childContent  childSec  childErr  e u m ()-            -> HandlerT resultContent resultSec resultErr e u m ()+            -> 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-       )+  tell' ( extrude ts trieContent+        , extrude ts trieNotFound+        , extrude ts trieSec+        , extrude ts trieErr+        )  +-- | Designate the scope of security to the set of routes - either only the adjacent+-- routes, or the adjacent /and/ the parent container node (root node if not+-- declared). data AuthScope = ProtectParent | ProtectChildren   deriving (Show, Eq) --- | Sets the security role and error handler for a scope of routes.+-- | 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 e u m ()+          -> HandlerT content (sec, AuthScope) err aux m () auth token handleFail scope =-  tell ( mempty-       , mempty-       , RootedPredTrie (Just (token,scope)) mempty-       , RootedPredTrie (Just handleFail) mempty-       )+  tell' ( mempty+        , mempty+        , RootedPredTrie (Just (token,scope)) mempty+        , RootedPredTrie (Just handleFail) mempty+        )  +-- | 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+                  , cleanxs ~ CatMaybes xs+                  , HasResult childContent (ActionT ue u m ())+                  , HasResult childErr     (e -> ActionT ue u m ())+                  , ExpectArity cleanxs childContent+                  , ExpectArity cleanxs childSec+                  , ExpectArity cleanxs childErr+                  , Singleton (UrlChunks xs)+                      childContent+                      (RootedPredTrie T.Text resultContent)+                  , ExtrudeSoundly cleanxs xs childContent resultContent+                  , ExtrudeSoundly cleanxs xs childSec     resultSec+                  , ExtrudeSoundly cleanxs xs childErr     resultErr+                  ) => UrlChunks xs+                    -> Maybe childContent+                    -> Maybe (HandlerT childContent  childSec  childErr  (e,u,ue) m ())+                    ->        HandlerT resultContent resultSec resultErr (e,u,ue) m ()+notFoundAction ts (Just vl) Nothing = tell' (mempty, singleton ts vl, mempty, mempty)+notFoundAction ts mvl (Just cs) = do+  (trieContent,RootedPredTrie _ trieNotFound,trieSec,trieErr) <- lift $ execHandlerT cs+  tell' ( extrude ts trieContent+        , extrude ts $ RootedPredTrie mvl trieNotFound+        , extrude ts trieSec+        , extrude ts trieErr+        )+notFoundAction _ Nothing Nothing = return ()++-- | Embed a @MiddlewareT@ as a not-found handler into a set of routes. notFound :: ( Monad m             , Functor m             , cleanxs ~ CatMaybes xs-            , HasResult childContent (ActionT u m ())-            , HasResult childErr     (e -> ActionT u m ())+            , HasResult childContent (MiddlewareT m)+            , HasResult childErr     (e -> MiddlewareT m)             , ExpectArity cleanxs childContent             , ExpectArity cleanxs childSec             , ExpectArity cleanxs childErr             , Singleton (UrlChunks xs)                 childContent                 (RootedPredTrie T.Text resultContent)-            , Extrude (UrlChunks xs)-                (RootedPredTrie T.Text childContent)-                (RootedPredTrie T.Text resultContent)-            , Extrude (UrlChunks xs)-                (RootedPredTrie T.Text childSec)-                (RootedPredTrie T.Text resultSec)-            , Extrude (UrlChunks xs)-                (RootedPredTrie T.Text childErr)-                (RootedPredTrie T.Text resultErr)-            , (ArityMinusTypeList childContent cleanxs) ~ resultContent-            , (ArityMinusTypeList childSec cleanxs) ~ resultSec-            , (ArityMinusTypeList childErr cleanxs) ~ resultErr-            , childContent ~ TypeListToArity cleanxs resultContent-            , childSec ~ TypeListToArity cleanxs resultSec-            , childErr ~ TypeListToArity cleanxs resultErr+            , ExtrudeSoundly cleanxs xs childContent resultContent+            , ExtrudeSoundly cleanxs xs childSec     resultSec+            , ExtrudeSoundly cleanxs xs childErr     resultErr             ) => UrlChunks xs               -> Maybe childContent-              -> Maybe (HandlerT childContent  childSec  childErr  e u m ())-              ->        HandlerT resultContent resultSec resultErr e u m ()-notFound ts (Just vl) Nothing = tell (mempty, singleton ts vl, mempty, mempty)+              -> Maybe (HandlerT childContent  childSec  childErr  (e,u,ue) m ())+              ->        HandlerT resultContent resultSec resultErr (e,u,ue) m ()+notFound ts (Just vl) Nothing = tell' (mempty, singleton ts vl, mempty, mempty) notFound ts mvl (Just cs) = do   (trieContent,RootedPredTrie _ trieNotFound,trieSec,trieErr) <- lift $ execHandlerT cs-  tell ( extrude ts trieContent-       , extrude ts $ RootedPredTrie mvl trieNotFound-       , extrude ts trieSec-       , extrude ts trieErr-       )+  tell' ( extrude ts trieContent+        , extrude ts $ RootedPredTrie mvl trieNotFound+        , extrude ts trieSec+        , extrude ts trieErr+        ) notFound _ Nothing Nothing = return ()  ---type ApplicationT m = Request -> (Response -> IO ResponseReceived) -> m ResponseReceived-type MiddlewareT m = ApplicationT m -> ApplicationT m--type AcceptHeader = B.ByteString-+-- * Routing --------------------------------------- --- | Turns a @HandlerT@ into a Wai @Application@+-- | Turns a @HandlerT@ containing @MiddlewareT@s into a @MiddlewareT@. route :: ( Functor m          , Monad m          , MonadIO m-         ) => HandlerT (ActionT u m ()) sec err e u m a -- ^ Assembled @handle@ calls+         ) => HandlerT (MiddlewareT m) sec err aux m () -- ^ Assembled @handle@ calls            -> MiddlewareT m route hs = extractContent hs . extractNotFound hs  --- | Given a security verification function which returns an updating function,--- turn a set of routes into a middleware, where a session is secured before--- responding.+-- | 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] -> ExceptT e m (Response -> Response)) -- ^ authorize-               -> RoutesT u sec e m () -- ^ Assembled @handle@ calls+               -> RoutableT sec e u ue m () -- ^ Assembled @handle@ calls                -> MiddlewareT m routeAuth authorize hs = extractAuth authorize hs . route hs --- | Turn the trie carrying the main content into a middleware.+-- | 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++-- | Exactly like @routeAuth@, but specialized for @ActionT@.+routeActionAuth :: ( Functor m+                   , Monad m+                   , MonadIO m+                   ) => (Request -> [sec] -> ExceptT e m (Response -> Response)) -- ^ authorize+                     -> RoutableActionT sec e u ue m () -- ^ Assembled @handle@ calls+                     -> MiddlewareT m+routeActionAuth authorize = routeAuth authorize . actionToMiddleware+++-- | 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+        )+++-- * Extraction -------------------------------++-- | Extracts only the normal @handle@ (content) routes into+-- a @MiddlewareT@, disregarding security and not-found responses. extractContent :: ( Functor m                   , Monad m                   , MonadIO m-                  ) => HandlerT (ActionT u m ()) sec err e u m a -- ^ Assembled @handle@ calls+                  ) => HandlerT (MiddlewareT m) sec err aux m a                     -> MiddlewareT m extractContent hs app req respond = do-  (rtrie,_,_,_) <- execHandlerT hs-  let mAcceptBS = Prelude.lookup ("Accept" :: HeaderName) $ requestHeaders req-      fe = getFileExt req-      v = getVerb req-  case lookupWithLRPT trimFileExt (pathInfo req) rtrie of+  (trie,_,_,_) <- execHandlerT hs+  case lookupWithLRPT trimFileExt (pathInfo req) trie of     Nothing -> fromMaybe (app req respond) $ do-      guard $ not $ null $ pathInfo req+      guard $ not . null $ pathInfo req       guard $ trimFileExt (last $ pathInfo req) == "index"-      found <- TC.lookup (init $ pathInfo req) rtrie-      Just $ actionToMiddleware mAcceptBS fe v found app req respond-    Just found -> actionToMiddleware mAcceptBS fe v found app req respond+      mid <- TC.lookup (init $ pathInfo req) trie+      Just $    mid app req respond+    Just mid -> mid app req respond  --- | Manually fetch the security tokens / authorization roles affiliated with--- a request and your routing system.+-- | 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 e u m a+                  ) => HandlerT x (sec, AuthScope) err aux m a                     -> Request                     -> m [sec] extractAuthSym hs req = do@@ -299,192 +415,103 @@   return $ foldl go [] (PT.matchesRPT (pathInfo req) trie)   where     go ys (_,(_,ProtectChildren),[]) = ys-    go ys (_,(x,_),_) = ys ++ [x]-+    go ys (_,(x,_              ),_ ) = ys ++ [x] +-- | Extracts only the security handling logic into a @MiddlewareT@. extractAuth :: ( Functor m-                   , Monad m-                   , MonadIO m-                   ) => (Request -> [sec] -> ExceptT e m (Response -> Response)) -- authorization method-                     -> HandlerT x (sec, AuthScope) (e -> ActionT u m ()) e u m a-                     -> MiddlewareT m+               , Monad m+               , MonadIO m+               ) => (Request -> [sec] -> ExceptT e m (Response -> Response)) -- authorization method+                 -> HandlerT x (sec, AuthScope) (e -> MiddlewareT m) aux m a+                 -> MiddlewareT m extractAuth authorize hs app req respond = do   (_,_,_,trie) <- execHandlerT hs   ss <- extractAuthSym hs req   ef <- runExceptT $ authorize req ss-  let acceptBS = Prelude.lookup ("Accept" :: HeaderName) $ requestHeaders req-      fe = getFileExt req-      v = getVerb req   either (\e -> maybe (app req respond)-                      (\action -> actionToMiddleware acceptBS fe v action app req respond)+                      (\mid -> mid app req respond)                     $ (getResultsFromMatch <$> PT.matchRPT (pathInfo req) trie) <$~> e)          (\f -> app req (respond . f))          ef --- | Turns the not-found trie into a final application, matching all routes under--- each @notFound@ node. If there is no nearest parent (querying above the head--- of the tree), control is passed down the middlware chain.+-- | Extracts only the @notFound@ responses into a @MiddlewareT@. extractNotFound :: ( Functor m                    , Monad m                    , MonadIO m-                   ) => HandlerT (ActionT u m ()) sec err e u m a+                   ) => HandlerT (MiddlewareT m) sec err aux m a                      -> MiddlewareT m extractNotFound = extractNearestVia (execHandlerT >=> \(_,t,_,_) -> return t)  --- | Only return content, do not handle uploads. Also, the extraction should be--- flat, in that the values contained in our trie are only @ActionT@, without arity.+-- | 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 (ActionT u m ()) sec err e u m a -> m (RootedPredTrie T.Text (ActionT u m ())))-                       -> HandlerT (ActionT u m ()) sec err e u m a+                     ) => (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   trie <- extr hs-  let acceptBS = Prelude.lookup ("Accept" :: HeaderName) $ requestHeaders req-      fe = getFileExt req-      v = getVerb req   maybe (app req respond)-        (\action -> actionToMiddleware acceptBS fe v action app req respond)+        (\mid -> mid app req respond)       $ getResultsFromMatch <$> PT.matchRPT (pathInfo req) trie  +getResultsFromMatch :: ([s],a,[s]) -> a+getResultsFromMatch (_,x,_) = x --- | Turn an @ActionT@ into a @Middleware@ by providing a @FileExt@ and @Verb@--- to lookup, returning the response and utilizing the upload handler encoded--- in the action.-actionToMiddleware :: MonadIO m =>-                      Maybe AcceptHeader -- @Accept@ header-                   -> FileExt-                   -> Verb-                   -> ActionT u m ()-                   -> MiddlewareT m-actionToMiddleware mAcceptBS f v found app req respond = do-  mApp <- runMaybeT $ do-    mContinue            <- lift $ lookupUpload v req found-    (reqbodyf, continue) <- hoistMaybe mContinue-    mUploadData          <- lift reqbodyf-    mResponse            <- lift $ lookupResponse mAcceptBS f $ continue mUploadData-    response             <- hoistMaybe mResponse-    return $ liftIO $ respond response-  fromMaybe (app req respond) mApp  -lookupUpload :: Monad m =>-                Verb-             -> Request-             -> VerbListenerT r u m ()-             -> m (Maybe (m (Maybe u), Maybe u -> r))-lookupUpload v req action = runMaybeT $ do-  vmap <- lift $ execVerbListenerT action-  hoistMaybe $ lookupVerb v req vmap--lookupResponse :: Monad m =>-                  Maybe AcceptHeader-               -> FileExt-               -> FileExtListenerT a m ()-               -> m (Maybe a)-lookupResponse mAcceptBS f fexts = runMaybeT $ do-  femap <- lift $ execFileExtListenerT fexts-  hoistMaybe $ lookupFileExt mAcceptBS f femap---lookupVerb :: Verb -> Request -> Verbs u m r -> Maybe (m (Maybe u), Maybe u -> r)-lookupVerb v req vmap = Map.lookup v $ supplyReq req $ unVerbs vmap----- | Given a possible @Accept@ header and file extension key, lookup the contents--- of a map.-lookupFileExt :: Maybe AcceptHeader -> FileExt -> FileExts a -> Maybe a-lookupFileExt mAccept k (FileExts xs) =-  let attempts = maybe [Html,Text,Json,JavaScript,Css]-                   (possibleFileExts k) mAccept-  in getFirst $ foldMap (First . flip Map.lookup xs) attempts----- | Takes a subject file extension and an @Accept@ header, and returns the other--- types of file types handleable, in order of prescedence.-possibleFileExts :: FileExt -> AcceptHeader -> [FileExt]-possibleFileExts fe accept =-  let computed = sortFE fe $ nub $ concat $-        catMaybes [ mapAccept [ ("application/json" :: B.ByteString, [Json])-                              , ("application/javascript" :: B.ByteString, [Json,JavaScript])-                              ] accept-                  , mapAccept [ ("text/html" :: B.ByteString, [Html])-                              ] accept-                  , mapAccept [ ("text/plain" :: B.ByteString, [Text])-                              ] accept-                  , mapAccept [ ("text/css" :: B.ByteString, [Css])-                              ] accept-                  ]--      wildcard = concat $-        catMaybes [ mapAccept [ ("*/*" :: B.ByteString, [Html,Text,Json,JavaScript,Css])-                              ] accept-                  ]-  in if not (null wildcard) then wildcard else computed-  where-    sortFE Html       xs = [Html, Text]             `intersect` xs-    sortFE JavaScript xs = [JavaScript, Text]       `intersect` xs-    sortFE Json       xs = [Json, JavaScript, Text] `intersect` xs-    sortFE Css        xs = [Css, Text]              `intersect` xs-    sortFE Text       xs = [Text]                   `intersect` xs-------- Internal Utilities -----------------------------------+-- * Pred-Trie related -----------------  -- | Removes @.txt@ from @foo.txt@ trimFileExt :: T.Text -> T.Text-trimFileExt s = if endsWithAny (T.unpack s)-                then T.pack $ takeWhile (/= '.') $ T.unpack s-                else s+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"                    ]-    endsWithAny s' = dropWhile (/= '.') s' `Prelude.elem` possibleExts---getFileExt :: Request -> FileExt-getFileExt req = fromMaybe Html $ case pathInfo req of-  [] -> Just Html -- TODO: Override default file extension for `/foo/bar`-  xs -> toExt $ T.dropWhile (/= '.') $ last xs--getVerb :: Request -> Verb-getVerb req = fromMaybe GET $ httpMethodToMSym $ requestMethod req----- | Turns a @ByteString@ into a @StdMethod@.-httpMethodToMSym :: Method -> Maybe Verb-httpMethodToMSym x | x == methodGet    = Just GET-                   | x == methodPost   = Just POST-                   | x == methodPut    = Just PUT-                   | x == methodDelete = Just DELETE-                   | otherwise         = Nothing+    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)  --- * Pred-Trie related ------------------ -- | A quirky function for processing the last element of a lookup path, only -- on /literal/ matches. lookupWithLPT :: Ord s => (s -> s) -> NonEmpty s -> PredTrie s a -> Maybe a lookupWithLPT 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+  | 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-                     if null ts then mx-                                else lookupWithLPT f (NE.fromList ts) =<< mxs+    goLit t' xs = do+      (mx,mxs) <- Map.lookup t' xs+      if null ts+      then mx+      else lookupWithLPT f (NE.fromList ts) =<< mxs      goPred (PredStep _ predicate mx xs) = do       d <- predicate t-      if null ts then mx <$~> d-                 else lookupWithLPT f (NE.fromList ts) xs <$~> d+      if null ts+      then mx <$~> d+      else lookupWithLPT f (NE.fromList ts) xs <$~> d  lookupWithLRPT :: Ord s => (s -> s) -> [s] -> RootedPredTrie s a -> Maybe a lookupWithLRPT _ [] (RootedPredTrie mx _) = mx lookupWithLRPT f ts (RootedPredTrie _ xs) = lookupWithLPT f (NE.fromList ts) xs -getResultsFromMatch :: ([s],a,[s]) -> a-getResultsFromMatch (_,x,_) = x+tell' :: (Monoid w, S.MonadState w m) => w -> m ()+tell' x = do+  xs <- S.get+  S.put $ xs <> x

@@ -1,11 +0,0 @@-module Web.Routes.Nested.FileExtListener-  ( module X-  ) where--import Web.Routes.Nested.FileExtListener.Types as X hiding (FileExt (..))-import Web.Routes.Nested.FileExtListener.Builder as X-import Web.Routes.Nested.FileExtListener.ByteString as X-import Web.Routes.Nested.FileExtListener.Blaze as X-import Web.Routes.Nested.FileExtListener.Lucid as X-import Web.Routes.Nested.FileExtListener.Text as X-import Web.Routes.Nested.FileExtListener.Json as X

@@ -1,61 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---module Web.Routes.Nested.FileExtListener.Blaze where--import           Web.Routes.Nested.FileExtListener.Types-import           Web.Routes.Nested.FileExtListener.ByteString--import           Data.Map-import qualified Data.Text.Lazy.Encoding                 as LT-import           Network.HTTP.Types                      (RequestHeaders,-                                                          Status, status200)-import           Network.Wai-import qualified Text.Blaze.Html                         as H-import qualified Text.Blaze.Html.Renderer.Text           as H--import           Control.Monad.Writer----- | Uses @Html@ as the key in the map, and @"text/html"@ as the content type.-blaze :: Monad m => H.Html -> FileExtListenerT Response m ()-blaze = blazeStatusHeaders status200 [("Content-Type", "text/html")]--blazeWith :: Monad m => (Response -> Response) -> H.Html -> FileExtListenerT Response m ()-blazeWith f = blazeStatusHeadersWith f status200 [("Content-Type", "text/html")]--blazeStatus :: Monad m => Status -> H.Html -> FileExtListenerT Response m ()-blazeStatus s = blazeStatusHeaders s [("Content-Type", "text/html")]--blazeStatusWith :: Monad m => (Response -> Response) -> Status -> H.Html -> FileExtListenerT Response m ()-blazeStatusWith f s = blazeStatusHeadersWith f s [("Content-Type", "text/html")]--blazeHeaders :: Monad m => RequestHeaders -> H.Html -> FileExtListenerT Response m ()-blazeHeaders = blazeStatusHeaders status200--blazeHeadersWith :: Monad m => (Response -> Response) -> RequestHeaders -> H.Html -> FileExtListenerT Response m ()-blazeHeadersWith f = blazeStatusHeadersWith f status200--blazeStatusHeaders :: Monad m => Status -> RequestHeaders -> H.Html -> FileExtListenerT Response m ()-blazeStatusHeaders = blazeStatusHeadersWith id--blazeStatusHeadersWith :: Monad m => (Response -> Response) -> Status -> RequestHeaders -> H.Html -> FileExtListenerT Response m ()-blazeStatusHeadersWith f s hs i =-  let r = blazeOnlyStatusHeaders s hs i in-  FileExtListenerT $ tell $-    FileExts $ singleton Html $ f r----blazeOnly :: H.Html -> Response-blazeOnly = blazeOnlyStatusHeaders status200 [("Content-Type", "text/html")]--blazeOnlyHeaders :: RequestHeaders -> H.Html -> Response-blazeOnlyHeaders = blazeOnlyStatusHeaders status200--blazeOnlyStatus :: Status -> H.Html -> Response-blazeOnlyStatus s = blazeOnlyStatusHeaders s [("Content-Type", "text/html")]--blazeOnlyStatusHeaders :: Status -> RequestHeaders -> H.Html -> Response-blazeOnlyStatusHeaders s hs i =-  bytestringOnlyStatus s hs $ LT.encodeUtf8 $ H.renderHtml i

@@ -1,41 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---module Web.Routes.Nested.FileExtListener.Builder where--import           Web.Routes.Nested.FileExtListener.Types--import qualified Data.ByteString.Builder                 as BU-import           Data.Map-import           Network.HTTP.Types                      (RequestHeaders,-                                                          Status, status200)-import           Network.Wai--import           Control.Monad.Writer----- | A builder is ambiguous, therefore we require @RequestHeaders@ and a @FileExt@ to be explicitly--- supplied.-builder :: Monad m => FileExt -> RequestHeaders -> BU.Builder -> FileExtListenerT Response m ()-builder e  = builderStatus e status200--builderWith :: Monad m => (Response -> Response) -> FileExt -> RequestHeaders -> BU.Builder -> FileExtListenerT Response m ()-builderWith f e = builderStatusWith f e status200--builderStatus :: Monad m => FileExt -> Status -> RequestHeaders -> BU.Builder -> FileExtListenerT Response m ()-builderStatus = builderStatusWith id--builderStatusWith :: Monad m => (Response -> Response) -> FileExt -> Status -> RequestHeaders -> BU.Builder -> FileExtListenerT Response m ()-builderStatusWith f e s hs i =-  let r = builderOnlyStatus s hs i in-  FileExtListenerT $ tell $-    FileExts $ singleton e $ f r----builderOnly :: RequestHeaders -> BU.Builder -> Response-builderOnly = builderOnlyStatus status200---- | The exact same thing as @Network.Wai.responseBuilder@.-builderOnlyStatus :: Status -> RequestHeaders -> BU.Builder -> Response-builderOnlyStatus = responseBuilder

@@ -1,44 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---module Web.Routes.Nested.FileExtListener.ByteString where--import           Web.Routes.Nested.FileExtListener.Types--import qualified Data.ByteString.Lazy                    as B-import           Data.Map-import           Network.HTTP.Types                      (RequestHeaders,-                                                          Status, status200)-import           Network.Wai-import qualified Network.Wai.Util                        as U--import           Control.Monad.Writer----- | @ByteString@ is ambiguous - we need to know what @RequestHeaders@ and @FileExt@ should be associated.-bytestring :: Monad m => FileExt -> RequestHeaders -> B.ByteString -> FileExtListenerT Response m ()-bytestring e = bytestringStatus e status200--bytestringWith :: Monad m => (Response -> Response) -> FileExt -> RequestHeaders -> B.ByteString -> FileExtListenerT Response m ()-bytestringWith f e = bytestringStatusWith f e status200--bytestringStatus :: Monad m => FileExt -> Status -> RequestHeaders -> B.ByteString-                 -> FileExtListenerT Response m ()-bytestringStatus = bytestringStatusWith id--bytestringStatusWith :: Monad m =>-                        (Response -> Response)-                     -> FileExt -> Status -> RequestHeaders -> B.ByteString-                     -> FileExtListenerT Response m ()-bytestringStatusWith f e s hs i = do-  r <- lift $ U.bytestring s hs i-  FileExtListenerT $ tell $-    FileExts $ singleton e $ f r---bytestringOnly :: RequestHeaders -> B.ByteString -> Response-bytestringOnly = bytestringOnlyStatus status200---- | The exact same thing as @Network.Wai.responseLBS@.-bytestringOnlyStatus :: Status -> RequestHeaders -> B.ByteString -> Response-bytestringOnlyStatus = responseLBS

@@ -1,61 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}----module Web.Routes.Nested.FileExtListener.Cassius where--import           Web.Routes.Nested.FileExtListener.Types as FE-import           Web.Routes.Nested.FileExtListener.ByteString--import           Data.Map-import           Text.Cassius-import qualified Data.Text.Lazy.Encoding                 as LT-import           Network.HTTP.Types                      (RequestHeaders,-                                                          Status, status200)-import           Network.Wai--import           Control.Monad.Writer----- | Uses @cassius@ as the key in the map, and @"cassius/plain"@ as the content type.-cassius :: Monad m => Css -> FileExtListenerT Response m ()-cassius = cassiusStatusHeaders status200 [("Content-Type", "cassius/css")]--cassiusWith :: Monad m => (Response -> Response) -> Css -> FileExtListenerT Response m ()-cassiusWith f = cassiusStatusHeadersWith f status200 [("Content-Type", "cassius/css")]--cassiusStatus :: Monad m => Status -> Css -> FileExtListenerT Response m ()-cassiusStatus s = cassiusStatusHeaders s [("Content-Type", "cassius/css")]--cassiusStatusWith :: Monad m => (Response -> Response) -> Status -> Css -> FileExtListenerT Response m ()-cassiusStatusWith f s = cassiusStatusHeadersWith f s [("Content-Type", "cassius/css")]--cassiusHeaders :: Monad m => RequestHeaders -> Css -> FileExtListenerT Response m ()-cassiusHeaders = cassiusStatusHeaders status200--cassiusHeadersWith :: Monad m => (Response -> Response) -> RequestHeaders -> Css -> FileExtListenerT Response m ()-cassiusHeadersWith f = cassiusStatusHeadersWith f status200--cassiusStatusHeaders :: Monad m => Status -> RequestHeaders -> Css -> FileExtListenerT Response m ()-cassiusStatusHeaders = cassiusStatusHeadersWith id--cassiusStatusHeadersWith :: Monad m => (Response -> Response) -> Status -> RequestHeaders -> Css -> FileExtListenerT Response m ()-cassiusStatusHeadersWith f s hs i =-  let r = cassiusOnlyStatusHeaders s hs i in-  FileExtListenerT $ tell $-    FileExts $ singleton Css $ f r-----cassiusOnly :: Css -> Response-cassiusOnly = cassiusOnlyStatusHeaders status200 [("Content-Type", "cassius/css")]--cassiusOnlyStatus :: Status -> Css -> Response-cassiusOnlyStatus s = cassiusOnlyStatusHeaders s [("Content-Type", "cassius/css")]--cassiusOnlyHeaders :: RequestHeaders -> Css -> Response-cassiusOnlyHeaders = cassiusOnlyStatusHeaders status200--cassiusOnlyStatusHeaders :: Status -> RequestHeaders -> Css -> Response-cassiusOnlyStatusHeaders s hs i = bytestringOnlyStatus s hs $ LT.encodeUtf8 $ renderCss i

@@ -1,62 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}----module Web.Routes.Nested.FileExtListener.Clay where--import           Web.Routes.Nested.FileExtListener.Types-import           Web.Routes.Nested.FileExtListener.ByteString--import           Data.Map-import           Clay.Render-import           Clay.Stylesheet-import qualified Data.Text.Lazy.Encoding                 as LT-import           Network.HTTP.Types                      (RequestHeaders,-                                                          Status, status200)-import           Network.Wai--import           Control.Monad.Writer----- | Uses @Text@ as the key in the map, and @"text/css"@ as the content type.-clay :: Monad m => Config -> [App] -> Css -> FileExtListenerT Response m ()-clay c as = clayStatusHeaders c as status200 [("Content-Type", "text/css")]--clayWith :: Monad m => (Response -> Response) -> Config -> [App] -> Css -> FileExtListenerT Response m ()-clayWith f c as = clayStatusHeadersWith f c as status200 [("Content-Type", "text/css")]--clayStatus :: Monad m => Config -> [App] -> Status -> Css -> FileExtListenerT Response m ()-clayStatus c as s = clayStatusHeaders c as s [("Content-Type", "text/css")]--clayStatusWith :: Monad m => (Response -> Response) -> Config -> [App] -> Status -> Css -> FileExtListenerT Response m ()-clayStatusWith f c as s = clayStatusHeadersWith f c as s [("Content-Type", "text/css")]--clayHeaders :: Monad m => Config -> [App] -> RequestHeaders -> Css -> FileExtListenerT Response m ()-clayHeaders c as = clayStatusHeaders c as status200--clayHeadersWith :: Monad m => (Response -> Response) -> Config -> [App] -> RequestHeaders -> Css -> FileExtListenerT Response m ()-clayHeadersWith f c as = clayStatusHeadersWith f c as status200--clayStatusHeaders :: Monad m => Config -> [App] -> Status -> RequestHeaders -> Css -> FileExtListenerT Response m ()-clayStatusHeaders = clayStatusHeadersWith id--clayStatusHeadersWith :: Monad m => (Response -> Response) -> Config -> [App] -> Status -> RequestHeaders -> Css -> FileExtListenerT Response m ()-clayStatusHeadersWith f c as s hs i =-  let r = clayOnlyStatusHeaders c as s hs i in-  FileExtListenerT $ tell $-    FileExts $ singleton Css $ f r-----clayOnly :: Config -> [App] -> Css -> Response-clayOnly c as = clayOnlyStatusHeaders c as status200 [("Content-Type", "text/css")]--clayOnlyStatus :: Config -> [App] -> Status -> Css -> Response-clayOnlyStatus c as s = clayOnlyStatusHeaders c as s [("Content-Type", "text/css")]--clayOnlyHeaders :: Config -> [App] -> RequestHeaders -> Css -> Response-clayOnlyHeaders c as = clayOnlyStatusHeaders c as status200--clayOnlyStatusHeaders :: Config -> [App] -> Status -> RequestHeaders -> Css -> Response-clayOnlyStatusHeaders c as s hs i = bytestringOnlyStatus s hs $ LT.encodeUtf8 $ renderWith c as i

@@ -1,110 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---module Web.Routes.Nested.FileExtListener.Json where--import           Web.Routes.Nested.FileExtListener.Types-import           Web.Routes.Nested.FileExtListener.ByteString--import qualified Data.Aeson                              as A-import           Data.Map-import           Network.HTTP.Types                      (RequestHeaders,-                                                          Status, status200)-import           Network.Wai--import           Control.Monad.Writer------ | Uses @Json@ as the key in the map, and @"application/json"@ as the content type.-json :: ( A.ToJSON j-        , Monad m-        ) => j -> FileExtListenerT Response m ()-json = jsonStatusHeaders status200 [("Content-Type", "application/json")]--jsonWith :: ( A.ToJSON j-            , Monad m-            ) => (Response -> Response) -> j -> FileExtListenerT Response m ()-jsonWith f = jsonStatusHeadersWith f status200 [("Content-Type", "application/json")]--jsonStatus :: ( A.ToJSON j-              , Monad m-              ) => Status -> j -> FileExtListenerT Response m ()-jsonStatus s = jsonStatusHeaders s [("Content-Type", "application/json")]--jsonStatusWith :: ( A.ToJSON j-                  , Monad m-                  ) => (Response -> Response) -> Status -> j -> FileExtListenerT Response m ()-jsonStatusWith f s = jsonStatusHeadersWith f s [("Content-Type", "application/json")]---- | Uses @Json@ as the key in the map, and @"application/javascript"@ as the content type.-jsonp :: ( A.ToJSON j-         , Monad m-         ) => j -> FileExtListenerT Response m ()-jsonp = jsonStatusHeaders status200 [("Content-Type", "application/javascript")]--jsonpWith :: ( A.ToJSON j-             , Monad m-             ) => (Response -> Response) -> j -> FileExtListenerT Response m ()-jsonpWith f = jsonStatusHeadersWith f status200 [("Content-Type", "application/javascript")]--jsonpStatus :: ( A.ToJSON j-               , Monad m-               ) => Status -> j -> FileExtListenerT Response m ()-jsonpStatus s = jsonStatusHeaders s [("Content-Type", "application/javascript")]--jsonpStatusWith :: ( A.ToJSON j-                   , Monad m-                   ) => (Response -> Response) -> Status -> j -> FileExtListenerT Response m ()-jsonpStatusWith f s = jsonStatusHeadersWith f s [("Content-Type", "application/javascript")]--jsonHeaders :: ( A.ToJSON j-               , Monad m-               ) => RequestHeaders -> j -> FileExtListenerT Response m ()-jsonHeaders = jsonStatusHeaders status200--jsonHeadersWith :: ( A.ToJSON j-                   , Monad m-                   ) => (Response -> Response) -> RequestHeaders -> j -> FileExtListenerT Response m ()-jsonHeadersWith f = jsonStatusHeadersWith f status200--jsonStatusHeaders :: ( A.ToJSON j-                     , Monad m-                     ) => Status -> RequestHeaders -> j -> FileExtListenerT Response m ()-jsonStatusHeaders = jsonStatusHeadersWith id--jsonStatusHeadersWith :: ( A.ToJSON j-                         , Monad m-                         ) => (Response -> Response) -> Status -> RequestHeaders -> j -> FileExtListenerT Response m ()-jsonStatusHeadersWith f s hs i =-  let r = jsonOnlyStatusHeaders s hs i in-  FileExtListenerT $ tell $-    FileExts $ singleton Json $ f r-----jsonOnly :: A.ToJSON j =>-            j -> Response-jsonOnly = jsonOnlyStatusHeaders status200 [("Content-Type", "application/json")]--jsonOnlyStatus :: A.ToJSON j =>-            Status -> j -> Response-jsonOnlyStatus s = jsonOnlyStatusHeaders s [("Content-Type", "application/json")]--jsonpOnly :: A.ToJSON j =>-            j -> Response-jsonpOnly = jsonOnlyStatusHeaders status200 [("Content-Type", "application/javascript")]--jsonpOnlyStatus :: A.ToJSON j =>-            Status -> j -> Response-jsonpOnlyStatus s = jsonOnlyStatusHeaders s [("Content-Type", "application/javascript")]--jsonOnlyHeaders :: A.ToJSON j =>-            RequestHeaders -> j -> Response-jsonOnlyHeaders = jsonOnlyStatusHeaders status200--jsonOnlyStatusHeaders :: A.ToJSON j =>-            Status -> RequestHeaders -> j -> Response-jsonOnlyStatusHeaders s hs i =-  bytestringOnlyStatus s hs $ A.encode i

@@ -1,61 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}----module Web.Routes.Nested.FileExtListener.Julius where--import           Web.Routes.Nested.FileExtListener.Types-import           Web.Routes.Nested.FileExtListener.ByteString--import           Data.Map-import           Text.Julius-import qualified Data.Text.Lazy.Encoding                 as LT-import           Network.HTTP.Types                      (RequestHeaders,-                                                          Status, status200)-import           Network.Wai--import           Control.Monad.Writer----- | Uses @julius@ as the key in the map, and @"application/javascript"@ as the content type.-julius :: Monad m => Javascript -> FileExtListenerT Response m ()-julius = juliusStatusHeaders status200 [("Content-Type", "application/javascript")]--juliusWith :: Monad m => (Response -> Response) -> Javascript -> FileExtListenerT Response m ()-juliusWith f = juliusStatusHeadersWith f status200 [("Content-Type", "application/javascript")]--juliusStatus :: Monad m => Status -> Javascript -> FileExtListenerT Response m ()-juliusStatus s = juliusStatusHeaders s [("Content-Type", "application/javascript")]--juliusStatusWith :: Monad m => (Response -> Response) -> Status -> Javascript -> FileExtListenerT Response m ()-juliusStatusWith f s = juliusStatusHeadersWith f s [("Content-Type", "application/javascript")]--juliusHeaders :: Monad m => RequestHeaders -> Javascript -> FileExtListenerT Response m ()-juliusHeaders = juliusStatusHeaders status200--juliusHeadersWith :: Monad m => (Response -> Response) -> RequestHeaders -> Javascript -> FileExtListenerT Response m ()-juliusHeadersWith f = juliusStatusHeadersWith f status200--juliusStatusHeaders :: Monad m => Status -> RequestHeaders -> Javascript -> FileExtListenerT Response m ()-juliusStatusHeaders = juliusStatusHeadersWith id--juliusStatusHeadersWith :: Monad m => (Response -> Response) -> Status -> RequestHeaders -> Javascript -> FileExtListenerT Response m ()-juliusStatusHeadersWith f s hs i =-  let r = juliusOnlyStatusHeaders s hs i in-  FileExtListenerT $ tell $-    FileExts $ singleton JavaScript $ f r-----juliusOnly :: Javascript -> Response-juliusOnly = juliusOnlyStatusHeaders status200 [("Content-Type", "application/javascript")]--juliusOnlyStatus :: Status -> Javascript -> Response-juliusOnlyStatus s = juliusOnlyStatusHeaders s [("Content-Type", "application/javascript")]--juliusOnlyHeaders :: RequestHeaders -> Javascript -> Response-juliusOnlyHeaders = juliusOnlyStatusHeaders status200--juliusOnlyStatusHeaders :: Status -> RequestHeaders -> Javascript -> Response-juliusOnlyStatusHeaders s hs i = bytestringOnlyStatus s hs $ LT.encodeUtf8 $ renderJavascript i

@@ -1,63 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---module Web.Routes.Nested.FileExtListener.Lucid where--import           Web.Routes.Nested.FileExtListener.Types-import           Web.Routes.Nested.FileExtListener.ByteString--import           Data.Map-import qualified Lucid.Base                              as L-import           Network.HTTP.Types                      (RequestHeaders,-                                                          Status, status200)-import           Network.Wai--import           Control.Monad.Writer----- | Uses the @Html@ key in the map, and @"text/html"@ as the content type.-lucid :: Monad m => L.HtmlT m () -> FileExtListenerT Response m ()-lucid = lucidStatusHeaders status200 [("Content-Type", "text/html")]--lucidWith :: Monad m => (Response -> Response) -> L.HtmlT m () -> FileExtListenerT Response m ()-lucidWith f = lucidStatusHeadersWith f status200 [("Content-Type", "text/html")]--lucidStatus :: Monad m => Status -> L.HtmlT m () -> FileExtListenerT Response m ()-lucidStatus s = lucidStatusHeaders s [("Content-Type", "text/html")]--lucidStatusWith :: Monad m => (Response -> Response) -> Status -> L.HtmlT m () -> FileExtListenerT Response m ()-lucidStatusWith f s = lucidStatusHeadersWith f s [("Content-Type", "text/html")]--lucidHeaders :: Monad m => RequestHeaders -> L.HtmlT m () -> FileExtListenerT Response m ()-lucidHeaders = lucidStatusHeaders status200--lucidHeadersWith :: Monad m => (Response -> Response) -> RequestHeaders -> L.HtmlT m () -> FileExtListenerT Response m ()-lucidHeadersWith f = lucidStatusHeadersWith f status200--lucidStatusHeaders :: Monad m => Status -> RequestHeaders -> L.HtmlT m () -> FileExtListenerT Response m ()-lucidStatusHeaders = lucidStatusHeadersWith id--lucidStatusHeadersWith :: Monad m => (Response -> Response) -> Status -> RequestHeaders -> L.HtmlT m () -> FileExtListenerT Response m ()-lucidStatusHeadersWith f s hs i = do-  r <- lift $ lucidOnlyStatusHeaders s hs i-  FileExtListenerT $ tell $-    FileExts $ singleton Html $ f r-----lucidOnly :: Monad m =>-             L.HtmlT m () -> m Response-lucidOnly = lucidOnlyStatusHeaders status200 [("Content-Type", "text/html")]--lucidOnlyStatus :: Monad m =>-             Status -> L.HtmlT m () -> m Response-lucidOnlyStatus s = lucidOnlyStatusHeaders s [("Content-Type", "text/html")]--lucidOnlyHeaders :: Monad m =>-             RequestHeaders -> L.HtmlT m () -> m Response-lucidOnlyHeaders = lucidOnlyStatusHeaders status200--lucidOnlyStatusHeaders :: Monad m =>-             Status -> RequestHeaders -> L.HtmlT m () -> m Response-lucidOnlyStatusHeaders s hs i = liftM (bytestringOnlyStatus s hs) $ L.renderBST i

@@ -1,61 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}----module Web.Routes.Nested.FileExtListener.Lucius where--import           Web.Routes.Nested.FileExtListener.Types as FE-import           Web.Routes.Nested.FileExtListener.ByteString--import           Data.Map-import           Text.Lucius-import qualified Data.Text.Lazy.Encoding                 as LT-import           Network.HTTP.Types                      (RequestHeaders,-                                                          Status, status200)-import           Network.Wai--import           Control.Monad.Writer----- | Uses @lucius@ as the key in the map, and @"lucius/css"@ as the content type.-lucius :: Monad m => Css -> FileExtListenerT Response m ()-lucius = luciusStatusHeaders status200 [("Content-Type", "lucius/css")]--luciusWith :: Monad m => (Response -> Response) -> Css -> FileExtListenerT Response m ()-luciusWith f = luciusStatusHeadersWith f status200 [("Content-Type", "lucius/css")]--luciusStatus :: Monad m => Status -> Css -> FileExtListenerT Response m ()-luciusStatus s = luciusStatusHeaders s [("Content-Type", "lucius/css")]--luciusStatusWith :: Monad m => (Response -> Response) -> Status -> Css -> FileExtListenerT Response m ()-luciusStatusWith f s = luciusStatusHeadersWith f s [("Content-Type", "lucius/css")]--luciusHeaders :: Monad m => RequestHeaders -> Css -> FileExtListenerT Response m ()-luciusHeaders = luciusStatusHeaders status200--luciusHeadersWith :: Monad m => (Response -> Response) -> RequestHeaders -> Css -> FileExtListenerT Response m ()-luciusHeadersWith f = luciusStatusHeadersWith f status200--luciusStatusHeaders :: Monad m => Status -> RequestHeaders -> Css -> FileExtListenerT Response m ()-luciusStatusHeaders = luciusStatusHeadersWith id--luciusStatusHeadersWith :: Monad m => (Response -> Response) -> Status -> RequestHeaders -> Css -> FileExtListenerT Response m ()-luciusStatusHeadersWith f s hs i =-  let r = luciusOnlyStatusHeaders s hs i in-  FileExtListenerT $ tell $-    FileExts $ singleton FE.Css $ f r-----luciusOnly :: Css -> Response-luciusOnly = luciusOnlyStatusHeaders status200 [("Content-Type", "lucius/css")]--luciusOnlyStatus :: Status -> Css -> Response-luciusOnlyStatus s = luciusOnlyStatusHeaders s [("Content-Type", "lucius/css")]--luciusOnlyHeaders :: RequestHeaders -> Css -> Response-luciusOnlyHeaders = luciusOnlyStatusHeaders status200--luciusOnlyStatusHeaders :: Status -> RequestHeaders -> Css -> Response-luciusOnlyStatusHeaders s hs i = bytestringOnlyStatus s hs $ LT.encodeUtf8 $ renderCss i

@@ -1,63 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}----module Web.Routes.Nested.FileExtListener.Text where--import           Web.Routes.Nested.FileExtListener.Types-import           Web.Routes.Nested.FileExtListener.ByteString--import           Data.Map-import qualified Data.Text.Lazy                          as LT-import qualified Data.Text.Lazy.Encoding                 as LT-import           Network.HTTP.Types                      (RequestHeaders,-                                                          Status, status200)-import           Network.Wai--import           Control.Monad.Writer----- | Uses @Text@ as the key in the map, and @"text/plain"@ as the content type.-text :: Monad m => LT.Text -> FileExtListenerT Response m ()-text = textStatusHeaders status200 [("Content-Type", "text/plain")]--textWith :: Monad m => (Response -> Response) -> LT.Text -> FileExtListenerT Response m ()-textWith f = textStatusHeadersWith f status200 [("Content-Type", "text/plain")]--textStatus :: Monad m => Status -> LT.Text -> FileExtListenerT Response m ()-textStatus s = textStatusHeaders s [("Content-Type", "text/plain")]--textStatusWith :: Monad m => (Response -> Response) -> Status -> LT.Text -> FileExtListenerT Response m ()-textStatusWith f s = textStatusHeadersWith f s [("Content-Type", "text/plain")]--textHeaders :: Monad m => RequestHeaders -> LT.Text -> FileExtListenerT Response m ()-textHeaders = textStatusHeaders status200--textHeadersWith :: Monad m => (Response -> Response) -> RequestHeaders -> LT.Text -> FileExtListenerT Response m ()-textHeadersWith f = textStatusHeadersWith f status200--textStatusHeaders :: Monad m => Status -> RequestHeaders -> LT.Text -> FileExtListenerT Response m ()-textStatusHeaders = textStatusHeadersWith id--textStatusHeadersWith :: Monad m =>-                         (Response -> Response) -> Status -> RequestHeaders -> LT.Text-                      -> FileExtListenerT Response m ()-textStatusHeadersWith f s hs i =-  let r = textOnlyStatusHeaders s hs i in-  FileExtListenerT $ tell $-    FileExts $ singleton Text $ f r-----textOnly :: LT.Text -> Response-textOnly = textOnlyStatusHeaders status200 [("Content-Type", "text/plain")]--textOnlyStatus :: Status -> LT.Text -> Response-textOnlyStatus s = textOnlyStatusHeaders s [("Content-Type", "text/plain")]--textOnlyHeaders :: RequestHeaders -> LT.Text -> Response-textOnlyHeaders = textOnlyStatusHeaders status200--textOnlyStatusHeaders :: Status -> RequestHeaders -> LT.Text -> Response-textOnlyStatusHeaders s hs i = bytestringOnlyStatus s hs $ LT.encodeUtf8 i

@@ -1,53 +0,0 @@-{-# LANGUAGE-    DeriveFunctor-  , DeriveTraversable-  , GeneralizedNewtypeDeriving-  , OverloadedStrings-  , StandaloneDeriving-  , FlexibleInstances-  , MultiParamTypeClasses-  #-}---module Web.Routes.Nested.FileExtListener.Types where--import qualified Data.Text            as T--import           Control.Monad.Trans-import           Control.Monad.Writer-import           Data.Map----- | Supported file extensions-data FileExt = Html-             | Css-             | JavaScript-             | Json-             | Text-  deriving (Show, Eq, Ord)---toExt :: T.Text -> Maybe FileExt-toExt x | x `elem` htmls       = Just Html-        | x `elem` csss        = Just Css-        | x `elem` javascripts = Just JavaScript-        | x `elem` jsons       = Just Json-        | x `elem` texts       = Just Text-        | otherwise            = Nothing-  where-    htmls       = [".htm", ".html"]-    csss        = [".css"]-    javascripts = [".js", ".javascript"]-    jsons       = [".json"]-    texts       = [".txt"]--newtype FileExts a = FileExts { unFileExts :: Map FileExt a }-  deriving (Show, Eq, Monoid, Functor, Foldable, Traversable)--newtype FileExtListenerT r m a =-  FileExtListenerT { runFileExtListenerT :: WriterT (FileExts r) m a }-    deriving (Functor, Applicative, Monad, MonadIO, MonadTrans,-              MonadWriter (FileExts r))--execFileExtListenerT :: Monad m => FileExtListenerT r m a -> m (FileExts r)-execFileExtListenerT = execWriterT . runFileExtListenerT

@@ -20,14 +20,18 @@   (:~) :: (T.Text, Parser r) -> EitherUrlChunk ('Just r)   (:*) :: (T.Text, Regex)    -> EitherUrlChunk ('Just [String]) --- | Match against a /Literal/ chunk-l :: T.Text -> EitherUrlChunk 'Nothing-l = (:=)- -- | Use raw strings instead of prepending @l@ instance x ~ 'Nothing => IsString (EitherUrlChunk x) where   fromString = l . T.pack +-- | The /Origin/ chunk - the equivalent to @[]@+o :: UrlChunks '[]+o = Root++-- | Match against a /Literal/ chunk+l :: T.Text -> EitherUrlChunk 'Nothing+l = (:=)+ -- | Match against a /Parsed/ chunk p :: (T.Text, Parser r) -> EitherUrlChunk ('Just r) p = (:~)@@ -36,17 +40,13 @@ r :: (T.Text, Regex) -> EitherUrlChunk ('Just [String]) r = (:*) --- | 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 '[]- -- | Glue two chunks together (</>) :: EitherUrlChunk mx -> UrlChunks xs -> UrlChunks (mx ': xs) (</>) = Cons  infixr 9 </> --- | The /new-Origin/ chunk - the equivalent to @[]@-o :: UrlChunks '[]-o = Root+-- | 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 '[]

@@ -1,133 +0,0 @@-{-# LANGUAGE-    GeneralizedNewtypeDeriving-  , ScopedTypeVariables-  , MultiParamTypeClasses-  , TupleSections-  #-}--module Web.Routes.Nested.VerbListener where--import           Network.Wai (Request)-import           Network.HTTP.Types (StdMethod (..))--import           Data.Function.Syntax-import           Data.Bifunctor-import           Data.Map (Map)-import qualified Data.Map                             as Map-import           Data.Set.Class                       as Sets-import           Control.Monad.Trans-import           Control.Monad.Writer---type Verb = StdMethod--type HandleUpload m u   = Request -> m (Maybe u)-type Respond u r        = Request -> Maybe u -> r-type ResponseSpec u m r = (HandleUpload m u, Respond u r)----- * Verb Map--newtype Verbs u m r = Verbs-  { unVerbs :: Map Verb (ResponseSpec u m r)-  } deriving (Monoid, HasUnion, HasEmpty)---- | To compensate for responses that want to peek into the @Request@ object.-supplyReq :: Request-          -> Map Verb (ResponseSpec u m r)-          -> Map Verb (m (Maybe u), Maybe u -> r)-supplyReq req xs = bimap ($ req) ($ req) <$> xs--instance Functor (Verbs u m) where-  fmap f (Verbs xs) = Verbs $ fmap (second (f .*)) xs---- instance Foldable (Verbs u m) where---   foldMap f (Verbs xs) = foldMap go xs---     where go (_, Left r) = f r -- can only take left cases---           go _ = mempty----- * Verb Writer--newtype VerbListenerT r u m a =-  VerbListenerT { runVerbListenerT :: WriterT (Union (Verbs u m r)) m a }-    deriving ( Functor-             , Applicative-             , Monad-             , MonadWriter (Union (Verbs u m r))-             , MonadIO-             )--execVerbListenerT :: Monad m => VerbListenerT r u m a -> m (Verbs u m r)-execVerbListenerT verbs = do uVerbs <- execWriterT $ runVerbListenerT verbs-                             return $ unUnion uVerbs--instance MonadTrans (VerbListenerT r u) where-  lift ma = VerbListenerT $ lift ma---foldMWithKey :: Monad m => (acc -> Verb -> a -> m acc) -> acc -> Map Verb a -> m acc-foldMWithKey f i = Map.foldlWithKey (\macc k a -> (\mer -> f mer k a) =<< macc) (return i)----- | For simple @GET@ responses-get :: ( Monad m-       ) => r -> VerbListenerT r u m ()-get r = tell $ Union $ Verbs $ Map.singleton GET ( const $ return Nothing-                                                 , const $ const r-                                                 )---- | Inspect the @Request@ object supplied by WAI-getReq :: ( Monad m-          ) => (Request -> r) -> VerbListenerT r u m ()-getReq r = tell $ Union $ Verbs $ Map.singleton GET ( const $ return Nothing-                                                    , const . r)----- | For simple @POST@ responses-post :: ( Monad m-        , MonadIO m-        ) => HandleUpload m u -> (Maybe u -> r) -> VerbListenerT r u m ()-post handle r = tell $ Union $ Verbs $ Map.singleton POST ( handle-                                                          , const r-                                                          )---- | Inspect the @Request@ object supplied by WAI-postReq :: ( Monad m-           , MonadIO m-           ) => HandleUpload m u -> (Request -> Maybe u -> r) -> VerbListenerT r u m ()-postReq handle r = tell $ Union $ Verbs $ Map.singleton POST ( handle-                                                             , r-                                                             )----- | For simple @PUT@ responses-put :: ( Monad m-       , MonadIO m-       ) => HandleUpload m u -> (Maybe u -> r) -> VerbListenerT r u m ()-put handle r = tell $ Union $ Verbs $ Map.singleton PUT ( handle-                                                        , const r-                                                        )---- | Inspect the @Request@ object supplied by WAI-putReq :: ( Monad m-          , MonadIO m-          ) => HandleUpload m u -> (Request -> Maybe u -> r) -> VerbListenerT r u m ()-putReq handle r = tell $ Union $ Verbs $ Map.singleton PUT ( handle-                                                           , r-                                                           )----- | For simple @DELETE@ responses-delete :: ( Monad m-          ) => r -> VerbListenerT r u m ()-delete r = tell $ Union $ Verbs $ Map.singleton DELETE ( const $ return Nothing-                                                       , const $ const r-                                                       )---- | Inspect the @Request@ object supplied by WAI-deleteReq :: ( Monad m-             ) => (Request -> r) -> VerbListenerT r u m ()-deleteReq r = tell $ Union $ Verbs $ Map.singleton DELETE ( const $ return Nothing-                                                          , const . r-                                                          )

@@ -1,1 +1,1 @@-{-# OPTIONS_GHC -F -pgmF hspec-discover #-}+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}

@@ -0,0 +1,5 @@+import Test.Hspec (hspec)+import Spec (spec)++main :: IO ()+main = hspec spec

@@ -0,0 +1,64 @@+{-# LANGUAGE+    OverloadedStrings+  #-}++module Web.Routes.NestedSpec (spec) where++import Web.Routes.NestedSpec.Basic+import Network.Wai.Trans++import Test.Hspec+import Test.Hspec.Wai as HW++++spec :: Spec+spec = do+  describe "Literal Routes" $+    with (return app) $ do+      describe "GET /" $+        it "should respond with 200" $+        get "/" `shouldRespondWith`+        200+      describe "GET /foo" $+        it "should respond with 200 and 'foo!'" $+        get "/foo" `shouldRespondWith`+        "" { matchStatus = 200+           , matchBody = Just "foo!"+           }+      describe "GET /baz" $+        it "should respond with 200 and 'baz!'" $+        get "/baz" `shouldRespondWith`+        "" { matchStatus = 200+           , matchBody = Just "baz!"+           }+      describe "GET /borked" $+        it "should respond with 404" $+        get "/borked" `shouldRespondWith`+        404+  describe "Regex Routes" $+    with (return app) $ do+      describe "GET /athan@emails.com" $+        it "should respond with 200 and '[\"athan@emails.com\"] email'" $+        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!"+           }+  describe "Secure Routes" $+    with (return app) $ do+      describe "GET /foo/bar" $+        it "should respond with 401 and 'Unauthorized!'" $+        get "/foo/bar" `shouldRespondWith`+        "" { matchStatus = 401+           , matchBody = Just "Unauthorized!"+           }++

@@ -0,0 +1,88 @@+{-# LANGUAGE+    OverloadedStrings+  , ScopedTypeVariables+  , FlexibleContexts+  #-}+++module Web.Routes.NestedSpec.Basic where++import Web.Routes.Nested+import Network.Wai.Trans+import Network.HTTP.Types+import           Text.Regex+import qualified Data.Text.Lazy as LT+import           Data.Attoparsec.Text+import Data.Monoid+import Control.Monad.Except+++data AuthRole = AuthRole deriving (Show, Eq)+data AuthErr = NeedsAuth deriving (Show, Eq)++-- | If you fail here and throw an AuthErr, then the user was not authorized to+-- under the conditions set by @ss :: [AuthRole]@, and based on the authentication+-- of that user's session from the @Request@ object. Note that we could have a+-- shared cache of authenticated sessions, by adding more constraints on @m@ like+-- @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+             , MonadError AuthErr m+             ) => Request -> [AuthRole] -> m (Response -> Response)+-- authorize _ _ = return id -- uncomment to force constant authorization+authorize req ss | null ss   = return id+                 | otherwise = throwError NeedsAuth++defApp :: Application+defApp _ respond = respond $ textOnlyStatus status404 "404 :("++app :: Application+app =+  let yoDawgIHeardYouLikeYoDawgsYo = routeActionAuth authorize routes+      routes =+        handleAction o (Just rootHandle) $ Just $ do+          handleAction fooRoute (Just fooHandle) $ Just $ do+            auth AuthRole unauthHandle ProtectChildren+            handleAction barRoute    (Just barHandle)    Nothing+            handleAction doubleRoute (Just doubleHandle) Nothing+          handleAction emailRoute (Just emailHandle) Nothing+          handleAction bazRoute (Just bazHandle) Nothing+          notFoundAction o (Just notFoundHandle) Nothing+  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"++    -- `/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`, 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 :("