{-# LANGUAGE BangPatterns     #-}
{-# LANGUAGE CPP              #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE Rank2Types       #-}
module Snap.Internal.Routing
  ( Route(..)
  , pRoute
  , route
  , routeEarliestNC
  , routeHeight
  , routeLocal
  , splitPath
  ) where
------------------------------------------------------------------------------
import           Control.Applicative      ((<|>))
import           Data.ByteString          (ByteString)
import qualified Data.ByteString          as B (head, intercalate, length, null, pack, splitWith, tail)
import           Data.ByteString.Internal (c2w)
import           Data.HashMap.Strict      (HashMap)
import qualified Data.HashMap.Strict      as H (elems, empty, fromList, lookup, unionWith)
import qualified Data.Map                 as Map (empty, insertWith, unionWith)
import           Snap.Internal.Core       (MonadSnap, getRequest, getsRequest, localRequest, modifyRequest, pass, updateContextPath)
import           Snap.Internal.Http.Types (Params, Request (rqContextPath, rqParams, rqPathInfo))
import           Snap.Internal.Parsing    (urlDecode)
#if !MIN_VERSION_base(4,8,0)
import           Data.Monoid              (Monoid (..))
#endif
import           Data.Semigroup           (Semigroup (..))

------------------------------------------------------------------------------

------------------------------------------------------------------------------
-- | The internal data type you use to build a routing tree. Matching is
-- done unambiguously.
--
-- 'Capture' and 'Dir' routes can have a "fallback" route:
--
--   - For 'Capture', the fallback is routed when there is nothing to capture
--   - For 'Dir', the fallback is routed when we can't find a route in its map
--
-- Fallback routes are stacked: i.e. for a route like:
--
-- > Dir [("foo", Capture "bar" (Action bar) NoRoute)] baz
--
-- visiting the URI foo/ will result in the "bar" capture being empty and
-- triggering its fallback. It's NoRoute, so we go to the nearest parent
-- fallback and try that, which is the baz action.
data Route a m = Action ((MonadSnap m) => m a)   -- wraps a 'Snap' action
               -- captures the dir in a param
               | Capture ByteString (Route a m) (Route a m)
               -- match on a dir
               | Dir (HashMap ByteString (Route a m)) (Route a m)
               | NoRoute


------------------------------------------------------------------------------

instance Semigroup (Route a m) where
    Route a m
NoRoute <> :: Route a m -> Route a m -> Route a m
<> Route a m
r = Route a m
r

    l :: Route a m
l@(Action MonadSnap m => m a
a) <> Route a m
r = case Route a m
r of
      (Action MonadSnap m => m a
a')       -> (MonadSnap m => m a) -> Route a m
forall a (m :: * -> *). (MonadSnap m => m a) -> Route a m
Action (m a
MonadSnap m => m a
a m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m a
MonadSnap m => m a
a')
      (Capture ByteString
p Route a m
r' Route a m
fb) -> ByteString -> Route a m -> Route a m -> Route a m
forall a (m :: * -> *).
ByteString -> Route a m -> Route a m -> Route a m
Capture ByteString
p Route a m
r' (Route a m
fb Route a m -> Route a m -> Route a m
forall a. Semigroup a => a -> a -> a
<> Route a m
l)
      (Dir HashMap ByteString (Route a m)
_ Route a m
_)         -> HashMap ByteString (Route a m) -> Route a m -> Route a m
forall a (m :: * -> *).
HashMap ByteString (Route a m) -> Route a m -> Route a m
Dir HashMap ByteString (Route a m)
forall k v. HashMap k v
H.empty Route a m
l Route a m -> Route a m -> Route a m
forall a. Semigroup a => a -> a -> a
<> Route a m
r
      Route a m
NoRoute           -> Route a m
l

    -- Whenever we're unioning two Captures and their capture variables
    -- differ, we have an ambiguity. We resolve this in the following order:
    --   1. Prefer whichever route is longer
    --   2. Else, prefer whichever has the earliest non-capture
    --   3. Else, prefer the right-hand side
    l :: Route a m
l@(Capture ByteString
p Route a m
r' Route a m
fb) <> Route a m
r = case Route a m
r of
      (Action MonadSnap m => m a
_)           -> ByteString -> Route a m -> Route a m -> Route a m
forall a (m :: * -> *).
ByteString -> Route a m -> Route a m -> Route a m
Capture ByteString
p Route a m
r' (Route a m
fb Route a m -> Route a m -> Route a m
forall a. Semigroup a => a -> a -> a
<> Route a m
r)
      (Capture ByteString
p' Route a m
r'' Route a m
fb')
              | ByteString
p ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
p'    -> ByteString -> Route a m -> Route a m -> Route a m
forall a (m :: * -> *).
ByteString -> Route a m -> Route a m -> Route a m
Capture ByteString
p (Route a m
r' Route a m -> Route a m -> Route a m
forall a. Semigroup a => a -> a -> a
<> Route a m
r'') (Route a m
fb Route a m -> Route a m -> Route a m
forall a. Semigroup a => a -> a -> a
<> Route a m
fb')
              | Int
rh' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
rh'' -> ByteString -> Route a m -> Route a m -> Route a m
forall a (m :: * -> *).
ByteString -> Route a m -> Route a m -> Route a m
Capture ByteString
p Route a m
r' (Route a m
fb Route a m -> Route a m -> Route a m
forall a. Semigroup a => a -> a -> a
<> Route a m
r)
              | Int
rh' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
rh'' -> ByteString -> Route a m -> Route a m -> Route a m
forall a (m :: * -> *).
ByteString -> Route a m -> Route a m -> Route a m
Capture ByteString
p' Route a m
r'' (Route a m
fb' Route a m -> Route a m -> Route a m
forall a. Semigroup a => a -> a -> a
<> Route a m
l)
              | Int
en' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
en'' -> ByteString -> Route a m -> Route a m -> Route a m
forall a (m :: * -> *).
ByteString -> Route a m -> Route a m -> Route a m
Capture ByteString
p Route a m
r' (Route a m
fb Route a m -> Route a m -> Route a m
forall a. Semigroup a => a -> a -> a
<> Route a m
r)
              | Bool
otherwise  -> ByteString -> Route a m -> Route a m -> Route a m
forall a (m :: * -> *).
ByteString -> Route a m -> Route a m -> Route a m
Capture ByteString
p' Route a m
r'' (Route a m
fb' Route a m -> Route a m -> Route a m
forall a. Semigroup a => a -> a -> a
<> Route a m
l)
        where
          rh' :: Int
rh'  = Route a m -> Int
forall a (m :: * -> *). Route a m -> Int
routeHeight Route a m
r'
          rh'' :: Int
rh'' = Route a m -> Int
forall a (m :: * -> *). Route a m -> Int
routeHeight Route a m
r''
          en' :: Int
en'  = Route a m -> Int -> Int
forall a (m :: * -> *). Route a m -> Int -> Int
routeEarliestNC Route a m
r' Int
1
          en'' :: Int
en'' = Route a m -> Int -> Int
forall a (m :: * -> *). Route a m -> Int -> Int
routeEarliestNC Route a m
r'' Int
1
      (Dir HashMap ByteString (Route a m)
rm Route a m
fb')         -> HashMap ByteString (Route a m) -> Route a m -> Route a m
forall a (m :: * -> *).
HashMap ByteString (Route a m) -> Route a m -> Route a m
Dir HashMap ByteString (Route a m)
rm (Route a m
fb' Route a m -> Route a m -> Route a m
forall a. Semigroup a => a -> a -> a
<> Route a m
l)
      Route a m
NoRoute              -> Route a m
l

    (<>) l :: Route a m
l@(Dir HashMap ByteString (Route a m)
rm Route a m
fb) Route a m
r = case Route a m
r of
      (Action MonadSnap m => m a
_)      -> HashMap ByteString (Route a m) -> Route a m -> Route a m
forall a (m :: * -> *).
HashMap ByteString (Route a m) -> Route a m -> Route a m
Dir HashMap ByteString (Route a m)
rm (Route a m
fb Route a m -> Route a m -> Route a m
forall a. Semigroup a => a -> a -> a
<> Route a m
r)
      (Capture ByteString
_ Route a m
_ Route a m
_) -> HashMap ByteString (Route a m) -> Route a m -> Route a m
forall a (m :: * -> *).
HashMap ByteString (Route a m) -> Route a m -> Route a m
Dir HashMap ByteString (Route a m)
rm (Route a m
fb Route a m -> Route a m -> Route a m
forall a. Semigroup a => a -> a -> a
<> Route a m
r)
      (Dir HashMap ByteString (Route a m)
rm' Route a m
fb')   -> HashMap ByteString (Route a m) -> Route a m -> Route a m
forall a (m :: * -> *).
HashMap ByteString (Route a m) -> Route a m -> Route a m
Dir ((Route a m -> Route a m -> Route a m)
-> HashMap ByteString (Route a m)
-> HashMap ByteString (Route a m)
-> HashMap ByteString (Route a m)
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v
H.unionWith Route a m -> Route a m -> Route a m
forall a. Semigroup a => a -> a -> a
(<>) HashMap ByteString (Route a m)
rm HashMap ByteString (Route a m)
rm') (Route a m
fb Route a m -> Route a m -> Route a m
forall a. Semigroup a => a -> a -> a
<> Route a m
fb')
      Route a m
NoRoute         -> Route a m
l

instance Monoid (Route a m) where
    mempty :: Route a m
mempty = Route a m
forall a (m :: * -> *). Route a m
NoRoute
    mappend :: Route a m -> Route a m -> Route a m
mappend = Route a m -> Route a m -> Route a m
forall a. Semigroup a => a -> a -> a
(<>)

------------------------------------------------------------------------------
routeHeight :: Route a m -> Int
routeHeight :: Route a m -> Int
routeHeight Route a m
r = case Route a m
r of
  Route a m
NoRoute          -> Int
1
  (Action MonadSnap m => m a
_)       -> Int
1
  (Capture ByteString
_ Route a m
r' Route a m
_) -> Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Route a m -> Int
forall a (m :: * -> *). Route a m -> Int
routeHeight Route a m
r'
  (Dir HashMap ByteString (Route a m)
rm Route a m
_)       -> Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int -> Int -> Int) -> Int -> [Int] -> Int
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 ((Route a m -> Int) -> [Route a m] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Route a m -> Int
forall a (m :: * -> *). Route a m -> Int
routeHeight ([Route a m] -> [Int]) -> [Route a m] -> [Int]
forall a b. (a -> b) -> a -> b
$ HashMap ByteString (Route a m) -> [Route a m]
forall k v. HashMap k v -> [v]
H.elems HashMap ByteString (Route a m)
rm)
{-# INLINE routeHeight #-}


------------------------------------------------------------------------------
routeEarliestNC :: Route a m -> Int -> Int
routeEarliestNC :: Route a m -> Int -> Int
routeEarliestNC Route a m
r Int
n = case Route a m
r of
  Route a m
NoRoute           -> Int
n
  (Action MonadSnap m => m a
_)        -> Int
n
  (Capture ByteString
_ Route a m
r' Route a m
_)  -> Route a m -> Int -> Int
forall a (m :: * -> *). Route a m -> Int -> Int
routeEarliestNC Route a m
r' Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1
  (Dir HashMap ByteString (Route a m)
_ Route a m
_)         -> Int
n
{-# INLINE routeEarliestNC #-}


------------------------------------------------------------------------------
-- | A web handler which, given a mapping from URL entry points to web
-- handlers, efficiently routes requests to the correct handler.
--
--
-- __Usage__
--
-- The URL entry points are given as relative paths, for example:
--
-- > route [ ("foo/bar/quux", fooBarQuux) ]
--
-- If the URI of the incoming request is @\/foo\/bar\/quux@ or
-- @\/foo\/bar\/quux\/...anything...@ then the request will be routed to
-- @\"fooBarQuux\"@, with 'rqContextPath' set to @\"\/foo\/bar\/quux\/\"@ and
-- 'rqPathInfo' set to @\"...anything...\"@.
--
-- A path component within an URL entry point beginning with a colon (@\":\"@)
-- is treated as a /variable capture/; the corresponding path component within
-- the request URI will be entered into the 'rqParams' parameters mapping with
-- the given name. For instance, if the routes were:
--
-- > route [ ("foo/:bar/baz", fooBazHandler) ]
--
-- Then a request for @\"\/foo\/saskatchewan\/baz\"@ would be routed to
-- @fooBazHandler@ with a mapping for @\"bar\" => \"saskatchewan\"@ in its
-- parameters table.
--
-- Longer paths are matched first, and specific routes are matched before
-- captures. That is, if given routes:
--
-- > [ ("a", h1), ("a/b", h2), ("a/:x", h3) ]
--
-- a request for @\"\/a\/b\"@ will go to @h2@, @\"\/a\/s\"@ for any /s/ will go
-- to @h3@, and @\"\/a\"@ will go to @h1@.
--
-- The following example matches @\"\/article\"@ to an article index,
-- @\"\/login\"@ to a login, and @\"\/article\/...\"@ to an article renderer.
--
-- @
-- 'route' [ (\"article\",     renderIndex)
--       , (\"article\/:id\", renderArticle)
--       , (\"login\",       'Snap.Core.method' POST doLogin) ]
-- @
--
-- __Note: URL decoding__
--
-- A short note about URL decoding: path matching and variable capture are done
-- on /decoded/ URLs, but the contents of 'rqContextPath' and 'rqPathInfo' will
-- contain the original encoded URL, i.e. what the user entered. For example,
-- in the following scenario:
--
-- > route [ ("a b c d/", foo ) ]
--
-- A request for \"@/a+b+c+d@\" will be sent to @foo@ with 'rqContextPath' set
-- to @\"/a+b+c+d/\"@.
--
-- This behaviour changed as of Snap 0.6.1; previous versions had unspecified
-- (and buggy!) semantics here.
--
--
-- __Example:__
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as Map
-- ghci> import qualified "Data.ByteString.Char8" as B8
-- ghci> import "Snap.Test"
-- ghci> :{
-- ghci| let handler = do r \<- 'getRequest'
-- ghci|                  'Snap.Core.writeBS' $ \"rqContextPath: \" \<> 'rqContextPath' r \<> \"\\n\"
-- ghci|                  'Snap.Core.writeBS' $ \"rqPathInfo: \" \<> 'rqPathInfo' r \<> \"\\n\"
-- ghci|                  'Snap.Core.writeBS' $ \"rqParams: \" \<> (B8.pack . show $ 'rqParams' r)
-- ghci| :}
-- ghci> 'Snap.Test.runHandler' ('Snap.Test.get' \"\/foo\/bar\" "Map.empty") ('route' [(\"foo\", handler)])
-- HTTP\/1.1 200 OK
-- server: Snap\/test
-- date: Sat, 02 Aug 2014 05:16:59 GMT
--
-- rqContextPath: \/foo\/
-- rqPathInfo: bar
-- rqParams: fromList []
-- ghci> 'Snap.Test.runHandler' ('Snap.Test.get' \"\/foo\/bar\" "Map.empty") ('route' [(\"foo\/:bar\", handler)])
-- [...]
--
-- rqContextPath: \/foo\/bar\/
-- rqPathInfo:
-- rqParams: fromList [(\"bar\",[\"bar\"])]
-- @
route :: MonadSnap m => [(ByteString, m a)] -> m a
route :: [(ByteString, m a)] -> m a
route [(ByteString, m a)]
rts = do
  ByteString
p <- (Request -> ByteString) -> m ByteString
forall (m :: * -> *) a. MonadSnap m => (Request -> a) -> m a
getsRequest Request -> ByteString
rqPathInfo
  m () -> [ByteString] -> [ByteString] -> Params -> Route a m -> m a
forall (m :: * -> *) a.
MonadSnap m =>
m () -> [ByteString] -> [ByteString] -> Params -> Route a m -> m a
route' (() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> m ()) -> () -> m ()
forall a b. (a -> b) -> a -> b
$! ()) [] (ByteString -> [ByteString]
splitPath ByteString
p) Params
forall k a. Map k a
Map.empty Route a m
rts'
  where
    rts' :: Route a m
rts' = [Route a m] -> Route a m
forall a. Monoid a => [a] -> a
mconcat (((ByteString, m a) -> Route a m)
-> [(ByteString, m a)] -> [Route a m]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString, m a) -> Route a m
forall (m :: * -> *) a.
MonadSnap m =>
(ByteString, m a) -> Route a m
pRoute [(ByteString, m a)]
rts)
{-# INLINE route #-}


------------------------------------------------------------------------------
-- | The 'routeLocal' function is the same as 'route', except it doesn't
-- change the request's context path. This is useful if you want to route to a
-- particular handler but you want that handler to receive the 'rqPathInfo' as
-- it is.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> import qualified "Data.ByteString.Char8" as B8
-- ghci> import "Snap.Test"
-- ghci> :{
-- ghci| let handler = do r \<- 'getRequest'
-- ghci|                  'Snap.Core.writeBS' $ \"rqContextPath: \" \<> 'rqContextPath' r \<> \"\\n\"
-- ghci|                  'Snap.Core.writeBS' $ \"rqPathInfo: \" \<> 'rqPathInfo' r \<> \"\\n\"
-- ghci|                  'Snap.Core.writeBS' $ \"rqParams: \" \<> (B8.pack . show $ 'rqParams' r)
-- ghci| :}
-- ghci> 'Snap.Test.runHandler' ('Snap.Test.get' \"\/foo\/bar\" M.empty) ('routeLocal' [(\"foo\", handler)])
-- HTTP\/1.1 200 OK
-- server: Snap\/test
-- date: Sat, 02 Aug 2014 05:17:28 GMT
--
-- rqContextPath: \/
-- rqPathInfo: foo\/bar
-- ghci> 'Snap.Test.runHandler' ('Snap.Test.get' \"\/foo\/bar\" M.empty) ('routeLocal' [(\"foo\/:bar\", handler)])
-- [...]
--
-- rqContextPath: \/
-- rqPathInfo: foo\/bar
-- rqParams: fromList [(\"bar\",[\"bar\"])]
-- @
routeLocal :: MonadSnap m => [(ByteString, m a)] -> m a
routeLocal :: [(ByteString, m a)] -> m a
routeLocal [(ByteString, m a)]
rts = do
    Request
req    <- m Request
forall (m :: * -> *). MonadSnap m => m Request
getRequest
    let ctx :: ByteString
ctx = Request -> ByteString
rqContextPath Request
req
    let p :: ByteString
p   = Request -> ByteString
rqPathInfo Request
req
    let md :: m ()
md  = (Request -> Request) -> m ()
forall (m :: * -> *). MonadSnap m => (Request -> Request) -> m ()
modifyRequest ((Request -> Request) -> m ()) -> (Request -> Request) -> m ()
forall a b. (a -> b) -> a -> b
$ \Request
r -> Request
r {rqContextPath :: ByteString
rqContextPath=ByteString
ctx, rqPathInfo :: ByteString
rqPathInfo=ByteString
p}

    (m () -> [ByteString] -> [ByteString] -> Params -> Route a m -> m a
forall (m :: * -> *) a.
MonadSnap m =>
m () -> [ByteString] -> [ByteString] -> Params -> Route a m -> m a
route' m ()
md [] (ByteString -> [ByteString]
splitPath ByteString
p) Params
forall k a. Map k a
Map.empty Route a m
rts') m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (m ()
md m () -> m a -> m a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m a
forall (m :: * -> *) a. MonadSnap m => m a
pass)

  where
    rts' :: Route a m
rts' = [Route a m] -> Route a m
forall a. Monoid a => [a] -> a
mconcat (((ByteString, m a) -> Route a m)
-> [(ByteString, m a)] -> [Route a m]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString, m a) -> Route a m
forall (m :: * -> *) a.
MonadSnap m =>
(ByteString, m a) -> Route a m
pRoute [(ByteString, m a)]
rts)
{-# INLINE routeLocal #-}


------------------------------------------------------------------------------
splitPath :: ByteString -> [ByteString]
splitPath :: ByteString -> [ByteString]
splitPath = (Word8 -> Bool) -> ByteString -> [ByteString]
B.splitWith (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== (Char -> Word8
c2w Char
'/'))
{-# INLINE splitPath #-}


------------------------------------------------------------------------------
pRoute :: MonadSnap m => (ByteString, m a) -> Route a m
pRoute :: (ByteString, m a) -> Route a m
pRoute (ByteString
r, m a
a) = (ByteString -> Route a m -> Route a m)
-> Route a m -> [ByteString] -> Route a m
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ByteString -> Route a m -> Route a m
forall a (m :: * -> *). ByteString -> Route a m -> Route a m
f ((MonadSnap m => m a) -> Route a m
forall a (m :: * -> *). (MonadSnap m => m a) -> Route a m
Action m a
MonadSnap m => m a
a) [ByteString]
hier
  where
    hier :: [ByteString]
hier   = (ByteString -> Bool) -> [ByteString] -> [ByteString]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (ByteString -> Bool) -> ByteString -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Bool
B.null) ([ByteString] -> [ByteString]) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> a -> b
$ (Word8 -> Bool) -> ByteString -> [ByteString]
B.splitWith (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== (Char -> Word8
c2w Char
'/')) ByteString
r
    f :: ByteString -> Route a m -> Route a m
f ByteString
s Route a m
rt = if ByteString -> Word8
B.head ByteString
s Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> Word8
c2w Char
':'
        then ByteString -> Route a m -> Route a m -> Route a m
forall a (m :: * -> *).
ByteString -> Route a m -> Route a m -> Route a m
Capture (ByteString -> ByteString
B.tail ByteString
s) Route a m
rt Route a m
forall a (m :: * -> *). Route a m
NoRoute
        else HashMap ByteString (Route a m) -> Route a m -> Route a m
forall a (m :: * -> *).
HashMap ByteString (Route a m) -> Route a m -> Route a m
Dir ([(ByteString, Route a m)] -> HashMap ByteString (Route a m)
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
H.fromList [(ByteString
s, Route a m
rt)]) Route a m
forall a (m :: * -> *). Route a m
NoRoute
{-# INLINE pRoute #-}


------------------------------------------------------------------------------
route' :: MonadSnap m
       => m ()           -- ^ action to run before we call the user handler
       -> [ByteString]   -- ^ the \"context\"; the list of path segments we've
                         -- already successfully matched, in reverse order
       -> [ByteString]   -- ^ the list of path segments we haven't yet matched
       -> Params
       -> Route a m
       -> m a
route' :: m () -> [ByteString] -> [ByteString] -> Params -> Route a m -> m a
route' m ()
pre ![ByteString]
ctx [ByteString]
_ !Params
params (Action MonadSnap m => m a
action) =
    (Request -> Request) -> m a -> m a
forall (m :: * -> *) a.
MonadSnap m =>
(Request -> Request) -> m a -> m a
localRequest (Int -> Request -> Request
updateContextPath (ByteString -> Int
B.length ByteString
ctx') (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Request
updateParams)
                 (m ()
pre m () -> m a -> m a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m a
MonadSnap m => m a
action)
  where
    ctx' :: ByteString
ctx' = ByteString -> [ByteString] -> ByteString
B.intercalate ([Word8] -> ByteString
B.pack [Char -> Word8
c2w Char
'/']) ([ByteString] -> [ByteString]
forall a. [a] -> [a]
reverse [ByteString]
ctx)
    updateParams :: Request -> Request
updateParams Request
req = Request
req
      { rqParams :: Params
rqParams = ([ByteString] -> [ByteString] -> [ByteString])
-> Params -> Params -> Params
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith (([ByteString] -> [ByteString] -> [ByteString])
-> [ByteString] -> [ByteString] -> [ByteString]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
(++)) Params
params (Request -> Params
rqParams Request
req) }

route' m ()
pre ![ByteString]
ctx [] !Params
params (Capture ByteString
_ Route a m
_  Route a m
fb) =
    m () -> [ByteString] -> [ByteString] -> Params -> Route a m -> m a
forall (m :: * -> *) a.
MonadSnap m =>
m () -> [ByteString] -> [ByteString] -> Params -> Route a m -> m a
route' m ()
pre [ByteString]
ctx [] Params
params Route a m
fb

route' m ()
pre ![ByteString]
ctx paths :: [ByteString]
paths@(ByteString
cwd:[ByteString]
rest) !Params
params (Capture ByteString
p Route a m
rt Route a m
fb)
    | ByteString -> Bool
B.null ByteString
cwd = m a
fallback
    | Bool
otherwise  = m a
m m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m a
fallback
  where
    fallback :: m a
fallback = m () -> [ByteString] -> [ByteString] -> Params -> Route a m -> m a
forall (m :: * -> *) a.
MonadSnap m =>
m () -> [ByteString] -> [ByteString] -> Params -> Route a m -> m a
route' m ()
pre [ByteString]
ctx [ByteString]
paths Params
params Route a m
fb
    m :: m a
m = m a -> (ByteString -> m a) -> Maybe ByteString -> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m a
forall (m :: * -> *) a. MonadSnap m => m a
pass
              (\ByteString
cwd' -> let params' :: Params
params' = ([ByteString] -> [ByteString] -> [ByteString])
-> ByteString -> [ByteString] -> Params -> Params
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith (([ByteString] -> [ByteString] -> [ByteString])
-> [ByteString] -> [ByteString] -> [ByteString]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
(++)) ByteString
p [ByteString
cwd'] Params
params
                        in m () -> [ByteString] -> [ByteString] -> Params -> Route a m -> m a
forall (m :: * -> *) a.
MonadSnap m =>
m () -> [ByteString] -> [ByteString] -> Params -> Route a m -> m a
route' m ()
pre (ByteString
cwdByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:[ByteString]
ctx) [ByteString]
rest Params
params' Route a m
rt)
              (ByteString -> Maybe ByteString
urlDecode ByteString
cwd)

route' m ()
pre ![ByteString]
ctx [] !Params
params (Dir HashMap ByteString (Route a m)
_ Route a m
fb) =
    m () -> [ByteString] -> [ByteString] -> Params -> Route a m -> m a
forall (m :: * -> *) a.
MonadSnap m =>
m () -> [ByteString] -> [ByteString] -> Params -> Route a m -> m a
route' m ()
pre [ByteString]
ctx [] Params
params Route a m
fb
route' m ()
pre ![ByteString]
ctx paths :: [ByteString]
paths@(ByteString
cwd:[ByteString]
rest) !Params
params (Dir HashMap ByteString (Route a m)
rtm Route a m
fb) = do
    ByteString
cwd' <- m ByteString
-> (ByteString -> m ByteString) -> Maybe ByteString -> m ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m ByteString
forall (m :: * -> *) a. MonadSnap m => m a
pass ByteString -> m ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString -> m ByteString)
-> Maybe ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString
urlDecode ByteString
cwd
    case ByteString -> HashMap ByteString (Route a m) -> Maybe (Route a m)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup ByteString
cwd' HashMap ByteString (Route a m)
rtm of
      Just Route a m
rt -> (m () -> [ByteString] -> [ByteString] -> Params -> Route a m -> m a
forall (m :: * -> *) a.
MonadSnap m =>
m () -> [ByteString] -> [ByteString] -> Params -> Route a m -> m a
route' m ()
pre (ByteString
cwdByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:[ByteString]
ctx) [ByteString]
rest Params
params Route a m
rt) m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
                 (m () -> [ByteString] -> [ByteString] -> Params -> Route a m -> m a
forall (m :: * -> *) a.
MonadSnap m =>
m () -> [ByteString] -> [ByteString] -> Params -> Route a m -> m a
route' m ()
pre [ByteString]
ctx [ByteString]
paths Params
params Route a m
fb)
      Maybe (Route a m)
Nothing -> m () -> [ByteString] -> [ByteString] -> Params -> Route a m -> m a
forall (m :: * -> *) a.
MonadSnap m =>
m () -> [ByteString] -> [ByteString] -> Params -> Route a m -> m a
route' m ()
pre [ByteString]
ctx [ByteString]
paths Params
params Route a m
fb

route' m ()
_ [ByteString]
_ [ByteString]
_ Params
_ Route a m
NoRoute = m a
forall (m :: * -> *) a. MonadSnap m => m a
pass