nested-routes 3.2.0 → 4.0.0

raw patch · 20 files changed

+1284/−507 lines, 20 filesdep +base64-bytestringdep +bifunctorsdep +blaze-builderdep ~basedep ~poly-aritydep ~pred-triesetup-changednew-component:exe:examplenew-component:exe:example-stmPVP ok

version bump matches the API change (PVP)

Dependencies added: base64-bytestring, bifunctors, blaze-builder, composition-extra, cookie, cryptonite, data-default, errors, iso8601-time, memory, sets, stm, time, tries, utf8-string, wai-session

Dependency ranges changed: base, poly-arity, pred-trie

API changes (from Hackage documentation)

Files

• Setup.hs +0/−2
• examples/Main.hs +91/−0
• examples/STM.hs +149/−0
• examples/STM/Auth.hs +225/−0
• nested-routes.cabal +130/−83
• src/Web/Routes/Nested.hs +391/−188
• src/Web/Routes/Nested/FileExtListener/Blaze.hs +14/−4
• src/Web/Routes/Nested/FileExtListener/Builder.hs +8/−2
• src/Web/Routes/Nested/FileExtListener/ByteString.hs +13/−3
• src/Web/Routes/Nested/FileExtListener/Cassius.hs +14/−8
• src/Web/Routes/Nested/FileExtListener/Clay.hs +15/−9
• src/Web/Routes/Nested/FileExtListener/Json.hs +44/−15
• src/Web/Routes/Nested/FileExtListener/Julius.hs +14/−8
• src/Web/Routes/Nested/FileExtListener/Lucid.hs +18/−10
• src/Web/Routes/Nested/FileExtListener/Lucius.hs +14/−8
• src/Web/Routes/Nested/FileExtListener/Text.hs +16/−3
• src/Web/Routes/Nested/FileExtListener/Types.hs +8/−5
• src/Web/Routes/Nested/Types.hs +43/−54
• src/Web/Routes/Nested/Types/UrlChunks.hs +4/−4
• src/Web/Routes/Nested/VerbListener.hs +73/−101

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

@@ -0,0 +1,91 @@+{-# LANGUAGE+    OverloadedStrings+  , ScopedTypeVariables+  , FlexibleContexts+  #-}+++module Main where++import Network.Wai+import Network.Wai.Handler.Warp+import Network.HTTP.Types+import Web.Routes.Nested+import Data.Attoparsec.Text+import Text.Regex+import Data.Monoid+import qualified Data.Text.Lazy as LT+import Control.Monad.Error.Class+import Control.Monad.IO.Class++import Debug.Trace+++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 :("++main :: IO ()+main =+  let app = routeAuth authorize routes+      routes =+        handle o (Just rootHandle) $ Just $ do+          handle 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+  in run 3000 $ app defApp+  where+    rootHandle = get $ text "Home"++    -- `/foo`+    fooRoute = l "foo" </> o+    fooHandle = get $ text "foo!"++    -- `/foo/bar`+    barRoute = l "bar" </> o+    barHandle = get $ do+      text "bar!"+      json ("json bar!" :: LT.Text)++    -- `/foo/1234e12`+    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`+    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!"+      post uploader uploadHandle++    unauthHandle NeedsAuth = get $ textStatus status401 "Unauthorized!"+    notFoundHandle = get $ textStatus status404 "Not Found :("

@@ -0,0 +1,149 @@+{-# LANGUAGE+    OverloadedStrings+  , ScopedTypeVariables+  , FlexibleContexts+  #-}+++module Main where++import STM.Auth+import STM.Templates++import Network.Wai+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+import qualified Data.Text.Lazy as LT+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+import Control.Error.Util+import Control.Monad.Error.Class+import Control.Monad.IO.Class+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+++defApp :: Application+defApp _ respond = respond $ textOnlyStatus status404 "404 :("++main :: IO ()+main = do+  cacheVar <- newTVarIO IntMap.empty+  uIdVar <- newTVarIO 0+  salt <- do (n :: BS.ByteString) <- liftIO $ getRandomBytes 256+             let n' = hash n :: Digest SHA512+                 n'' = convert n' :: BS.ByteString+             return n''+  let 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 ()+      routes = do+        handle o (Just rootHandle) Nothing+        handle 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 $+          auth ShouldBeLoggedIn unauthHandle ProtectParent+        notFound o (Just notFoundHandle) Nothing+  run 3000 $ app defApp+  where+    rootHandle = get $ text "Home"++    -- `/foo`+    fooRoute = l "foo" </> o+    fooHandle = get $ text "foo!"++    -- `/foo/bar`+    barRoute = l "bar" </> o+    barHandle = get $ do+      text "bar!"+      json ("json bar!" :: LT.Text)++    -- `/foo/1234e12`+    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`+    bazRoute = l "baz" </> o+    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!"+      post uploader uploadHandle++    loginRoute = "login" </> o+    loginHandle = do+      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"++    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+          else do+            mSuccess <- runMaybeT $ do+              user <- hoistMaybe $ lookup "user" ps+              pass <- hoistMaybe $ lookup "password" ps+              liftIO $ putStrLn $ "<~!~> Attempted Login: " ++ show user ++ ", " ++ show pass ++ "\n"+              nUserSess <- newUserSession+              lift $ writeUserSession nUserSess+              return $ Success nUserSess+            return $ Just $ fromMaybe InvalidLoginAttempt mSuccess+        _ -> return $ Just InvalidLoginAttempt+      where+        firstIs _ [] = True+        firstIs f (x:_) = f x+++    logoutRoute = "logout" </> o+    logoutHandle = getReq $ \req -> do+      resp <- case getUserSession $ requestHeaders req of+        Nothing -> return "no session :s"+        Just userSession -> do+          lift $ deleteUserSession (userSessID userSession)+          return "logged-out"+      textWith clearSessionResponse resp++    unauthHandle SessionNotInCache   = get $ textStatusWith clearSessionResponse status401 "Unauthorized! - session not in cache"+    unauthHandle SessionTimedOut     = get $ textStatusWith clearSessionResponse status401 "Unauthorized! - session timed out"+    unauthHandle SessionMismatch     = get $ textStatusWith clearSessionResponse status401 "Unauthorized! - session mismatch"+    unauthHandle InvalidRequestNonce = get $ textStatusWith clearSessionResponse status401 "Unauthorized! - you're doing something sneaky!"+    unauthHandle NoSessionHeaders    = get $ textStatusWith clearSessionResponse status401 "Unauthorized! - are you sure you're logged in?"+    notFoundHandle = get $ textStatus status404 "Not Found :("

@@ -0,0 +1,225 @@+{-# LANGUAGE+    FlexibleContexts+  , OverloadedStrings+  #-}++module STM.Auth where++import Network.Wai+import Network.Wai.Handler.Warp+import Network.Wai.Session+import Network.HTTP.Types+import Web.Routes.Nested+import Web.Cookie+import Data.Attoparsec.Text+import Text.Regex+import Data.Monoid+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Lazy as LT+import qualified Data.ByteString as BS+import qualified Data.ByteString.Base64 as BS+import Blaze.ByteString.Builder (toByteString)+import qualified Data.IntMap as IntMap+import Data.ByteString.UTF8 (fromString, toString)+import Data.ByteArray (convert)+import Data.Time+import Data.Time.ISO8601+import Data.Maybe+import Data.Default++import Control.Concurrent.STM+import Control.Monad.STM+import Control.Monad.Error.Class+import Control.Error.Util+import Control.Monad.Except+import Control.Monad.IO.Class+import Control.Monad.Reader+import Control.Monad+import Crypto.Random+import Crypto.Random.Types+import Crypto.Hash++import Debug.Trace+++-- | @sec@+data SecurityLayer = ShouldBeLoggedIn+                   | ShouldBeModerator+                   | ShouldBeAdmin+  deriving (Show, Eq, Ord)++data AuthEnv = AuthEnv+  { authEnvCache   :: TVar (IntMap.IntMap (UTCTime, BS.ByteString))+  , authEnvFreshId :: TVar Int+  , authEnvSalt :: BS.ByteString+  }+++sessionId :: BS.ByteString+sessionId = "security-id"++sessionNonce :: BS.ByteString+sessionNonce = "security-token"++sessionTime :: BS.ByteString+sessionTime = "security-token-time"++makeSessionCookies :: UserSession BS.ByteString -> RequestHeaders+makeSessionCookies (UserSession i t c) = repeat "Set-Cookie" `zip` cookies+  where+    cookies =+      [ toByteString $+        renderSetCookie $ def { setCookieName = sessionId+                              , setCookieMaxAge = Just 60+                              , setCookieValue = fromString $ show i }+      , toByteString $+        renderSetCookie $ def { setCookieName = sessionTime+                              , setCookieMaxAge = Just 60+                              , setCookieValue = T.encodeUtf8 $ T.pack $ formatISO8601 t }+      , toByteString $+        renderSetCookie $ def { setCookieName = sessionNonce+                              , setCookieMaxAge = Just 60+                              , setCookieValue = c }+      ]++clearSessionResponse :: Response -> Response+clearSessionResponse = mapResponseHeaders $+  filter $ \(a,b) ->+    let cookieName = setCookieName $ parseSetCookie b+    in not $ a == "Set-Cookie" && ( cookieName == sessionId+                                 || cookieName == sessionTime+                                 || cookieName == sessionNonce )++clearSessionRequest :: Request -> Request+clearSessionRequest req =+  req {requestHeaders = go $ requestHeaders req}+  where+    go = filter $ \(a,b) ->+      let cookies = parseCookies b+          hasSession (k,_) = k == sessionId || k == sessionTime || k == sessionNonce+      in not $ a == "Cookie" && any hasSession cookies++getUserSession :: RequestHeaders -> Maybe (UserSession BS.ByteString)+getUserSession hs =+  let (mi,mt,mc) = foldr go (Nothing,Nothing,Nothing) hs+  in UserSession <$> mi <*> mt <*> mc+  where+    go (k,c) (mi,mt,mc) | k == "Cookie" =+        let cs = parseCookies c+            go' (k',c') (mi',mt',mc')+              | k' == sessionId = (hush $ parseOnly integer $ T.decodeUtf8 c', mt', mc')+              | k' == sessionTime = (mi', parseISO8601 $ T.unpack $ T.decodeUtf8 c', mc')+              | k' == sessionNonce = (mi', mt', Just c')+              | otherwise = (mi',mt',mc')+        in foldr go' (mi,mt,mc) cs+      | otherwise = (mi,mt,mc)+++integer :: Parser Int+integer = do+  xs <- double+  return $ floor xs++++data UserSession a = UserSession+  { userSessID    :: Int+  , userSessTime  :: UTCTime+  , userSessNonce :: a+  } deriving (Show, Eq, Ord)++newUserSession :: ( MonadIO m+                  , MonadReader AuthEnv m+                  ) => m (UserSession BS.ByteString)+newUserSession = do+  salt <- authEnvSalt <$> ask+  uIdKey <- authEnvFreshId <$> ask+  uId <- liftIO $ atomically $ do+    i <- readTVar uIdKey+    modifyTVar' uIdKey (+1)+    return i+  now <- liftIO getCurrentTime+  return $ UserSession uId now $ BS.encode $ convert $ go now salt+  where+    go :: UTCTime -> BS.ByteString -> Digest SHA512+    go now salt = hash $ salt <> fromString (formatISO8601 now)+++lookupUserSession :: ( MonadIO m+                     , MonadReader AuthEnv m+                     ) => Int -> m (Maybe (UserSession BS.ByteString))+lookupUserSession i = do+  cacheKey <- authEnvCache <$> ask+  liftIO $ atomically $ do+    cache <- readTVar cacheKey+    return $ do (t,c) <- IntMap.lookup i cache+                return $ UserSession i t c++deleteUserSession :: ( MonadIO m+                     , MonadReader AuthEnv m+                     ) => Int -> m ()+deleteUserSession i = do+  cacheKey <- authEnvCache <$> ask+  liftIO $ atomically $ modifyTVar' cacheKey (IntMap.delete i)+++writeUserSession :: ( MonadIO m+                    , MonadReader AuthEnv m+                    ) => UserSession BS.ByteString -> m ()+writeUserSession (UserSession i t c) = do+  cacheKey <- authEnvCache <$> ask+  liftIO $ atomically $ modifyTVar' cacheKey $ IntMap.insert i (t, c)+++checkUserSession :: MonadReader AuthEnv m =>+                    UserSession BS.ByteString+                 -> m Bool+checkUserSession (UserSession _ t c) = do+  salt <- authEnvSalt <$> ask+  let old = hash $ salt <> fromString (formatISO8601 t) :: Digest SHA512+      old' = BS.encode $ convert old :: BS.ByteString+  return $ c == old'+++data AuthenticationError = NoSessionHeaders+                         | InvalidRequestNonce+                         | SessionNotInCache+                         | SessionMismatch+                         | SessionTimedOut+++authenticate :: ( MonadIO m+                , MonadError AuthenticationError m+                , MonadReader AuthEnv m+                ) => Request -> [SecurityLayer] -> m (Response -> Response)+authenticate _ [] = return id+authenticate req _ = do+  liftIO $ putStrLn "<!> Auth Attempt <!>"+  liftIO $ putStrLn "--- Headers ----------- \n" >> print (requestHeaders req) >> putStrLn "\n"+  userSession        <- note' NoSessionHeaders $ getUserSession $ requestHeaders req+  userSessionIsValid <- checkUserSession userSession+  liftIO $ putStrLn "--- User Session ------ \n" >> print userSession >> putStrLn "\n"+  cacheKey <- authEnvCache <$> ask+  cache <- liftIO $ readTVarIO cacheKey+  liftIO $ putStrLn "--- Cache ------------- \n" >> print cache >> putStrLn "\n"+  mCachedSession     <- lookupUserSession (userSessID userSession)+  (UserSession i cachedTime cachedNonce) <- note' SessionNotInCache mCachedSession+  newUserSess'       <- newUserSession+  let newUserSess = newUserSess' {userSessID = i}+  case () of+    () | diffUTCTime (userSessTime newUserSess) cachedTime >= 60 -> do deleteUserSession i+                                                                       throwError SessionTimedOut+       | cachedNonce /= userSessNonce userSession -> throwError SessionMismatch+       | not userSessionIsValid                   -> throwError InvalidRequestNonce+       | otherwise -> do writeUserSession newUserSess+                         return $ mapResponseHeaders (++ makeSessionCookies newUserSess)+                                . clearSessionResponse+++note' e mx = fromMaybe (throwError e) $ pure <$> mx+++insert k v [] = [(k,v)]+insert k v ((k',v'):xs) | k == k' = (k,v):xs+                        | otherwise = (k',v'): insert k v xs

@@ -1,5 +1,5 @@ Name:                   nested-routes-Version:                3.2.0+Version:                4.0.0 Author:                 Athan Clark <athan.clark@gmail.com> Maintainer:             Athan Clark <athan.clark@gmail.com> License:                BSD3@@ -20,90 +20,22 @@   <https://hackage.haskell.org/package/attoparsec Attoparsec>   parsers and <https://hackage.haskell.org/package/regex-compat Regular Expressions>   /directly/ in our routes, with our handlers-  reflecting their results. You can find more information on the+  reflecting their results. You can find more information in the   <https://www.fpcomplete.com/user/AthanClark/nested-routes demo>.-  .-  As an example:-  .-  > router :: Application-  > router = route handlers-  >   where-  >     handlers = do-  >       handle o-  >         (Just $ get $ text "home")-  >         Nothing-  >       handle ("foo" </> "bar")-  >         (Just $ get $ text "foobar") $ Just $-  >         handle (p ("baz", double) </> o)-  >           (Just $ \d -> get $ text $ LT.pack (show d) <> " bazs")-  >           Nothing-  >       handle (p ("num",double) </> o)-  >         (Just $ \d -> get $ text $ LT.pack $ show d) $ Just $ do-  >         handle "bar"-  >            (Just $ \d -> get $ do-  >                     text $ (LT.pack $ show d) <> " bars")-  >                     json $ (LT.pack $ show d) <> " bars!")-  >            Nothing-  >         handle (r ("email", mkRegex "(^[-a-zA-Z0-9_.]+@[-a-zA-Z0-9]+\\.[-a-zA-Z0-9.]+$)") </> o)-  >            (Just $ \d e -> get $ textOnly $ (LT.pack $ show d) <> " " <> (LT.pack $ show e)-  .-  The route specification syntax is a little strange right now - @l@ specifies-  a "literal chunk" of a handlable url (ie - @l \"foo\" \<\/\> l \"bar\" \<\/\> o@ would-  represent the url @\/foo\/bar@), while @p@ represents a "parsable" url chunk,-  which expects a pair - the left element being merely a reference name for the-  parser during internal plumbing, and the right being the actual @Parser@. @o@ represents-  the end of a url string, and can be used alone in a handler to capture requests-  to the root path.-  .-  Each route being handled needs some kind of content. For every parsed url chunk,-  the route expects a function-  of arity matching 1-for-1 with the parsed contents. For example, @\d -> ...@ in the-  demonstration above is such a function, where @d :: Double@.-  .-  Internally, we match against both the file extension and Accept headers in the-  HTTP request - the Accept header may override the file extension.-  .-  When we test our application:-  .-  >  λ> curl localhost:3000/ -H "Accept: text/plain, */*"-  >  ↪ "home"-  .-  requests may end with index-  .-  >  λ> curl localhost:3000/index -H "Accept: text/plain, */*"-  >  ↪ "home"-  .-  and specify the file extension-  .-  >  λ> curl localhost:3000/index.txt -H "Accept: text/plain, */*"-  >  ↪ "home"-  .-  each responding with the "closest" available file type-  .-  >  λ> curl localhost:3000/index.html -H "Accept: text/html, */*"-  >  ↪ "home"-  .-  >  λ> curl localhost:3000/foo/bar -H "Accept: text/plain, */*"-  >  ↪ "foobar"-  .-  >  λ> curl localhost:3000/foo/bar.txt -H "Accept: text/plain, */*"-  >  ↪ "foobar"-  .-  >  λ> curl localhost:3000/foo/bar/5678.5678 -H "Accept: text/plain, */*"-  >  ↪ "5678.5678 bazs"-  .-  >  λ> curl localhost:3000/1234.1234 -H "Accept: text/plain, */*"-  >  ↪ "1234.1234"-  .-  >  λ> curl localhost:3000/2e5 -H "Accept: text/plain, */*"-  >  ↪ "200000.0"-  .-  >  λ> curl localhost:3000/1234.1234/bar -H "Accept: text/plain, */*"-  >  ↪ "1234.1234 bars"-+  and the examples. Cabal-Version:          >= 1.10 Build-Type:             Simple ++Flag Example+  Description:          Build the trivial example.+  Default:              False++Flag Example-STM+  Description:          Build the Sha512 / STM nonce cache example.+  Default:              False++ Library   Default-Language:     Haskell2010   HS-Source-Dirs:       src@@ -134,6 +66,7 @@                       , transformers                       , witherable                       , composition+                      , composition-extra >= 2.0.0                       , semigroups                       , constraints                       , containers@@ -144,10 +77,14 @@                       , shakespeare                       , clay                       , bytestring+                      , bifunctors                       , attoparsec                       , regex-compat-                      , pred-trie >= 0.2-                      , poly-arity >= 0.0.4+                      , pred-trie >= 0.3+                      , tries+                      , poly-arity >= 0.0.6+                      , sets >= 0.0.5+                      , errors  Test-Suite spec   Type:                 exitcode-stdio-1.0@@ -165,6 +102,7 @@                       , regex-compat                       , containers                       , composition+                      , composition-extra                       , semigroups                       , text                       , aeson@@ -181,6 +119,115 @@                       , transformers                       , http-media                       , http-types+                      , sets+                      , errors+++Executable example+  if flag(Example)+    Buildable: True+  else+    Buildable: False+  Default-Language:     Haskell2010+  HS-Source-Dirs:       src+                      , examples+  GHC-Options:          -Wall+  Main-Is:              Main.hs+  Build-Depends:        base+                      , wai+                      , wai-extra+                      , wai-util+                      , warp+                      , http-types+                      , http-media+                      , mtl+                      , transformers+                      , witherable+                      , composition+                      , composition-extra+                      , semigroups+                      , constraints+                      , containers+                      , text+                      , aeson+                      , blaze-html+                      , lucid+                      , shakespeare+                      , clay+                      , bytestring+                      , attoparsec+                      , regex-compat+                      , pred-trie+                      , tries+                      , poly-arity+                      , sets+                      , errors++Executable example-stm+  if flag(Example-STM)+    Buildable: True+  else+    Buildable: False+  Default-Language:     Haskell2010+  HS-Source-Dirs:       src+                      , examples+  GHC-Options:          -Wall+  Main-Is:              STM.hs+  Other-Modules:        STM.Auth+                        Web.Routes.Nested+                        Web.Routes.Nested.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+                      , cookie+                      , wai-util+                      , warp+                      , http-types+                      , http-media+                      , mtl+                      , transformers+                      , witherable+                      , composition+                      , composition-extra+                      , semigroups+                      , constraints+                      , containers+                      , text+                      , aeson+                      , blaze-html+                      , lucid+                      , shakespeare+                      , clay+                      , bytestring+                      , attoparsec+                      , regex-compat+                      , pred-trie+                      , tries+                      , poly-arity+                      , sets+                      , errors+                      , cryptonite+                      , memory+                      , time+                      , iso8601-time+                      , utf8-string+                      , stm+                      , errors+                      , cookie+                      , data-default+                      , blaze-builder+                      , base64-bytestring  Source-Repository head   Type:                 git

@@ -13,13 +13,40 @@   #-}  module Web.Routes.Nested-  ( module X+  ( -- * Types+    module X+  , Tries   , HandlerT (..)   , ActionT+  , RoutesT+  , ApplicationT+  , MiddlewareT+  , AuthScope (..)+  -- * Combinators   , handle   , parent+  , auth   , notFound+  -- * Entry Point   , route+  , routeAuth+  -- * 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@@ -31,257 +58,433 @@ import           Network.HTTP.Media import           Network.Wai -import           Data.Trie.Pred.Unified-import qualified Data.Trie.Pred.Unified            as P+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.Lazy                     as M+import qualified Data.Map                          as Map+import           Data.Trie.Map (MapStep (..)) import qualified Data.ByteString                   as B-import qualified Data.ByteString.Lazy              as BL+import           Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty                as NE import           Data.Maybe                        (fromMaybe)-import           Data.Constraint-import           Data.Witherable-import           Data.List+import           Data.Witherable hiding (filter)+import           Data.Functor.Syntax import           Data.Function.Poly+import           Data.List hiding (filter) -import           Control.Arrow-import           Control.Applicative+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  -newtype HandlerT x m a = HandlerT-  { runHandler :: WriterT ( RUPTrie T.Text x-                          , RUPTrie T.Text x ) m a }-  deriving (Functor, Applicative, Monad, MonadIO, MonadTrans)+type Tries x s e e' = ( RootedPredTrie T.Text x+                      , RootedPredTrie T.Text x+                      , RootedPredTrie T.Text s+                      , RootedPredTrie T.Text e+                      ) -type ActionT m a = VerbListenerT (FileExtListenerT Response m a) m a+newtype HandlerT x sec err errSym uploadSym m a = HandlerT+  { runHandlerT :: WriterT (Tries x sec err errSym) m a }+  deriving ( Functor+           , Applicative+           , Monad+           , MonadIO+           , MonadTrans+           , MonadWriter (Tries x sec err errSym)+           ) +execHandlerT :: Monad m => HandlerT x sec err errSym uploadSym m a -> m (Tries x sec err errSym)+execHandlerT = execWriterT . runHandlerT++type ActionT u m a = VerbListenerT (FileExtListenerT Response m a) 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+ -- | For routes ending with a literal. handle :: ( Monad m           , Functor m-          , cleanxs ~ OnlyJusts xs-          , HasResult childType (ActionT m ())-          , ExpectArity cleanxs childType+          , cleanxs ~ CatMaybes xs+          , HasResult childContent (ActionT u m ())+          , HasResult childErr     (e -> ActionT u m ())+          , ExpectArity cleanxs childContent+          , ExpectArity cleanxs childSec+          , ExpectArity cleanxs childErr           , Singleton (UrlChunks xs)-              childType-              (RUPTrie T.Text result)+              childContent+              (RootedPredTrie T.Text resultContent)           , Extrude (UrlChunks xs)-              (RUPTrie T.Text childType)-              (RUPTrie T.Text result)-          , (ArityMinusTypeList childType cleanxs) ~ result-          , childType ~ TypeListToArity cleanxs result-          ) => UrlChunks xs -- ^ Path to match against-            -> Maybe childType -- ^ Possibly a function, ending in @ActionT z m ()@.-            -> Maybe (HandlerT childType m ()) -- ^ Potential child routes-            -> HandlerT result m ()-handle ts (Just vl) Nothing =-  HandlerT $ tell (singleton ts vl, mempty)+              (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+          ) => 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) handle ts mvl (Just cs) = do-  (Rooted _ ctrie,_) <- lift $ execWriterT $ runHandler cs-  HandlerT $ tell (extrude ts $ Rooted mvl ctrie, mempty)+  (RootedPredTrie _ trieContent,trieNotFound,trieSec,trieErr) <- lift $ execHandlerT cs+  tell ( extrude ts $ RootedPredTrie mvl trieContent+       , extrude ts trieNotFound+       , extrude ts trieSec+       , extrude ts trieErr+       ) handle _ Nothing Nothing = return ()  parent :: ( Monad m           , Functor m-          , cleanxs ~ OnlyJusts xs+          , cleanxs ~ CatMaybes xs           , Singleton (UrlChunks xs)-              childType-              (RUPTrie T.Text result)+              childContent+              (RootedPredTrie T.Text resultContent)           , Extrude (UrlChunks xs)-              (RUPTrie T.Text childType)-              (RUPTrie T.Text result)-          , (ArityMinusTypeList childType cleanxs) ~ result-          , childType ~ TypeListToArity cleanxs result+              (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           ) => UrlChunks xs-            -> HandlerT childType m ()-            -> HandlerT result m ()+            -> HandlerT childContent  childSec  childErr  e u m ()+            -> HandlerT resultContent resultSec resultErr e u m () parent ts cs = do-  (Rooted _ ctrie,_) <- lift $ execWriterT $ runHandler cs-  HandlerT $ tell (extrude ts $ Rooted Nothing ctrie, mempty)+  (trieContent,trieNotFound,trieSec,trieErr) <- lift $ execHandlerT cs+  tell ( extrude ts trieContent+       , extrude ts trieNotFound+       , extrude ts trieSec+       , extrude ts trieErr+       ) ++data AuthScope = ProtectParent | ProtectChildren+  deriving (Show, Eq)++-- | Sets the security role and error handler for a scope of routes.+auth :: ( Monad m+        , Functor m+        ) => sec+          -> err+          -> AuthScope+          -> HandlerT content (sec, AuthScope) err e u m ()+auth token handleFail scope =+  tell ( mempty+       , mempty+       , RootedPredTrie (Just (token,scope)) mempty+       , RootedPredTrie (Just handleFail) mempty+       )++ notFound :: ( Monad m             , Functor m-            , cleanxs ~ OnlyJusts xs-            , HasResult childType (ActionT m ())-            , ExpectArity cleanxs childType+            , cleanxs ~ CatMaybes xs+            , HasResult childContent (ActionT u m ())+            , HasResult childErr     (e -> ActionT u m ())+            , ExpectArity cleanxs childContent+            , ExpectArity cleanxs childSec+            , ExpectArity cleanxs childErr             , Singleton (UrlChunks xs)-                childType-                (RUPTrie T.Text result)+                childContent+                (RootedPredTrie T.Text resultContent)             , Extrude (UrlChunks xs)-                (RUPTrie T.Text childType)-                (RUPTrie T.Text result)-            , (ArityMinusTypeList childType cleanxs) ~ result-            , childType ~ TypeListToArity cleanxs result+                (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             ) => UrlChunks xs-              -> Maybe childType-              -> Maybe (HandlerT childType m ())-              -> HandlerT result m ()-notFound ts (Just vl) Nothing =-  HandlerT $ tell (mempty, singleton ts vl)+              -> 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) notFound ts mvl (Just cs) = do-  (Rooted _ ctrie,_) <- lift $ execWriterT $ runHandler cs-  HandlerT $ tell (mempty, extrude ts $ Rooted mvl ctrie)+  (trieContent,RootedPredTrie _ trieNotFound,trieSec,trieErr) <- lift $ execHandlerT cs+  tell ( extrude ts trieContent+       , extrude ts $ RootedPredTrie mvl trieNotFound+       , extrude ts trieSec+       , extrude ts trieErr+       ) notFound _ Nothing Nothing = return ()  -type Application' m = Request -> (Response -> IO ResponseReceived) -> m ResponseReceived ++type ApplicationT m = Request -> (Response -> IO ResponseReceived) -> m ResponseReceived+type MiddlewareT m = ApplicationT m -> ApplicationT m++type AcceptHeader = B.ByteString++ -- | Turns a @HandlerT@ into a Wai @Application@ route :: ( Functor m          , Monad m          , MonadIO m-         ) => HandlerT (ActionT m ()) m a -- ^ Assembled @handle@ calls-           -> Application' m-route h req respond = do-  (rtrie, nftrie) <- execWriterT $ runHandler h-  let mMethod  = httpMethodToMSym $ requestMethod req-      mFileext = case pathInfo req of-                         [] -> Just Html-                         xs -> toExt $ T.dropWhile (/= '.') $ last xs-      mnftrans = P.lookupNearestParent (pathInfo req) nftrie-      acceptBS = Prelude.lookup ("Accept" :: HeaderName) $ requestHeaders req-      fe = fromMaybe Html mFileext+         ) => HandlerT (ActionT u m ()) sec err e u m a -- ^ Assembled @handle@ calls+           -> MiddlewareT m+route hs = extractContent hs . extractNotFound hs -  notFoundBasic <- handleNotFound req acceptBS Html GET mnftrans -  case mMethod of-    Nothing -> liftIO $ respond404 notFoundBasic-    Just v  -> do-      menf <- handleNotFound req acceptBS fe v mnftrans-      let failResp = liftIO $ respond404 menf+-- | 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.+routeAuth :: ( Functor m+             , Monad m+             , MonadIO m+             ) => (Request -> [sec] -> ExceptT e m (Response -> Response)) -- ^ authorize+               -> RoutesT u sec e m () -- ^ Assembled @handle@ calls+               -> MiddlewareT m+routeAuth authorize hs = extractAuth authorize hs . route hs -      case P.lookupWithL trimFileExt (pathInfo req) rtrie of-        Nothing -> case pathInfo req of-          [] -> failResp-          _  -> case trimFileExt $ last $ pathInfo req of-                  "index" -> maybe failResp-                               (\foundM -> continue req acceptBS fe v foundM menf) $-                               P.lookup (init $ pathInfo req) rtrie-                  _ -> failResp-        Just foundM -> continue req acceptBS fe v foundM menf+-- | Turn the trie carrying the main content into a middleware.+extractContent :: ( Functor m+                  , Monad m+                  , MonadIO m+                  ) => HandlerT (ActionT u m ()) sec err e u m a -- ^ Assembled @handle@ calls+                    -> 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+    Nothing -> fromMaybe (app req respond) $ do+      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 ++-- | Manually fetch the security tokens / authorization roles affiliated with+-- a request and your routing system.+extractAuthSym :: ( Functor m+                  , Monad m+                  ) => HandlerT x (sec, AuthScope) err e u m a+                    -> Request+                    -> m [sec]+extractAuthSym hs req = do+  (_,_,trie,_) <- execHandlerT hs+  return $ foldl go [] (PT.matchesRPT (pathInfo req) trie)   where-    onJustM :: Monad m => (a -> m (Maybe b)) -> Maybe a -> m (Maybe b)-    onJustM = maybe (return Nothing)+    go ys (_,(_,ProtectChildren),[]) = ys+    go ys (_,(x,_),_) = ys ++ [x]  -    handleNotFound :: MonadIO m =>-                      Request-                   -> Maybe B.ByteString+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+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)+                    $ (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.+extractNotFound :: ( Functor m+                   , Monad m+                   , MonadIO m+                   ) => HandlerT (ActionT u m ()) sec err e u 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.+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+                       -> 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)+      $ getResultsFromMatch <$> PT.matchRPT (pathInfo req) trie++++-- | 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-                   -> Maybe (ActionT m ())-                   -> m (Maybe Response)-    handleNotFound req acceptBS f v mnfcomp =-      let handleEither nfcomp = do-            vmapLit <- execWriterT $ runVerbListenerT nfcomp-            onJustM (\(_, femonad) -> do-              femap <- execWriterT $ runFileExtListenerT femonad-              return $ lookupProper acceptBS f $ unFileExts femap) $-                M.lookup v $ supplyReq req $ unVerbs vmapLit-      in onJustM handleEither mnfcomp+                   -> 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  -    continue :: MonadIO m =>-                Request-             -> Maybe B.ByteString-             -> FileExt-             -> Verb-             -> ActionT m ()-             -> Maybe Response-             -> m ResponseReceived-    continue req acceptBS f v foundM mnfResp = do-      vmapLit <- execWriterT $ runVerbListenerT foundM-      continueMap acceptBS f v (supplyReq req $ unVerbs vmapLit) mnfResp+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 -    continueMap :: MonadIO m =>-                   Maybe B.ByteString-                -> FileExt-                -> Verb-                -> M.Map Verb ( Maybe (BL.ByteString -> m (), Maybe BodyLength)-                              , FileExtListenerT Response m ()-                              )-                -> Maybe Response-                -> m ResponseReceived-    continueMap acceptBS f v vmap mnfResp = do-      let failResp = liftIO $ respond404 mnfResp+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 -      maybe failResp (\(mreqbodyf, femonad) -> do-          femap <- execWriterT $ runFileExtListenerT femonad-          maybe failResp (\r ->-              case mreqbodyf of-                Nothing              -> liftIO $ respond r-                Just (reqbf,Nothing) -> handleUpload req reqbf respond r-                Just (reqbf,Just bl) ->-                  case requestBodyLength req of-                    KnownLength bl' ->-                      if bl' <= bl-                      then handleUpload req reqbf respond r-                      else failResp-                    _ -> failResp) $-            lookupProper acceptBS f $ unFileExts femap) $-        M.lookup v vmap -    handleUpload req reqbf respond r = do-      body <- liftIO $ strictRequestBody req-      reqbf body-      liftIO $ respond r+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 -    respond404 :: Maybe Response -> IO ResponseReceived-    respond404 mr = respond $ fromMaybe plain404 mr -    plain404 :: Response-    plain404 = responseLBS status404 [("Content-Type","text/plain")] "404"+-- | 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 -    lookupProper :: Maybe B.ByteString -> FileExt -> M.Map FileExt a -> Maybe a-    lookupProper maccept k xs =-      let attempts = maybe [Html,Text,Json,JavaScript,Css]-                       (possibleFileExts k) maccept-      in foldr (go xs) Nothing attempts-      where-        go xs x Nothing = M.lookup x xs-        go _ _ (Just y) = Just y -    possibleFileExts :: FileExt -> B.ByteString -> [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+-- | 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 -    trimFileExt :: T.Text -> T.Text-    trimFileExt s = if T.unpack s `endsWithAny` possibleExts-                    then T.pack $ takeWhile (/= '.') $ T.unpack s-                    else s-      where-        possibleExts = [ ".html",".htm",".txt",".json",".lucid"-                       , ".julius",".css",".cassius",".lucius"-                       ]-        endsWithAny s xs = dropWhile (/= '.') s `elem` xs -    httpMethodToMSym :: Method -> Maybe Verb-    httpMethodToMSym x | x == methodGet    = Just GET-                       | x == methodPost   = Just POST-                       | x == methodPut    = Just PUT-                       | x == methodDelete = Just DELETE-                       | otherwise         = Nothing+----- Internal Utilities -----------------------------------++-- | 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+  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+++-- * 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+  where+    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++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

@@ -21,17 +21,29 @@ 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 s hs i =+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 r+    FileExts $ singleton Html $ f r   @@ -47,5 +59,3 @@ blazeOnlyStatusHeaders :: Status -> RequestHeaders -> H.Html -> Response blazeOnlyStatusHeaders s hs i =   bytestringOnlyStatus s hs $ LT.encodeUtf8 $ H.renderHtml i--

@@ -19,11 +19,17 @@ 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 e s hs i =+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 r+    FileExts $ singleton e $ f r   

@@ -19,11 +19,21 @@ bytestring :: Monad m => FileExt -> RequestHeaders -> B.ByteString -> FileExtListenerT Response m () bytestring e = bytestringStatus e status200 -bytestringStatus :: Monad m => FileExt -> Status -> RequestHeaders -> B.ByteString -> FileExtListenerT Response m ()-bytestringStatus e s hs i = do+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 r+    FileExts $ singleton e $ f r   bytestringOnly :: RequestHeaders -> B.ByteString -> Response

@@ -9,7 +9,6 @@  import           Data.Map import           Text.Cassius-import qualified Data.Text.Lazy                          as LT import qualified Data.Text.Lazy.Encoding                 as LT import           Network.HTTP.Types                      (RequestHeaders,                                                           Status, status200)@@ -22,17 +21,29 @@ 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 s hs i =+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 r+    FileExts $ singleton Css $ f r   @@ -48,8 +59,3 @@  cassiusOnlyStatusHeaders :: Status -> RequestHeaders -> Css -> Response cassiusOnlyStatusHeaders s hs i = bytestringOnlyStatus s hs $ LT.encodeUtf8 $ renderCss i-----

@@ -10,7 +10,6 @@ import           Data.Map import           Clay.Render import           Clay.Stylesheet-import qualified Data.Text.Lazy                          as LT import qualified Data.Text.Lazy.Encoding                 as LT import           Network.HTTP.Types                      (RequestHeaders,                                                           Status, status200)@@ -23,17 +22,29 @@ clay :: Monad m => Config -> [App] -> Css -> FileExtListenerT Response m () clay c as = clayStatusHeaders c as status200 [("Content-Type", "text/css")] -clayStatus :: Monad m =>Config -> [App] ->  Status -> Css -> FileExtListenerT Response m ()+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 c as s hs i =+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 r+    FileExts $ singleton Css $ f r   @@ -49,8 +60,3 @@  clayOnlyStatusHeaders :: Config -> [App] -> Status -> RequestHeaders -> Css -> Response clayOnlyStatusHeaders c as s hs i = bytestringOnlyStatus s hs $ LT.encodeUtf8 $ renderWith c as i-----

@@ -18,38 +18,68 @@  -- | 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 ()+        , 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 ()+              , 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 ()+         , 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 ()+               , 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 ()+               , 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 s hs i =+                     , 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 r+    FileExts $ singleton Json $ f r   @@ -78,4 +108,3 @@             Status -> RequestHeaders -> j -> Response jsonOnlyStatusHeaders s hs i =   bytestringOnlyStatus s hs $ A.encode i-

@@ -9,7 +9,6 @@  import           Data.Map import           Text.Julius-import qualified Data.Text.Lazy                          as LT import qualified Data.Text.Lazy.Encoding                 as LT import           Network.HTTP.Types                      (RequestHeaders,                                                           Status, status200)@@ -22,17 +21,29 @@ 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 s hs i =+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 r+    FileExts $ singleton JavaScript $ f r   @@ -48,8 +59,3 @@  juliusOnlyStatusHeaders :: Status -> RequestHeaders -> Javascript -> Response juliusOnlyStatusHeaders s hs i = bytestringOnlyStatus s hs $ LT.encodeUtf8 $ renderJavascript i-----

@@ -16,24 +16,32 @@   -- | Uses the @Html@ key in the map, and @"text/html"@ as the content type.-lucid :: Monad m =>-         L.HtmlT m () -> FileExtListenerT Response m ()+lucid :: Monad m => L.HtmlT m () -> FileExtListenerT Response m () lucid = lucidStatusHeaders status200 [("Content-Type", "text/html")] -lucidStatus :: Monad m =>-         Status -> L.HtmlT m () -> FileExtListenerT Response m ()+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")] -lucidHeaders :: Monad m =>-         RequestHeaders -> L.HtmlT m () -> FileExtListenerT Response m ()+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 -lucidStatusHeaders :: Monad m =>-         Status -> RequestHeaders -> L.HtmlT m () -> FileExtListenerT Response m ()-lucidStatusHeaders s hs i = do+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 r+    FileExts $ singleton Html $ f r   

@@ -9,7 +9,6 @@  import           Data.Map import           Text.Lucius-import qualified Data.Text.Lazy                          as LT import qualified Data.Text.Lazy.Encoding                 as LT import           Network.HTTP.Types                      (RequestHeaders,                                                           Status, status200)@@ -22,17 +21,29 @@ 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 s hs i =+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 r+    FileExts $ singleton FE.Css $ f r   @@ -48,8 +59,3 @@  luciusOnlyStatusHeaders :: Status -> RequestHeaders -> Css -> Response luciusOnlyStatusHeaders s hs i = bytestringOnlyStatus s hs $ LT.encodeUtf8 $ renderCss i-----

@@ -14,7 +14,6 @@                                                           Status, status200) import           Network.Wai -import           Data.Composition import           Control.Monad.Writer  @@ -22,17 +21,31 @@ 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 s hs i =+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 r+    FileExts $ singleton Text $ f r   

@@ -3,6 +3,9 @@   , DeriveTraversable   , GeneralizedNewtypeDeriving   , OverloadedStrings+  , StandaloneDeriving+  , FlexibleInstances+  , MultiParamTypeClasses   #-}  @@ -10,13 +13,9 @@  import qualified Data.Text            as T -import           Control.Applicative import           Control.Monad.Trans import           Control.Monad.Writer-import           Data.Foldable        hiding (elem) import           Data.Map-import           Data.Monoid-import           Data.Traversable   -- | Supported file extensions@@ -47,4 +46,8 @@  newtype FileExtListenerT r m a =   FileExtListenerT { runFileExtListenerT :: WriterT (FileExts r) m a }-    deriving (Functor, Applicative, Monad, MonadIO, MonadTrans)+    deriving (Functor, Applicative, Monad, MonadIO, MonadTrans,+              MonadWriter (FileExts r))++execFileExtListenerT :: Monad m => FileExtListenerT r m a -> m (FileExts r)+execFileExtListenerT = execWriterT . runFileExtListenerT

@@ -16,88 +16,77 @@   ( Singleton (..)   , Extend (..)   , Extrude (..)-  , OnlyJusts-  , eitherToMaybe-  , restAreLits-  , ToNE (..)-  , ToL (..)+  , CatMaybes   , module Web.Routes.Nested.Types.UrlChunks   ) where -import Data.Attoparsec.Text-import Text.Regex-import Web.Routes.Nested.Types.UrlChunks+import           Data.Attoparsec.Text+import           Text.Regex+import           Web.Routes.Nested.Types.UrlChunks import qualified Data.Text as T-import           Data.List.NonEmpty-import Data.Trie.Pred.Unified+import           Data.Trie.Pred+import           Data.Trie.Pred.Step+import qualified Data.Trie.Map as MT+import qualified Data.Map as Map  -type family OnlyJusts (xs :: [Maybe *]) :: [*] where-  OnlyJusts '[] = '[]-  OnlyJusts ('Nothing  ': xs) = OnlyJusts xs-  OnlyJusts (('Just x) ': xs) = x ': OnlyJusts xs+type family CatMaybes (xs :: [Maybe *]) :: [*] where+  CatMaybes '[] = '[]+  CatMaybes ('Nothing  ': xs) = CatMaybes xs+  CatMaybes (('Just x) ': xs) = x ': CatMaybes xs +-- | Creates a string of nodes - a trie with a width of 1. class Singleton chunks a trie | chunks a -> trie where   singleton :: chunks -> a -> trie -instance Singleton (UrlChunks '[]) a (RUPTrie T.Text a) where-  singleton Root r = Rooted (Just r) []+-- Basis+instance Singleton (UrlChunks '[]) a (RootedPredTrie T.Text a) where+  singleton Root r' = RootedPredTrie (Just r') emptyPT +-- Successor instance ( Singleton (UrlChunks xs) a trie0-         , Extend (EitherUrlChunk x) trie0 trie1 )=>-         Singleton (UrlChunks (x ': xs)) a trie1 where-  singleton (Cons u us) r = extend u (singleton us r)+         , Extend (EitherUrlChunk x) trie0 trie1+         ) => Singleton (UrlChunks (x ': xs)) a trie1 where+  singleton (Cons u us) r' = extend u (singleton us r')  +-- | Turn a list of tries (@Rooted@) into a node with those children class Extend eitherUrlChunk child result | eitherUrlChunk child -> result where   extend :: eitherUrlChunk -> child -> result -instance Extend (EitherUrlChunk  'Nothing) (RUPTrie T.Text a) (RUPTrie T.Text a) where-  extend ((:=) t) (Rooted mx xs) = Rooted Nothing [UMore t mx xs]+-- | Literal case+instance Extend (EitherUrlChunk  'Nothing) (RootedPredTrie T.Text a) (RootedPredTrie T.Text a) where+  extend ((:=) t) (RootedPredTrie mx xs) = RootedPredTrie Nothing $+    PredTrie (MT.MapStep $ Map.singleton t (mx, Just xs)) mempty -instance Extend (EitherUrlChunk ('Just r)) (RUPTrie T.Text (r -> a)) (RUPTrie T.Text a) where-  extend ((:~) (t,q)) (Rooted mx xs) = Rooted Nothing [UPred t (eitherToMaybe . parseOnly q) mx xs]-  extend ((:*) (t,q)) (Rooted mx xs) = Rooted Nothing [UPred t (matchRegex q . T.unpack)     mx xs]+-- | Existentially quantified case+instance Extend (EitherUrlChunk ('Just r)) (RootedPredTrie T.Text (r -> a)) (RootedPredTrie T.Text a) where+  extend ((:~) (i,q)) (RootedPredTrie mx xs) = RootedPredTrie Nothing $+    PredTrie mempty $ PredSteps [PredStep i (eitherToMaybe . parseOnly q) mx xs]+  extend ((:*) (i,q)) (RootedPredTrie mx xs) = RootedPredTrie Nothing $+    PredTrie mempty $ PredSteps [PredStep i (matchRegex q . T.unpack) mx xs]  +-- | @FoldR Extend start chunks ~ result@ class Extrude chunks start result | chunks start -> result where   extrude :: chunks -> start -> result -instance Extrude (UrlChunks '[]) (RUPTrie T.Text a) (RUPTrie T.Text a) where-  extrude Root r = r+-- Basis+instance Extrude (UrlChunks '[]) (RootedPredTrie T.Text a) (RootedPredTrie T.Text a) where+  extrude Root r' = r' +-- Successor instance ( Extrude (UrlChunks xs) trie0 trie1          , Extend (EitherUrlChunk x) trie1 trie2 ) => Extrude (UrlChunks (x ': xs)) trie0 trie2 where-  extrude (Cons u us) r = extend u (extrude us r)+  extrude (Cons u us) r' = extend u (extrude us r')   eitherToMaybe :: Either String r -> Maybe r-eitherToMaybe (Right r) = Just r+eitherToMaybe (Right r') = Just r' eitherToMaybe _         = Nothing -restAreLits :: UrlChunks xs -> Bool-restAreLits Root = False-restAreLits (Cons ((:=) _) Root) = True-restAreLits (Cons ((:=) _) us)   = restAreLits us-restAreLits (Cons _ _) = False---class ToNE chunks where-  toNE :: chunks -> NonEmpty T.Text--instance ToNE (UrlChunks ('Nothing ': '[])) where-  toNE (Cons ((:=) t) Root) = t :| []--instance ToNE (UrlChunks xs) => ToNE (UrlChunks ('Nothing ': xs)) where-  toNE (Cons ((:=) t) us) = t :| (toList $ toNE us)---class ToL chunks where-  toL :: chunks -> [T.Text]--instance ToL (UrlChunks '[]) where-  toL Root = []--instance ToL (UrlChunks xs) => ToL (UrlChunks ('Nothing ': xs)) where-  toL (Cons ((:=) t) us) = t : toL us-+-- restAreLits :: UrlChunks xs -> Bool+-- restAreLits Root = False+-- restAreLits (Cons ((:=) _) Root) = True+-- restAreLits (Cons ((:=) _) us)   = restAreLits us+-- restAreLits (Cons _ _) = False

@@ -20,7 +20,7 @@   (:~) :: (T.Text, Parser r) -> EitherUrlChunk ('Just r)   (:*) :: (T.Text, Regex)    -> EitherUrlChunk ('Just [String]) --- | Match against a /literal/ chunk+-- | Match against a /Literal/ chunk l :: T.Text -> EitherUrlChunk 'Nothing l = (:=) @@ -28,11 +28,11 @@ instance x ~ 'Nothing => IsString (EitherUrlChunk x) where   fromString = l . T.pack --- | Match against a /parsed/ chunk+-- | Match against a /Parsed/ chunk p :: (T.Text, Parser r) -> EitherUrlChunk ('Just r) p = (:~) --- | Match against a /regular expression/ chunk+-- | Match against a /Regular expression/ chunk r :: (T.Text, Regex) -> EitherUrlChunk ('Just [String]) r = (:*) @@ -47,6 +47,6 @@  infixr 9 </> --- | The /origin/ chunk - the equivalent to @./@ in BASH+-- | The /new-Origin/ chunk - the equivalent to @[]@ o :: UrlChunks '[] o = Root

@@ -1,8 +1,5 @@ {-# LANGUAGE-    DeriveFunctor-  , DeriveTraversable-  , DeriveFoldable-  , GeneralizedNewtypeDeriving+    GeneralizedNewtypeDeriving   , ScopedTypeVariables   , MultiParamTypeClasses   , TupleSections@@ -13,149 +10,124 @@ import           Network.Wai (Request) import           Network.HTTP.Types (StdMethod (..)) -import           Data.Foldable-import           Data.Traversable-import           Data.Map                             as Map-import qualified Data.ByteString.Lazy                 as BL-import           Data.Word                            (Word64)-import           Control.Arrow-import           Control.Applicative hiding (empty)+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 BodyLength = Word64+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) -newtype Verbs m r = Verbs-  { unVerbs :: Map Verb ( Maybe (BL.ByteString -> m (), Maybe BodyLength)-                        , Either r (Request -> r)-                        )-  } deriving (Monoid) +-- * 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 ( Maybe (BL.ByteString -> m (), Maybe BodyLength)-                      , Either r (Request -> r)-                      )-          -> Map Verb ( Maybe (BL.ByteString -> m (), Maybe BodyLength)-                      , r-                      )-supplyReq req xs = second (either id ($ req)) <$> xs+          -> Map Verb (ResponseSpec u m r)+          -> Map Verb (m (Maybe u), Maybe u -> r)+supplyReq req xs = bimap ($ req) ($ req) <$> xs -instance Functor (Verbs m) where-  fmap f (Verbs xs) = Verbs $ fmap go xs-    where go (x, Left r)  = (x, Left $ f r)-          go (x, Right r) = (x, Right $ f . r)+instance Functor (Verbs u m) where+  fmap f (Verbs xs) = Verbs $ fmap (second (f .*)) xs -instance Foldable (Verbs m) where-  foldMap f (Verbs xs) = foldMap go xs-    where go (_, Left r) = f r-          go _ = mempty+-- 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 -newtype VerbListenerT r m a =-  VerbListenerT { runVerbListenerT :: WriterT (Verbs m r) m a }-    deriving (Functor, Applicative, Monad, MonadIO) -instance MonadTrans (VerbListenerT r) where+-- * 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 = foldlWithKey (\macc k a -> (\mer -> f mer k a) =<< macc) (return i)+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 m ()-get r = do-  let new = singleton GET (Nothing, Left r)-  VerbListenerT $ tell $ Verbs new+       ) => 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 m ()-getReq r = do-  let new = singleton GET (Nothing, Right r)-  VerbListenerT $ tell $ Verbs new+          ) => (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-        ) => (BL.ByteString -> m ()) -> r -> VerbListenerT r m ()-post handle r = do-  let new = singleton POST (Just (handle, Nothing), Left r)-  VerbListenerT $ tell $ Verbs new+        ) => 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-           ) => (BL.ByteString -> m ()) -> (Request -> r) -> VerbListenerT r m ()-postReq handle r = do-  let new = singleton POST (Just (handle, Nothing), Right r)-  VerbListenerT $ tell $ Verbs new---- | Supply a maximum size bound for file uploads-postMax :: ( Monad m-           , MonadIO m-           ) => BodyLength -> (BL.ByteString -> m ()) -> r -> VerbListenerT r m ()-postMax bl handle r = do-  let new = singleton POST (Just (handle, Just bl), Left r)-  VerbListenerT $ tell $ Verbs new---- | Inspect the @Request@ object supplied by WAI-postMaxReq :: ( Monad m-              , MonadIO m-              ) => BodyLength -> (BL.ByteString -> m ()) -> (Request -> r) -> VerbListenerT r m ()-postMaxReq bl handle r = do-  let new = singleton POST (Just (handle, Just bl), Right r)-  VerbListenerT $ tell $ Verbs new+           ) => 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-       ) => (BL.ByteString -> m ()) -> r -> VerbListenerT r m ()-put handle r = do-  let new = singleton PUT (Just (handle, Nothing), Left r)-  VerbListenerT $ tell $ Verbs new+       ) => 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-          ) => (BL.ByteString -> m ()) -> (Request -> r) -> VerbListenerT r m ()-putReq handle r = do-  let new = singleton PUT (Just (handle, Nothing), Right r)-  VerbListenerT $ tell $ Verbs new---- | Supply a maximum size bound for file uploads-putMax :: ( Monad m-          , MonadIO m-          ) => BodyLength -> (BL.ByteString -> m ()) -> r -> VerbListenerT r m ()-putMax bl handle r = do-  let new = singleton PUT (Just (handle, Just bl), Left r)-  VerbListenerT $ tell $ Verbs new---- | Inspect the @Request@ object supplied by WAI-putMaxReq :: ( Monad m-             , MonadIO m-             ) => BodyLength -> (BL.ByteString -> m ()) -> (Request -> r) -> VerbListenerT r m ()-putMaxReq bl handle r = do-  let new = singleton PUT (Just (handle, Just bl), Right r)-  VerbListenerT $ tell $ Verbs new+          ) => 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 m ()-delete r = do-  let new = singleton DELETE (Nothing, Left r)-  VerbListenerT $ tell $ Verbs new+          ) => 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 m ()-deleteReq r = do-  let new = singleton DELETE (Nothing, Right r)-  VerbListenerT $ tell $ Verbs new+             ) => (Request -> r) -> VerbListenerT r u m ()+deleteReq r = tell $ Union $ Verbs $ Map.singleton DELETE ( const $ return Nothing+                                                          , const . r+                                                          )