-- This Source Code Form is subject to the terms of the Mozilla Public
-- License, v. 2.0. If a copy of the MPL was not distributed with this
-- file, You can obtain one at http://mozilla.org/MPL/2.0/.

module Network.Wai.Route.Tree
    ( -- * Routing Tree
      Tree
    , fromList
    , lookup
    , foldTree
    , mapTree
    , toList
    , segments

      -- ** Tree leaf payload
    , Payload
    , value
    , path
    , captures

      -- ** Captures
    , Captures
    , captured
    , captureParams
    , captureValues
    ) where

import Control.Applicative
import Data.ByteString (ByteString)
import Data.List (foldl')
import Data.HashMap.Strict (HashMap)
import Data.Maybe (fromMaybe)
import Data.Semigroup
import Data.Word
import Network.HTTP.Types (urlDecode, urlEncode)
import Prelude hiding (lookup)

import qualified Data.ByteString     as B
import qualified Data.HashMap.Strict as M

data Tree a = Tree
    { forall a. Tree a -> HashMap ByteString (Tree a)
subtree :: HashMap ByteString (Tree a)
    , forall a. Tree a -> Maybe (Tree a)
capture :: Maybe (Tree a)
    , forall a. Tree a -> Maybe (Payload a)
payload :: Maybe (Payload a)
    } deriving (Tree a -> Tree a -> Bool
(Tree a -> Tree a -> Bool)
-> (Tree a -> Tree a -> Bool) -> Eq (Tree a)
forall a. Eq a => Tree a -> Tree a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Tree a -> Tree a -> Bool
== :: Tree a -> Tree a -> Bool
$c/= :: forall a. Eq a => Tree a -> Tree a -> Bool
/= :: Tree a -> Tree a -> Bool
Eq, Int -> Tree a -> ShowS
[Tree a] -> ShowS
Tree a -> String
(Int -> Tree a -> ShowS)
-> (Tree a -> String) -> ([Tree a] -> ShowS) -> Show (Tree a)
forall a. Show a => Int -> Tree a -> ShowS
forall a. Show a => [Tree a] -> ShowS
forall a. Show a => Tree a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Tree a -> ShowS
showsPrec :: Int -> Tree a -> ShowS
$cshow :: forall a. Show a => Tree a -> String
show :: Tree a -> String
$cshowList :: forall a. Show a => [Tree a] -> ShowS
showList :: [Tree a] -> ShowS
Show)

data Payload a = Payload
    { forall a. Payload a -> ByteString
path     :: !ByteString
    , forall a. Payload a -> a
value    :: !a
    , forall a. Payload a -> Captures
captures :: !Captures
    } deriving (Payload a -> Payload a -> Bool
(Payload a -> Payload a -> Bool)
-> (Payload a -> Payload a -> Bool) -> Eq (Payload a)
forall a. Eq a => Payload a -> Payload a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Payload a -> Payload a -> Bool
== :: Payload a -> Payload a -> Bool
$c/= :: forall a. Eq a => Payload a -> Payload a -> Bool
/= :: Payload a -> Payload a -> Bool
Eq, Int -> Payload a -> ShowS
[Payload a] -> ShowS
Payload a -> String
(Int -> Payload a -> ShowS)
-> (Payload a -> String)
-> ([Payload a] -> ShowS)
-> Show (Payload a)
forall a. Show a => Int -> Payload a -> ShowS
forall a. Show a => [Payload a] -> ShowS
forall a. Show a => Payload a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Payload a -> ShowS
showsPrec :: Int -> Payload a -> ShowS
$cshow :: forall a. Show a => Payload a -> String
show :: Payload a -> String
$cshowList :: forall a. Show a => [Payload a] -> ShowS
showList :: [Payload a] -> ShowS
Show)

data Captures = Captures
    { Captures -> [ByteString]
params :: [ByteString]
    , Captures -> [ByteString]
values :: [ByteString]
    } deriving (Captures -> Captures -> Bool
(Captures -> Captures -> Bool)
-> (Captures -> Captures -> Bool) -> Eq Captures
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Captures -> Captures -> Bool
== :: Captures -> Captures -> Bool
$c/= :: Captures -> Captures -> Bool
/= :: Captures -> Captures -> Bool
Eq, Int -> Captures -> ShowS
[Captures] -> ShowS
Captures -> String
(Int -> Captures -> ShowS)
-> (Captures -> String) -> ([Captures] -> ShowS) -> Show Captures
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Captures -> ShowS
showsPrec :: Int -> Captures -> ShowS
$cshow :: Captures -> String
show :: Captures -> String
$cshowList :: [Captures] -> ShowS
showList :: [Captures] -> ShowS
Show)

instance Semigroup (Tree a) where
    Tree a
a <> :: Tree a -> Tree a -> Tree a
<> Tree a
b =  HashMap ByteString (Tree a)
-> Maybe (Tree a) -> Maybe (Payload a) -> Tree a
forall a.
HashMap ByteString (Tree a)
-> Maybe (Tree a) -> Maybe (Payload a) -> Tree a
Tree (Tree a -> HashMap ByteString (Tree a)
forall a. Tree a -> HashMap ByteString (Tree a)
subtree Tree a
a HashMap ByteString (Tree a)
-> HashMap ByteString (Tree a) -> HashMap ByteString (Tree a)
forall a. Semigroup a => a -> a -> a
<> Tree a -> HashMap ByteString (Tree a)
forall a. Tree a -> HashMap ByteString (Tree a)
subtree Tree a
b)
                   (Tree a -> Maybe (Tree a)
forall a. Tree a -> Maybe (Tree a)
capture Tree a
a Maybe (Tree a) -> Maybe (Tree a) -> Maybe (Tree a)
forall a. Semigroup a => a -> a -> a
<> Tree a -> Maybe (Tree a)
forall a. Tree a -> Maybe (Tree a)
capture Tree a
b)
                   (Tree a -> Maybe (Payload a)
forall a. Tree a -> Maybe (Payload a)
payload Tree a
a Maybe (Payload a) -> Maybe (Payload a) -> Maybe (Payload a)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Tree a -> Maybe (Payload a)
forall a. Tree a -> Maybe (Payload a)
payload Tree a
b)

instance Monoid (Tree a) where
    mempty :: Tree a
mempty  = HashMap ByteString (Tree a)
-> Maybe (Tree a) -> Maybe (Payload a) -> Tree a
forall a.
HashMap ByteString (Tree a)
-> Maybe (Tree a) -> Maybe (Payload a) -> Tree a
Tree HashMap ByteString (Tree a)
forall a. Monoid a => a
mempty Maybe (Tree a)
forall a. Maybe a
Nothing Maybe (Payload a)
forall a. Maybe a
Nothing
    mappend :: Tree a -> Tree a -> Tree a
mappend = Tree a -> Tree a -> Tree a
forall a. Semigroup a => a -> a -> a
(<>)

captureParams :: Captures -> [ByteString]
captureParams :: Captures -> [ByteString]
captureParams = Captures -> [ByteString]
params

captureValues :: Captures -> [ByteString]
captureValues :: Captures -> [ByteString]
captureValues = Captures -> [ByteString]
values

captured :: Captures -> [(ByteString, ByteString)]
captured :: Captures -> [(ByteString, ByteString)]
captured (Captures [ByteString]
a [ByteString]
b) = [ByteString] -> [ByteString] -> [(ByteString, ByteString)]
forall a b. [a] -> [b] -> [(a, b)]
zip [ByteString]
a [ByteString]
b

fromList :: [(ByteString, a)] -> Tree a
fromList :: forall a. [(ByteString, a)] -> Tree a
fromList = (Tree a -> (ByteString, a) -> Tree a)
-> Tree a -> [(ByteString, a)] -> Tree a
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Tree a -> (ByteString, a) -> Tree a
forall {b}. Tree b -> (ByteString, b) -> Tree b
addRoute Tree a
forall a. Monoid a => a
mempty
  where
    addRoute :: Tree b -> (ByteString, b) -> Tree b
addRoute Tree b
t (ByteString
p,b
a) = Tree b -> [ByteString] -> [ByteString] -> Tree b
go Tree b
t (ByteString -> [ByteString]
segments ByteString
p) []
      where
        go :: Tree b -> [ByteString] -> [ByteString] -> Tree b
go Tree b
n [] [ByteString]
cs =
            let pa :: Payload b
pa = ByteString -> b -> Captures -> Payload b
forall a. ByteString -> a -> Captures -> Payload a
Payload ByteString
p b
a ([ByteString] -> [ByteString] -> Captures
Captures [ByteString]
cs [])
            in Tree b
n { payload = Just pa }

        go Tree b
n (ByteString
c:[ByteString]
ps) [ByteString]
cs | HasCallStack => ByteString -> Word8
ByteString -> Word8
B.head ByteString
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
colon =
            let b :: Tree b
b = Tree b -> Maybe (Tree b) -> Tree b
forall a. a -> Maybe a -> a
fromMaybe Tree b
forall a. Monoid a => a
mempty (Maybe (Tree b) -> Tree b) -> Maybe (Tree b) -> Tree b
forall a b. (a -> b) -> a -> b
$ Tree b -> Maybe (Tree b)
forall a. Tree a -> Maybe (Tree a)
capture Tree b
n
            in Tree b
n { capture = Just $! go b ps (B.tail c : cs) }

        go Tree b
n (ByteString
d:[ByteString]
ps) [ByteString]
cs =
            let d' :: ByteString
d' = Bool -> ByteString -> ByteString
urlEncode Bool
False ByteString
d
                b :: Tree b
b  = Tree b -> Maybe (Tree b) -> Tree b
forall a. a -> Maybe a -> a
fromMaybe Tree b
forall a. Monoid a => a
mempty (Maybe (Tree b) -> Tree b) -> Maybe (Tree b) -> Tree b
forall a b. (a -> b) -> a -> b
$ ByteString -> HashMap ByteString (Tree b) -> Maybe (Tree b)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup ByteString
d' (Tree b -> HashMap ByteString (Tree b)
forall a. Tree a -> HashMap ByteString (Tree a)
subtree Tree b
n)
            in Tree b
n { subtree = M.insert d' (go b ps cs) (subtree n) }

lookup :: Tree a -> [ByteString] -> Maybe (Payload a)
lookup :: forall a. Tree a -> [ByteString] -> Maybe (Payload a)
lookup Tree a
t [ByteString]
p = [ByteString] -> [ByteString] -> Tree a -> Maybe (Payload a)
forall {a}.
[ByteString] -> [ByteString] -> Tree a -> Maybe (Payload a)
go [ByteString]
p [] Tree a
t
  where
    go :: [ByteString] -> [ByteString] -> Tree a -> Maybe (Payload a)
go [] [ByteString]
cvs Tree a
n =
        let f :: Payload a -> Payload a
f Payload a
e = Payload a
e { captures = Captures (params (captures e)) cvs }
        in Payload a -> Payload a
forall {a}. Payload a -> Payload a
f (Payload a -> Payload a) -> Maybe (Payload a) -> Maybe (Payload a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tree a -> Maybe (Payload a)
forall a. Tree a -> Maybe (Payload a)
payload Tree a
n

    go (ByteString
s:[ByteString]
ss) [ByteString]
cvs Tree a
n =
        Maybe (Payload a)
-> (Tree a -> Maybe (Payload a))
-> Maybe (Tree a)
-> Maybe (Payload a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Tree a -> Maybe (Tree a)
forall a. Tree a -> Maybe (Tree a)
capture Tree a
n Maybe (Tree a)
-> (Tree a -> Maybe (Payload a)) -> Maybe (Payload a)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [ByteString] -> [ByteString] -> Tree a -> Maybe (Payload a)
go [ByteString]
ss (Bool -> ByteString -> ByteString
urlDecode Bool
False ByteString
s ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString]
cvs))
              ([ByteString] -> [ByteString] -> Tree a -> Maybe (Payload a)
go [ByteString]
ss [ByteString]
cvs)
              (ByteString -> HashMap ByteString (Tree a) -> Maybe (Tree a)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup ByteString
s (HashMap ByteString (Tree a) -> Maybe (Tree a))
-> HashMap ByteString (Tree a) -> Maybe (Tree a)
forall a b. (a -> b) -> a -> b
$ Tree a -> HashMap ByteString (Tree a)
forall a. Tree a -> HashMap ByteString (Tree a)
subtree Tree a
n)

foldTree :: (Payload a -> b -> b) -> b -> Tree a -> b
foldTree :: forall a b. (Payload a -> b -> b) -> b -> Tree a -> b
foldTree Payload a -> b -> b
f b
z (Tree HashMap ByteString (Tree a)
sub Maybe (Tree a)
cap Maybe (Payload a)
pay) =
    let a :: b
a = (b -> Tree a -> b) -> b -> HashMap ByteString (Tree a) -> b
forall a v k. (a -> v -> a) -> a -> HashMap k v -> a
M.foldl' ((Payload a -> b -> b) -> b -> Tree a -> b
forall a b. (Payload a -> b -> b) -> b -> Tree a -> b
foldTree Payload a -> b -> b
f) b
z HashMap ByteString (Tree a)
sub
        b :: b
b = b -> (Tree a -> b) -> Maybe (Tree a) -> b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe b
a ((Payload a -> b -> b) -> b -> Tree a -> b
forall a b. (Payload a -> b -> b) -> b -> Tree a -> b
foldTree Payload a -> b -> b
f b
a) Maybe (Tree a)
cap
        c :: b
c = b -> (Payload a -> b) -> Maybe (Payload a) -> b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe b
b ((Payload a -> b -> b) -> b -> Payload a -> b
forall a b c. (a -> b -> c) -> b -> a -> c
flip Payload a -> b -> b
f b
b) Maybe (Payload a)
pay
    in b
c

mapTree :: (Payload a -> Payload b) -> Tree a -> Tree b
mapTree :: forall a b. (Payload a -> Payload b) -> Tree a -> Tree b
mapTree Payload a -> Payload b
f Tree a
t = (Payload a -> Tree b -> Tree b) -> Tree b -> Tree a -> Tree b
forall a b. (Payload a -> b -> b) -> b -> Tree a -> b
foldTree Payload a -> Tree b -> Tree b
apply Tree b
forall a. Monoid a => a
mempty Tree a
t
  where
    apply :: Payload a -> Tree b -> Tree b
apply Payload a
x Tree b
tr = Tree b
tr { payload = Just (f x) }

toList :: Tree a -> [Payload a]
toList :: forall a. Tree a -> [Payload a]
toList = (Payload a -> [Payload a] -> [Payload a])
-> [Payload a] -> Tree a -> [Payload a]
forall a b. (Payload a -> b -> b) -> b -> Tree a -> b
foldTree (:) []

segments :: ByteString -> [ByteString]
segments :: ByteString -> [ByteString]
segments = (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]) -> ByteString -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> ByteString -> [ByteString]
B.split Word8
slash

slash, colon :: Word8
slash :: Word8
slash = Word8
0x2F
colon :: Word8
colon = Word8
0x3A
{-# INLINE slash #-}
{-# INLINE colon #-}