{-# 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 (..))
data Route a m = Action ((MonadSnap m) => m a)
| Capture ByteString (Route a m) (Route a m)
| 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') -> forall a (m :: * -> *). (MonadSnap m => m a) -> Route a m
Action (MonadSnap m => m a
a forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> MonadSnap m => m a
a')
(Capture ByteString
p Route a m
r' Route a m
fb) -> forall a (m :: * -> *).
ByteString -> Route a m -> Route a m -> Route a m
Capture ByteString
p Route a m
r' (Route a m
fb forall a. Semigroup a => a -> a -> a
<> Route a m
l)
(Dir HashMap ByteString (Route a m)
_ Route a m
_) -> forall a (m :: * -> *).
HashMap ByteString (Route a m) -> Route a m -> Route a m
Dir forall k v. HashMap k v
H.empty Route a m
l forall a. Semigroup a => a -> a -> a
<> Route a m
r
Route a m
NoRoute -> Route a m
l
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
_) -> forall a (m :: * -> *).
ByteString -> Route a m -> Route a m -> Route a m
Capture ByteString
p Route a m
r' (Route a m
fb forall a. Semigroup a => a -> a -> a
<> Route a m
r)
(Capture ByteString
p' Route a m
r'' Route a m
fb')
| ByteString
p forall a. Eq a => a -> a -> Bool
== ByteString
p' -> forall a (m :: * -> *).
ByteString -> Route a m -> Route a m -> Route a m
Capture ByteString
p (Route a m
r' forall a. Semigroup a => a -> a -> a
<> Route a m
r'') (Route a m
fb forall a. Semigroup a => a -> a -> a
<> Route a m
fb')
| Int
rh' forall a. Ord a => a -> a -> Bool
> Int
rh'' -> forall a (m :: * -> *).
ByteString -> Route a m -> Route a m -> Route a m
Capture ByteString
p Route a m
r' (Route a m
fb forall a. Semigroup a => a -> a -> a
<> Route a m
r)
| Int
rh' forall a. Ord a => a -> a -> Bool
< Int
rh'' -> forall a (m :: * -> *).
ByteString -> Route a m -> Route a m -> Route a m
Capture ByteString
p' Route a m
r'' (Route a m
fb' forall a. Semigroup a => a -> a -> a
<> Route a m
l)
| Int
en' forall a. Ord a => a -> a -> Bool
< Int
en'' -> forall a (m :: * -> *).
ByteString -> Route a m -> Route a m -> Route a m
Capture ByteString
p Route a m
r' (Route a m
fb forall a. Semigroup a => a -> a -> a
<> Route a m
r)
| Bool
otherwise -> forall a (m :: * -> *).
ByteString -> Route a m -> Route a m -> Route a m
Capture ByteString
p' Route a m
r'' (Route a m
fb' forall a. Semigroup a => a -> a -> a
<> Route a m
l)
where
rh' :: Int
rh' = forall a (m :: * -> *). Route a m -> Int
routeHeight Route a m
r'
rh'' :: Int
rh'' = forall a (m :: * -> *). Route a m -> Int
routeHeight Route a m
r''
en' :: Int
en' = forall a (m :: * -> *). Route a m -> Int -> Int
routeEarliestNC Route a m
r' Int
1
en'' :: Int
en'' = 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') -> 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' 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
_) -> 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 forall a. Semigroup a => a -> a -> a
<> Route a m
r)
(Capture ByteString
_ 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 forall a. Semigroup a => a -> a -> a
<> Route a m
r)
(Dir HashMap ByteString (Route a m)
rm' Route a m
fb') -> forall a (m :: * -> *).
HashMap ByteString (Route a m) -> Route a m -> Route a m
Dir (forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v
H.unionWith forall a. Semigroup a => a -> a -> a
(<>) HashMap ByteString (Route a m)
rm HashMap ByteString (Route a m)
rm') (Route a m
fb 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 = forall a (m :: * -> *). Route a m
NoRoute
mappend :: Route a m -> Route a m -> Route a m
mappend = forall a. Semigroup a => a -> a -> a
(<>)
routeHeight :: Route a m -> Int
routeHeight :: forall a (m :: * -> *). 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 forall a. Num a => a -> a -> a
+ forall a (m :: * -> *). Route a m -> Int
routeHeight Route a m
r'
(Dir HashMap ByteString (Route a m)
rm Route a m
_) -> Int
1 forall a. Num a => a -> a -> a
+ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall a. Ord a => a -> a -> a
max Int
1 (forall a b. (a -> b) -> [a] -> [b]
map forall a (m :: * -> *). Route a m -> Int
routeHeight forall a b. (a -> b) -> a -> b
$ forall k v. HashMap k v -> [v]
H.elems HashMap ByteString (Route a m)
rm)
{-# INLINE routeHeight #-}
routeEarliestNC :: Route a m -> Int -> Int
routeEarliestNC :: forall a (m :: * -> *). 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
_) -> forall a (m :: * -> *). Route a m -> Int -> Int
routeEarliestNC Route a m
r' Int
nforall a. Num a => a -> a -> a
+Int
1
(Dir HashMap ByteString (Route a m)
_ Route a m
_) -> Int
n
{-# INLINE routeEarliestNC #-}
route :: MonadSnap m => [(ByteString, m a)] -> m a
route :: forall (m :: * -> *) a. MonadSnap m => [(ByteString, m a)] -> m a
route [(ByteString, m a)]
rts = do
ByteString
p <- forall (m :: * -> *) a. MonadSnap m => (Request -> a) -> m a
getsRequest Request -> ByteString
rqPathInfo
forall (m :: * -> *) a.
MonadSnap m =>
m () -> [ByteString] -> [ByteString] -> Params -> Route a m -> m a
route' (forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! ()) [] (ByteString -> [ByteString]
splitPath ByteString
p) forall k a. Map k a
Map.empty Route a m
rts'
where
rts' :: Route a m
rts' = forall a. Monoid a => [a] -> a
mconcat (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *) a.
MonadSnap m =>
(ByteString, m a) -> Route a m
pRoute [(ByteString, m a)]
rts)
{-# INLINE route #-}
routeLocal :: MonadSnap m => [(ByteString, m a)] -> m a
routeLocal :: forall (m :: * -> *) a. MonadSnap m => [(ByteString, m a)] -> m a
routeLocal [(ByteString, m a)]
rts = do
Request
req <- 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 = forall (m :: * -> *). MonadSnap m => (Request -> Request) -> m ()
modifyRequest forall a b. (a -> b) -> a -> b
$ \Request
r -> Request
r {rqContextPath :: ByteString
rqContextPath=ByteString
ctx, rqPathInfo :: ByteString
rqPathInfo=ByteString
p}
(forall (m :: * -> *) a.
MonadSnap m =>
m () -> [ByteString] -> [ByteString] -> Params -> Route a m -> m a
route' m ()
md [] (ByteString -> [ByteString]
splitPath ByteString
p) forall k a. Map k a
Map.empty Route a m
rts') forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (m ()
md forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. MonadSnap m => m a
pass)
where
rts' :: Route a m
rts' = forall a. Monoid a => [a] -> a
mconcat (forall a b. (a -> b) -> [a] -> [b]
map 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 (forall a. Eq a => a -> a -> Bool
== (Char -> Word8
c2w Char
'/'))
{-# INLINE splitPath #-}
pRoute :: MonadSnap m => (ByteString, m a) -> Route a m
pRoute :: forall (m :: * -> *) a.
MonadSnap m =>
(ByteString, m a) -> Route a m
pRoute (ByteString
r, m a
a) = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {a} {m :: * -> *}. ByteString -> Route a m -> Route a m
f (forall a (m :: * -> *). (MonadSnap m => m a) -> Route a m
Action m a
a) [ByteString]
hier
where
hier :: [ByteString]
hier = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Bool
B.null) forall a b. (a -> b) -> a -> b
$ (Word8 -> Bool) -> ByteString -> [ByteString]
B.splitWith (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 HasCallStack => ByteString -> Word8
B.head ByteString
s forall a. Eq a => a -> a -> Bool
== Char -> Word8
c2w Char
':'
then forall a (m :: * -> *).
ByteString -> Route a m -> Route a m -> Route a m
Capture (HasCallStack => ByteString -> ByteString
B.tail ByteString
s) Route a m
rt forall a (m :: * -> *). Route a m
NoRoute
else forall a (m :: * -> *).
HashMap ByteString (Route a m) -> Route a m -> Route a m
Dir (forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
H.fromList [(ByteString
s, Route a m
rt)]) forall a (m :: * -> *). Route a m
NoRoute
{-# INLINE pRoute #-}
route' :: MonadSnap m
=> m ()
-> [ByteString]
-> [ByteString]
-> Params
-> Route a m
-> m a
route' :: forall (m :: * -> *) a.
MonadSnap m =>
m () -> [ByteString] -> [ByteString] -> Params -> Route a m -> m a
route' m ()
pre ![ByteString]
ctx [ByteString]
_ !Params
params (Action MonadSnap m => m a
action) =
forall (m :: * -> *) a.
MonadSnap m =>
(Request -> Request) -> m a -> m a
localRequest (Int -> Request -> Request
updateContextPath (ByteString -> Int
B.length ByteString
ctx') forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Request
updateParams)
(m ()
pre forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MonadSnap m => m a
action)
where
ctx' :: ByteString
ctx' = ByteString -> [ByteString] -> ByteString
B.intercalate ([Word8] -> ByteString
B.pack [Char -> Word8
c2w Char
'/']) (forall a. [a] -> [a]
reverse [ByteString]
ctx)
updateParams :: Request -> Request
updateParams Request
req = Request
req
{ rqParams :: Params
rqParams = forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith (forall a b c. (a -> b -> c) -> b -> a -> c
flip 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) =
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 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m a
fallback
where
fallback :: m a
fallback = 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 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall (m :: * -> *) a. MonadSnap m => m a
pass
(\ByteString
cwd' -> let params' :: Params
params' = forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. [a] -> [a] -> [a]
(++)) ByteString
p [ByteString
cwd'] Params
params
in forall (m :: * -> *) a.
MonadSnap m =>
m () -> [ByteString] -> [ByteString] -> Params -> Route a m -> m a
route' m ()
pre (ByteString
cwdforall 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) =
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' <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall (m :: * -> *) a. MonadSnap m => m a
pass forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString
urlDecode ByteString
cwd
case 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 -> (forall (m :: * -> *) a.
MonadSnap m =>
m () -> [ByteString] -> [ByteString] -> Params -> Route a m -> m a
route' m ()
pre (ByteString
cwdforall a. a -> [a] -> [a]
:[ByteString]
ctx) [ByteString]
rest Params
params Route a m
rt) forall (f :: * -> *) a. Alternative f => f a -> f a -> f 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 -> 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 = forall (m :: * -> *) a. MonadSnap m => m a
pass