diff --git a/Setup.hs b/Setup.hs
deleted file mode 100644
--- a/Setup.hs
+++ /dev/null
@@ -1,2 +0,0 @@
-import Distribution.Simple
-main = defaultMain
diff --git a/examples/Main.hs b/examples/Main.hs
new file mode 100644
--- /dev/null
+++ b/examples/Main.hs
@@ -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 :("
diff --git a/examples/STM.hs b/examples/STM.hs
new file mode 100644
--- /dev/null
+++ b/examples/STM.hs
@@ -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 :("
diff --git a/examples/STM/Auth.hs b/examples/STM/Auth.hs
new file mode 100644
--- /dev/null
+++ b/examples/STM/Auth.hs
@@ -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
diff --git a/nested-routes.cabal b/nested-routes.cabal
--- a/nested-routes.cabal
+++ b/nested-routes.cabal
@@ -1,5 +1,5 @@
 Name:                   nested-routes
-Version:                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
diff --git a/src/Web/Routes/Nested.hs b/src/Web/Routes/Nested.hs
--- a/src/Web/Routes/Nested.hs
+++ b/src/Web/Routes/Nested.hs
@@ -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
diff --git a/src/Web/Routes/Nested/FileExtListener/Blaze.hs b/src/Web/Routes/Nested/FileExtListener/Blaze.hs
--- a/src/Web/Routes/Nested/FileExtListener/Blaze.hs
+++ b/src/Web/Routes/Nested/FileExtListener/Blaze.hs
@@ -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
-
-
diff --git a/src/Web/Routes/Nested/FileExtListener/Builder.hs b/src/Web/Routes/Nested/FileExtListener/Builder.hs
--- a/src/Web/Routes/Nested/FileExtListener/Builder.hs
+++ b/src/Web/Routes/Nested/FileExtListener/Builder.hs
@@ -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
 
 
 
diff --git a/src/Web/Routes/Nested/FileExtListener/ByteString.hs b/src/Web/Routes/Nested/FileExtListener/ByteString.hs
--- a/src/Web/Routes/Nested/FileExtListener/ByteString.hs
+++ b/src/Web/Routes/Nested/FileExtListener/ByteString.hs
@@ -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
diff --git a/src/Web/Routes/Nested/FileExtListener/Cassius.hs b/src/Web/Routes/Nested/FileExtListener/Cassius.hs
--- a/src/Web/Routes/Nested/FileExtListener/Cassius.hs
+++ b/src/Web/Routes/Nested/FileExtListener/Cassius.hs
@@ -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
-
-
-
-
-
diff --git a/src/Web/Routes/Nested/FileExtListener/Clay.hs b/src/Web/Routes/Nested/FileExtListener/Clay.hs
--- a/src/Web/Routes/Nested/FileExtListener/Clay.hs
+++ b/src/Web/Routes/Nested/FileExtListener/Clay.hs
@@ -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
-
-
-
-
-
diff --git a/src/Web/Routes/Nested/FileExtListener/Json.hs b/src/Web/Routes/Nested/FileExtListener/Json.hs
--- a/src/Web/Routes/Nested/FileExtListener/Json.hs
+++ b/src/Web/Routes/Nested/FileExtListener/Json.hs
@@ -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
-
diff --git a/src/Web/Routes/Nested/FileExtListener/Julius.hs b/src/Web/Routes/Nested/FileExtListener/Julius.hs
--- a/src/Web/Routes/Nested/FileExtListener/Julius.hs
+++ b/src/Web/Routes/Nested/FileExtListener/Julius.hs
@@ -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
-
-
-
-
-
diff --git a/src/Web/Routes/Nested/FileExtListener/Lucid.hs b/src/Web/Routes/Nested/FileExtListener/Lucid.hs
--- a/src/Web/Routes/Nested/FileExtListener/Lucid.hs
+++ b/src/Web/Routes/Nested/FileExtListener/Lucid.hs
@@ -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
 
 
 
diff --git a/src/Web/Routes/Nested/FileExtListener/Lucius.hs b/src/Web/Routes/Nested/FileExtListener/Lucius.hs
--- a/src/Web/Routes/Nested/FileExtListener/Lucius.hs
+++ b/src/Web/Routes/Nested/FileExtListener/Lucius.hs
@@ -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
-
-
-
-
-
diff --git a/src/Web/Routes/Nested/FileExtListener/Text.hs b/src/Web/Routes/Nested/FileExtListener/Text.hs
--- a/src/Web/Routes/Nested/FileExtListener/Text.hs
+++ b/src/Web/Routes/Nested/FileExtListener/Text.hs
@@ -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
 
 
 
diff --git a/src/Web/Routes/Nested/FileExtListener/Types.hs b/src/Web/Routes/Nested/FileExtListener/Types.hs
--- a/src/Web/Routes/Nested/FileExtListener/Types.hs
+++ b/src/Web/Routes/Nested/FileExtListener/Types.hs
@@ -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
diff --git a/src/Web/Routes/Nested/Types.hs b/src/Web/Routes/Nested/Types.hs
--- a/src/Web/Routes/Nested/Types.hs
+++ b/src/Web/Routes/Nested/Types.hs
@@ -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
diff --git a/src/Web/Routes/Nested/Types/UrlChunks.hs b/src/Web/Routes/Nested/Types/UrlChunks.hs
--- a/src/Web/Routes/Nested/Types/UrlChunks.hs
+++ b/src/Web/Routes/Nested/Types/UrlChunks.hs
@@ -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
diff --git a/src/Web/Routes/Nested/VerbListener.hs b/src/Web/Routes/Nested/VerbListener.hs
--- a/src/Web/Routes/Nested/VerbListener.hs
+++ b/src/Web/Routes/Nested/VerbListener.hs
@@ -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
+                                                          )