{-# LANGUAGE CPP                        #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# OPTIONS_HADDOCK hide                #-}

module Airship.Internal.Route
    ( RoutingSpec
    , Route
    , RouteLeaf
    , RoutedResource(..)
    , Trie
    , root
    , var
    , star
    , (</>)
    , (#>)
    , (#>=)
    , runRouter
    , route
    , routeText
    ) where

import           Airship.Resource           as Resource

import           Control.Monad.Writer.Class (MonadWriter, tell)
import qualified Data.ByteString            as B
import qualified Data.ByteString.Base64     as Base64
import qualified Data.ByteString.Char8      as BC8
import           Data.HashMap.Strict        (HashMap, fromList)
import qualified Data.List                  as L (foldl')
import           Data.Maybe                 (isNothing)
import           Data.Semigroup             (Semigroup, (<>))
import           Data.Monoid                (Monoid)
import           Data.Text                  (Text)
import qualified Data.Text                  as T (intercalate, cons)
import           Data.Text.Encoding         (encodeUtf8, decodeUtf8)
import           Data.Trie                  (Trie)
import qualified Data.Trie                  as Trie


#if __GLASGOW_HASKELL__ < 710
import           Control.Applicative
#endif
import           Control.Monad.Writer       (Writer, WriterT (..), execWriter)

import           Data.String                (IsString, fromString)

-- | 'Route's represent chunks of text used to match over URLs.
-- You match hardcoded paths with string literals (and the @-XOverloadedStrings@ extension),
-- named variables with the 'var' combinator, and wildcards with 'star'.
newtype Route = Route { Route -> [BoundOrUnbound]
getRoute :: [BoundOrUnbound] } deriving (Int -> Route -> ShowS
[Route] -> ShowS
Route -> String
(Int -> Route -> ShowS)
-> (Route -> String) -> ([Route] -> ShowS) -> Show Route
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Route] -> ShowS
$cshowList :: [Route] -> ShowS
show :: Route -> String
$cshow :: Route -> String
showsPrec :: Int -> Route -> ShowS
$cshowsPrec :: Int -> Route -> ShowS
Show, b -> Route -> Route
NonEmpty Route -> Route
Route -> Route -> Route
(Route -> Route -> Route)
-> (NonEmpty Route -> Route)
-> (forall b. Integral b => b -> Route -> Route)
-> Semigroup Route
forall b. Integral b => b -> Route -> Route
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: b -> Route -> Route
$cstimes :: forall b. Integral b => b -> Route -> Route
sconcat :: NonEmpty Route -> Route
$csconcat :: NonEmpty Route -> Route
<> :: Route -> Route -> Route
$c<> :: Route -> Route -> Route
Semigroup, Semigroup Route
Route
Semigroup Route
-> Route
-> (Route -> Route -> Route)
-> ([Route] -> Route)
-> Monoid Route
[Route] -> Route
Route -> Route -> Route
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [Route] -> Route
$cmconcat :: [Route] -> Route
mappend :: Route -> Route -> Route
$cmappend :: Route -> Route -> Route
mempty :: Route
$cmempty :: Route
$cp1Monoid :: Semigroup Route
Monoid)

routeText :: Route -> Text
routeText :: Route -> Text
routeText (Route [BoundOrUnbound]
parts) =
    Char -> Text -> Text
T.cons Char
'/' (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
"/" ((BoundOrUnbound -> Text
boundOrUnboundText (BoundOrUnbound -> Text) -> [BoundOrUnbound] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [BoundOrUnbound]
parts))

data BoundOrUnbound = Bound Text
                    | Var Text
                    | RestUnbound deriving (Int -> BoundOrUnbound -> ShowS
[BoundOrUnbound] -> ShowS
BoundOrUnbound -> String
(Int -> BoundOrUnbound -> ShowS)
-> (BoundOrUnbound -> String)
-> ([BoundOrUnbound] -> ShowS)
-> Show BoundOrUnbound
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BoundOrUnbound] -> ShowS
$cshowList :: [BoundOrUnbound] -> ShowS
show :: BoundOrUnbound -> String
$cshow :: BoundOrUnbound -> String
showsPrec :: Int -> BoundOrUnbound -> ShowS
$cshowsPrec :: Int -> BoundOrUnbound -> ShowS
Show)


boundOrUnboundText :: BoundOrUnbound -> Text
boundOrUnboundText :: BoundOrUnbound -> Text
boundOrUnboundText (Bound Text
t) = Text
t
boundOrUnboundText (Var Text
t) = Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t
boundOrUnboundText (BoundOrUnbound
RestUnbound) = Text
"*"




instance IsString Route where
    fromString :: String -> Route
fromString String
s = [BoundOrUnbound] -> Route
Route [Text -> BoundOrUnbound
Bound (String -> Text
forall a. IsString a => String -> a
fromString String
s)]


data RoutedResource m
    = RoutedResource Route (Resource m)


data RouteLeaf m = RouteMatch (RoutedResource m) [Text]
                 | RVar
                 | RouteMatchOrVar (RoutedResource m) [Text]
                 | Wildcard (RoutedResource m)


-- | Turns the list of routes in a 'RoutingSpec' into a 'Trie' for efficient
-- routing
runRouter :: RoutingSpec m a -> Trie (RouteLeaf m)
runRouter :: RoutingSpec m a -> Trie (RouteLeaf m)
runRouter RoutingSpec m a
routes = [(ByteString, RouteLeaf m)] -> Trie (RouteLeaf m)
forall (m :: * -> *).
[(ByteString, RouteLeaf m)] -> Trie (RouteLeaf m)
toTrie ([(ByteString, RouteLeaf m)] -> Trie (RouteLeaf m))
-> [(ByteString, RouteLeaf m)] -> Trie (RouteLeaf m)
forall a b. (a -> b) -> a -> b
$ Writer [(ByteString, RouteLeaf m)] a -> [(ByteString, RouteLeaf m)]
forall w a. Writer w a -> w
execWriter (RoutingSpec m a -> Writer [(ByteString, RouteLeaf m)] a
forall (m :: * -> *) a.
RoutingSpec m a -> Writer [(ByteString, RouteLeaf m)] a
getRouter RoutingSpec m a
routes)
    where
        -- Custom version of Trie.fromList that resolves key conflicts
        -- in the desired manner. In the case of duplicate routes the
        -- routes specified first are favored over any subsequent
        -- specifications.
        toTrie :: [(ByteString, RouteLeaf m)] -> Trie (RouteLeaf m)
toTrie = (Trie (RouteLeaf m)
 -> (ByteString, RouteLeaf m) -> Trie (RouteLeaf m))
-> Trie (RouteLeaf m)
-> [(ByteString, RouteLeaf m)]
-> Trie (RouteLeaf m)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl' Trie (RouteLeaf m)
-> (ByteString, RouteLeaf m) -> Trie (RouteLeaf m)
forall (m :: * -> *).
Trie (RouteLeaf m)
-> (ByteString, RouteLeaf m) -> Trie (RouteLeaf m)
insertOrReplace Trie (RouteLeaf m)
forall a. Trie a
Trie.empty
        insertOrReplace :: Trie (RouteLeaf m)
-> (ByteString, RouteLeaf m) -> Trie (RouteLeaf m)
insertOrReplace Trie (RouteLeaf m)
t (ByteString
k, RouteLeaf m
v) =
            let newV :: RouteLeaf m
newV = RouteLeaf m
-> (RouteLeaf m -> RouteLeaf m)
-> Maybe (RouteLeaf m)
-> RouteLeaf m
forall b a. b -> (a -> b) -> Maybe a -> b
maybe RouteLeaf m
v (RouteLeaf m -> RouteLeaf m -> RouteLeaf m
forall (m :: * -> *). RouteLeaf m -> RouteLeaf m -> RouteLeaf m
mergeValues RouteLeaf m
v) (Maybe (RouteLeaf m) -> RouteLeaf m)
-> Maybe (RouteLeaf m) -> RouteLeaf m
forall a b. (a -> b) -> a -> b
$ ByteString -> Trie (RouteLeaf m) -> Maybe (RouteLeaf m)
forall a. ByteString -> Trie a -> Maybe a
Trie.lookup ByteString
k Trie (RouteLeaf m)
t
            in ByteString
-> RouteLeaf m -> Trie (RouteLeaf m) -> Trie (RouteLeaf m)
forall a. ByteString -> a -> Trie a -> Trie a
Trie.insert ByteString
k RouteLeaf m
newV Trie (RouteLeaf m)
t
        mergeValues :: RouteLeaf m -> RouteLeaf m -> RouteLeaf m
mergeValues (Wildcard RoutedResource m
x) RouteLeaf m
_                              = RoutedResource m -> RouteLeaf m
forall (m :: * -> *). RoutedResource m -> RouteLeaf m
Wildcard RoutedResource m
x
        mergeValues RouteLeaf m
_ (Wildcard RoutedResource m
x)                                     = RoutedResource m -> RouteLeaf m
forall (m :: * -> *). RoutedResource m -> RouteLeaf m
Wildcard RoutedResource m
x
        mergeValues RouteLeaf m
RVar RouteLeaf m
RVar                                   = RouteLeaf m
forall (m :: * -> *). RouteLeaf m
RVar
        mergeValues RouteLeaf m
RVar (RouteMatch RoutedResource m
x [Text]
y)                       = RoutedResource m -> [Text] -> RouteLeaf m
forall (m :: * -> *). RoutedResource m -> [Text] -> RouteLeaf m
RouteMatchOrVar RoutedResource m
x [Text]
y
        mergeValues (RouteMatch RoutedResource m
_ [Text]
_) (RouteMatch RoutedResource m
x [Text]
y)           = RoutedResource m -> [Text] -> RouteLeaf m
forall (m :: * -> *). RoutedResource m -> [Text] -> RouteLeaf m
RouteMatch RoutedResource m
x [Text]
y
        mergeValues (RouteMatch RoutedResource m
x [Text]
y) RouteLeaf m
RVar                       = RoutedResource m -> [Text] -> RouteLeaf m
forall (m :: * -> *). RoutedResource m -> [Text] -> RouteLeaf m
RouteMatchOrVar RoutedResource m
x [Text]
y
        mergeValues (RouteMatchOrVar RoutedResource m
_ [Text]
_) (RouteMatch RoutedResource m
x [Text]
y)      = RoutedResource m -> [Text] -> RouteLeaf m
forall (m :: * -> *). RoutedResource m -> [Text] -> RouteLeaf m
RouteMatchOrVar RoutedResource m
x [Text]
y
        mergeValues (RouteMatchOrVar RoutedResource m
x [Text]
y) RouteLeaf m
_                     = RoutedResource m -> [Text] -> RouteLeaf m
forall (m :: * -> *). RoutedResource m -> [Text] -> RouteLeaf m
RouteMatchOrVar RoutedResource m
x [Text]
y
        mergeValues RouteLeaf m
_ RouteLeaf m
v                                                = RouteLeaf m
v

-- | @a '</>' b@ separates the path components @a@ and @b@ with a slash.
-- This is actually just a synonym for 'mappend'.
(</>) :: Route -> Route -> Route
</> :: Route -> Route -> Route
(</>) = Route -> Route -> Route
forall a. Semigroup a => a -> a -> a
(<>)

-- | Represents the root resource (@/@). This should usually be the first path declared in a 'RoutingSpec'.
root :: Route
root :: Route
root = [BoundOrUnbound] -> Route
Route []

-- | Captures a named in a route and adds it to the 'routingParams' hashmap under the provided 'Text' value. For example,
--
-- @
--    "blog" '</>' 'var' "date" '</>' 'var' "post"
-- @
--
-- will capture all URLs of the form @\/blog\/$date\/$post@, and add @date@ and @post@ to the 'routingParams'
-- contained within the resource this route maps to.
var :: Text -> Route
var :: Text -> Route
var Text
t = [BoundOrUnbound] -> Route
Route [Text -> BoundOrUnbound
Var Text
t]

-- | Captures a wildcard route. For example,
--
-- @
--    "emcees" '</>' star
-- @
--
-- will match @\/emcees@, @\/emcees/biggie@, @\/emcees\/earl\/vince@, and so on and so forth.
star :: Route
star :: Route
star = [BoundOrUnbound] -> Route
Route [BoundOrUnbound
RestUnbound]


-- Routing trie creation algorithm
-- 1. Store full paths as keys up to first `var`
-- 2. Calculate Base64 encoding of the URL portion preceding the
--    `var` ++ "var" and use that as key for the next part of the
--    route spec.
-- 3. Repeat step 2 for every `var` encountered until the route
 --   is completed and maps to a resource.
(#>) :: MonadWriter [(B.ByteString, (RouteLeaf a))] m
     => Route -> Resource a -> m ()
Route
k #> :: Route -> Resource a -> m ()
#> Resource a
v = do
    let (ByteString
key, [(ByteString, RouteLeaf m)]
routes, [Text]
vars, Bool
isWild) = ((ByteString, [(ByteString, RouteLeaf m)], [Text], Bool)
 -> BoundOrUnbound
 -> (ByteString, [(ByteString, RouteLeaf m)], [Text], Bool))
-> (ByteString, [(ByteString, RouteLeaf m)], [Text], Bool)
-> [BoundOrUnbound]
-> (ByteString, [(ByteString, RouteLeaf m)], [Text], Bool)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (ByteString, [(ByteString, RouteLeaf m)], [Text], Bool)
-> BoundOrUnbound
-> (ByteString, [(ByteString, RouteLeaf m)], [Text], Bool)
forall (m :: * -> *).
(ByteString, [(ByteString, RouteLeaf m)], [Text], Bool)
-> BoundOrUnbound
-> (ByteString, [(ByteString, RouteLeaf m)], [Text], Bool)
routeFoldFun (ByteString
"", [], [], Bool
False) (Route -> [BoundOrUnbound]
getRoute Route
k)
        key' :: ByteString
key' = if ByteString -> Bool
BC8.null ByteString
key then ByteString
"/"
               else ByteString
key
        ctor :: RouteLeaf a
ctor = if Bool
isWild
                  then RoutedResource a -> RouteLeaf a
forall (m :: * -> *). RoutedResource m -> RouteLeaf m
Wildcard (Route -> Resource a -> RoutedResource a
forall (m :: * -> *). Route -> Resource m -> RoutedResource m
RoutedResource Route
k Resource a
v)
                  else RoutedResource a -> [Text] -> RouteLeaf a
forall (m :: * -> *). RoutedResource m -> [Text] -> RouteLeaf m
RouteMatch (Route -> Resource a -> RoutedResource a
forall (m :: * -> *). Route -> Resource m -> RoutedResource m
RoutedResource Route
k Resource a
v) [Text]
vars
    [(ByteString, RouteLeaf a)] -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell ([(ByteString, RouteLeaf a)] -> m ())
-> [(ByteString, RouteLeaf a)] -> m ()
forall a b. (a -> b) -> a -> b
$ (ByteString
key', RouteLeaf a
ctor) (ByteString, RouteLeaf a)
-> [(ByteString, RouteLeaf a)] -> [(ByteString, RouteLeaf a)]
forall a. a -> [a] -> [a]
: [(ByteString, RouteLeaf a)]
forall (m :: * -> *). [(ByteString, RouteLeaf m)]
routes
    where
        routeFoldFun :: (ByteString, [(ByteString, RouteLeaf m)], [Text], Bool)
-> BoundOrUnbound
-> (ByteString, [(ByteString, RouteLeaf m)], [Text], Bool)
routeFoldFun (ByteString
kps, [(ByteString, RouteLeaf m)]
rt, [Text]
vs, Bool
False) (Bound Text
x) =
            ([ByteString] -> ByteString
B.concat [ByteString
kps, ByteString
"/", Text -> ByteString
encodeUtf8 Text
x], [(ByteString, RouteLeaf m)]
rt, [Text]
vs, Bool
False)
        routeFoldFun (ByteString
kps, [(ByteString, RouteLeaf m)]
rt, [Text]
vs, Bool
False) (Var Text
x) =
            let partKey :: ByteString
partKey = ByteString -> ByteString
Base64.encode (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
B.concat [ByteString
kps, ByteString
"var"]
                rt' :: [(ByteString, RouteLeaf m)]
rt' = (ByteString
kps, RouteLeaf m
forall (m :: * -> *). RouteLeaf m
RVar) (ByteString, RouteLeaf m)
-> [(ByteString, RouteLeaf m)] -> [(ByteString, RouteLeaf m)]
forall a. a -> [a] -> [a]
: [(ByteString, RouteLeaf m)]
rt
            in (ByteString
partKey, [(ByteString, RouteLeaf m)]
rt', Text
xText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
vs, Bool
False)
        routeFoldFun (ByteString
kps, [(ByteString, RouteLeaf m)]
rt, [Text]
vs, Bool
False) BoundOrUnbound
RestUnbound =
            (ByteString
kps, [(ByteString, RouteLeaf m)]
rt, [Text]
vs, Bool
True)
        routeFoldFun (ByteString
kps, [(ByteString, RouteLeaf m)]
rt, [Text]
vs, Bool
True) BoundOrUnbound
_ =
            (ByteString
kps, [(ByteString, RouteLeaf m)]
rt, [Text]
vs, Bool
True)


(#>=) :: MonadWriter [(B.ByteString, (RouteLeaf a))] m
      => Route -> m (Resource a) -> m ()
Route
k #>= :: Route -> m (Resource a) -> m ()
#>= m (Resource a)
mv = m (Resource a)
mv m (Resource a) -> (Resource a -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Route
k Route -> Resource a -> m ()
forall (a :: * -> *) (m :: * -> *).
MonadWriter [(ByteString, RouteLeaf a)] m =>
Route -> Resource a -> m ()
#>)


-- | Represents a fully-specified set of routes that map paths (represented as 'Route's) to 'Resource's. 'RoutingSpec's are declared with do-notation, to wit:
--
-- @
--    myRoutes :: RoutingSpec IO ()
--    myRoutes = do
--      root                                 #> myRootResource
--      "blog" '</>' var "date" '</>' var "post" #> blogPostResource
--      "about"                              #> aboutResource
--      "anything" '</>' star                  #> wildcardResource
-- @
--
newtype RoutingSpec m a = RoutingSpec {
        RoutingSpec m a -> Writer [(ByteString, RouteLeaf m)] a
getRouter :: Writer [(B.ByteString, RouteLeaf m)] a
    } deriving ( a -> RoutingSpec m b -> RoutingSpec m a
(a -> b) -> RoutingSpec m a -> RoutingSpec m b
(forall a b. (a -> b) -> RoutingSpec m a -> RoutingSpec m b)
-> (forall a b. a -> RoutingSpec m b -> RoutingSpec m a)
-> Functor (RoutingSpec m)
forall a b. a -> RoutingSpec m b -> RoutingSpec m a
forall a b. (a -> b) -> RoutingSpec m a -> RoutingSpec m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
forall (m :: * -> *) a b. a -> RoutingSpec m b -> RoutingSpec m a
forall (m :: * -> *) a b.
(a -> b) -> RoutingSpec m a -> RoutingSpec m b
<$ :: a -> RoutingSpec m b -> RoutingSpec m a
$c<$ :: forall (m :: * -> *) a b. a -> RoutingSpec m b -> RoutingSpec m a
fmap :: (a -> b) -> RoutingSpec m a -> RoutingSpec m b
$cfmap :: forall (m :: * -> *) a b.
(a -> b) -> RoutingSpec m a -> RoutingSpec m b
Functor, Functor (RoutingSpec m)
a -> RoutingSpec m a
Functor (RoutingSpec m)
-> (forall a. a -> RoutingSpec m a)
-> (forall a b.
    RoutingSpec m (a -> b) -> RoutingSpec m a -> RoutingSpec m b)
-> (forall a b c.
    (a -> b -> c)
    -> RoutingSpec m a -> RoutingSpec m b -> RoutingSpec m c)
-> (forall a b.
    RoutingSpec m a -> RoutingSpec m b -> RoutingSpec m b)
-> (forall a b.
    RoutingSpec m a -> RoutingSpec m b -> RoutingSpec m a)
-> Applicative (RoutingSpec m)
RoutingSpec m a -> RoutingSpec m b -> RoutingSpec m b
RoutingSpec m a -> RoutingSpec m b -> RoutingSpec m a
RoutingSpec m (a -> b) -> RoutingSpec m a -> RoutingSpec m b
(a -> b -> c)
-> RoutingSpec m a -> RoutingSpec m b -> RoutingSpec m c
forall a. a -> RoutingSpec m a
forall a b. RoutingSpec m a -> RoutingSpec m b -> RoutingSpec m a
forall a b. RoutingSpec m a -> RoutingSpec m b -> RoutingSpec m b
forall a b.
RoutingSpec m (a -> b) -> RoutingSpec m a -> RoutingSpec m b
forall a b c.
(a -> b -> c)
-> RoutingSpec m a -> RoutingSpec m b -> RoutingSpec m c
forall (m :: * -> *). Functor (RoutingSpec m)
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall (m :: * -> *) a. a -> RoutingSpec m a
forall (m :: * -> *) a b.
RoutingSpec m a -> RoutingSpec m b -> RoutingSpec m a
forall (m :: * -> *) a b.
RoutingSpec m a -> RoutingSpec m b -> RoutingSpec m b
forall (m :: * -> *) a b.
RoutingSpec m (a -> b) -> RoutingSpec m a -> RoutingSpec m b
forall (m :: * -> *) a b c.
(a -> b -> c)
-> RoutingSpec m a -> RoutingSpec m b -> RoutingSpec m c
<* :: RoutingSpec m a -> RoutingSpec m b -> RoutingSpec m a
$c<* :: forall (m :: * -> *) a b.
RoutingSpec m a -> RoutingSpec m b -> RoutingSpec m a
*> :: RoutingSpec m a -> RoutingSpec m b -> RoutingSpec m b
$c*> :: forall (m :: * -> *) a b.
RoutingSpec m a -> RoutingSpec m b -> RoutingSpec m b
liftA2 :: (a -> b -> c)
-> RoutingSpec m a -> RoutingSpec m b -> RoutingSpec m c
$cliftA2 :: forall (m :: * -> *) a b c.
(a -> b -> c)
-> RoutingSpec m a -> RoutingSpec m b -> RoutingSpec m c
<*> :: RoutingSpec m (a -> b) -> RoutingSpec m a -> RoutingSpec m b
$c<*> :: forall (m :: * -> *) a b.
RoutingSpec m (a -> b) -> RoutingSpec m a -> RoutingSpec m b
pure :: a -> RoutingSpec m a
$cpure :: forall (m :: * -> *) a. a -> RoutingSpec m a
$cp1Applicative :: forall (m :: * -> *). Functor (RoutingSpec m)
Applicative, Applicative (RoutingSpec m)
a -> RoutingSpec m a
Applicative (RoutingSpec m)
-> (forall a b.
    RoutingSpec m a -> (a -> RoutingSpec m b) -> RoutingSpec m b)
-> (forall a b.
    RoutingSpec m a -> RoutingSpec m b -> RoutingSpec m b)
-> (forall a. a -> RoutingSpec m a)
-> Monad (RoutingSpec m)
RoutingSpec m a -> (a -> RoutingSpec m b) -> RoutingSpec m b
RoutingSpec m a -> RoutingSpec m b -> RoutingSpec m b
forall a. a -> RoutingSpec m a
forall a b. RoutingSpec m a -> RoutingSpec m b -> RoutingSpec m b
forall a b.
RoutingSpec m a -> (a -> RoutingSpec m b) -> RoutingSpec m b
forall (m :: * -> *). Applicative (RoutingSpec m)
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
forall (m :: * -> *) a. a -> RoutingSpec m a
forall (m :: * -> *) a b.
RoutingSpec m a -> RoutingSpec m b -> RoutingSpec m b
forall (m :: * -> *) a b.
RoutingSpec m a -> (a -> RoutingSpec m b) -> RoutingSpec m b
return :: a -> RoutingSpec m a
$creturn :: forall (m :: * -> *) a. a -> RoutingSpec m a
>> :: RoutingSpec m a -> RoutingSpec m b -> RoutingSpec m b
$c>> :: forall (m :: * -> *) a b.
RoutingSpec m a -> RoutingSpec m b -> RoutingSpec m b
>>= :: RoutingSpec m a -> (a -> RoutingSpec m b) -> RoutingSpec m b
$c>>= :: forall (m :: * -> *) a b.
RoutingSpec m a -> (a -> RoutingSpec m b) -> RoutingSpec m b
$cp1Monad :: forall (m :: * -> *). Applicative (RoutingSpec m)
Monad
               , MonadWriter [(B.ByteString, RouteLeaf m)]
               )


route :: Trie (RouteLeaf a)
      -> BC8.ByteString
      -> Maybe (RoutedResource a, (HashMap Text Text, [Text]))
route :: Trie (RouteLeaf a)
-> ByteString
-> Maybe (RoutedResource a, (HashMap Text Text, [Text]))
route Trie (RouteLeaf a)
routes ByteString
pInfo = let matchRes :: Maybe (ByteString, RouteLeaf a, ByteString)
matchRes = Trie (RouteLeaf a)
-> ByteString -> Maybe (ByteString, RouteLeaf a, ByteString)
forall a. Trie a -> ByteString -> Maybe (ByteString, a, ByteString)
Trie.match Trie (RouteLeaf a)
routes ByteString
pInfo
                     in Trie (RouteLeaf a)
-> Maybe (ByteString, RouteLeaf a, ByteString)
-> [Text]
-> Maybe ByteString
-> Maybe (RoutedResource a, (HashMap Text Text, [Text]))
forall (a :: * -> *).
Trie (RouteLeaf a)
-> Maybe (ByteString, RouteLeaf a, ByteString)
-> [Text]
-> Maybe ByteString
-> Maybe (RoutedResource a, (HashMap Text Text, [Text]))
matchRoute' Trie (RouteLeaf a)
routes Maybe (ByteString, RouteLeaf a, ByteString)
matchRes [Text]
forall a. Monoid a => a
mempty Maybe ByteString
forall a. Maybe a
Nothing


matchRoute' :: Trie (RouteLeaf a)
            -> Maybe (B.ByteString, RouteLeaf a, B.ByteString)
            -> [Text]
            -> Maybe B.ByteString
            -> Maybe (RoutedResource a, (HashMap Text Text, [Text]))
matchRoute' :: Trie (RouteLeaf a)
-> Maybe (ByteString, RouteLeaf a, ByteString)
-> [Text]
-> Maybe ByteString
-> Maybe (RoutedResource a, (HashMap Text Text, [Text]))
matchRoute' Trie (RouteLeaf a)
_routes Maybe (ByteString, RouteLeaf a, ByteString)
Nothing [Text]
_ps Maybe ByteString
_dsp =
    -- Nothing even partially matched the route
    Maybe (RoutedResource a, (HashMap Text Text, [Text]))
forall a. Maybe a
Nothing
matchRoute' Trie (RouteLeaf a)
routes (Just (ByteString
matched, RouteMatchOrVar RoutedResource a
r [Text]
vars, ByteString
"")) [Text]
ps Maybe ByteString
dsp =
    -- The matched key is also a prefix of other routes, but the
    -- entire path matched so handle like a RouteMatch.
    Trie (RouteLeaf a)
-> Maybe (ByteString, RouteLeaf a, ByteString)
-> [Text]
-> Maybe ByteString
-> Maybe (RoutedResource a, (HashMap Text Text, [Text]))
forall (a :: * -> *).
Trie (RouteLeaf a)
-> Maybe (ByteString, RouteLeaf a, ByteString)
-> [Text]
-> Maybe ByteString
-> Maybe (RoutedResource a, (HashMap Text Text, [Text]))
matchRoute' Trie (RouteLeaf a)
routes ((ByteString, RouteLeaf a, ByteString)
-> Maybe (ByteString, RouteLeaf a, ByteString)
forall a. a -> Maybe a
Just (ByteString
matched, RoutedResource a -> [Text] -> RouteLeaf a
forall (m :: * -> *). RoutedResource m -> [Text] -> RouteLeaf m
RouteMatch RoutedResource a
r [Text]
vars, ByteString
"")) [Text]
ps Maybe ByteString
dsp
matchRoute' Trie (RouteLeaf a)
_routes (Just (ByteString
matched, RouteMatch RoutedResource a
r [Text]
vars, ByteString
"")) [Text]
ps Maybe ByteString
dsp =
    -- The entire path matched so return the resource, params, and
    -- dispatch path
    (RoutedResource a, (HashMap Text Text, [Text]))
-> Maybe (RoutedResource a, (HashMap Text Text, [Text]))
forall a. a -> Maybe a
Just (RoutedResource a
r, ([(Text, Text)] -> HashMap Text Text
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
fromList ([(Text, Text)] -> HashMap Text Text)
-> [(Text, Text)] -> HashMap Text Text
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text] -> [(Text, Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
vars [Text]
ps, Maybe ByteString -> ByteString -> [Text]
dispatchList Maybe ByteString
dsp ByteString
matched))
    where
        dispatchList :: Maybe ByteString -> ByteString -> [Text]
dispatchList (Just ByteString
d) ByteString
m = ByteString -> [Text]
toTextList (ByteString -> [Text]) -> ByteString -> [Text]
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
B.concat [ByteString
d, ByteString
m]
        dispatchList Maybe ByteString
Nothing ByteString
_ = [Text]
forall a. Monoid a => a
mempty
        toTextList :: ByteString -> [Text]
toTextList ByteString
bs = ByteString -> Text
decodeUtf8 (ByteString -> Text) -> [ByteString] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> ByteString -> [ByteString]
BC8.split Char
'/' ByteString
bs
matchRoute' Trie (RouteLeaf a)
_routes (Just (ByteString
_matched, RouteMatch RoutedResource a
_r [Text]
_vars, ByteString
_)) [Text]
_ps Maybe ByteString
_dsp =
    -- Part of the request path matched, but the trie value at the
    -- matched prefix is not an RVar or RouteMatchOrVar so there is no
    -- match.
    Maybe (RoutedResource a, (HashMap Text Text, [Text]))
forall a. Maybe a
Nothing
matchRoute' Trie (RouteLeaf a)
routes (Just (ByteString
matched, RouteMatchOrVar RoutedResource a
_r [Text]
_vars, ByteString
rest)) [Text]
ps Maybe ByteString
dsp =
    -- Part of the request path matched and the trie value at the
    -- matched prefix is a RouteMatchOrVar so handle it the same as if
    -- the value were RVar.
    Trie (RouteLeaf a)
-> Maybe (ByteString, RouteLeaf a, ByteString)
-> [Text]
-> Maybe ByteString
-> Maybe (RoutedResource a, (HashMap Text Text, [Text]))
forall (a :: * -> *).
Trie (RouteLeaf a)
-> Maybe (ByteString, RouteLeaf a, ByteString)
-> [Text]
-> Maybe ByteString
-> Maybe (RoutedResource a, (HashMap Text Text, [Text]))
matchRoute' Trie (RouteLeaf a)
routes ((ByteString, RouteLeaf a, ByteString)
-> Maybe (ByteString, RouteLeaf a, ByteString)
forall a. a -> Maybe a
Just (ByteString
matched, RouteLeaf a
forall (m :: * -> *). RouteLeaf m
RVar, ByteString
rest)) [Text]
ps Maybe ByteString
dsp
matchRoute' Trie (RouteLeaf a)
routes (Just (ByteString
matched, RouteLeaf a
RVar, ByteString
rest)) [Text]
ps Maybe ByteString
dsp
    | ByteString -> Bool
BC8.null ByteString
rest = Maybe (RoutedResource a, (HashMap Text Text, [Text]))
forall a. Maybe a
Nothing
    | Int -> ByteString -> ByteString
BC8.take Int
2 ByteString
rest ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"//" = Maybe (RoutedResource a, (HashMap Text Text, [Text]))
forall a. Maybe a
Nothing
    | ByteString -> Char
BC8.head ByteString
rest Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/' =
        -- Part of the request path matched and the trie value at the
        -- matched prefix is a RVar so calculate the key for the next part
        -- of the route and continue attempting to match.
        let nextKey :: ByteString
nextKey = [ByteString] -> ByteString
B.concat [ ByteString -> ByteString
Base64.encode (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
B.concat [ByteString
matched, ByteString
"var"]
                               , (Char -> Bool) -> ByteString -> ByteString
BC8.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'/') (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ByteString -> ByteString
BC8.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'/') ByteString
rest
                               ]
            updDsp :: Maybe ByteString
updDsp = if Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isNothing Maybe ByteString
dsp then ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
forall a. Monoid a => a
mempty
                     else Maybe ByteString
dsp
            paramVal :: Text
paramVal = ByteString -> Text
decodeUtf8 (ByteString -> Text)
-> (ByteString -> ByteString) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ByteString -> ByteString
BC8.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'/')
                       (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ByteString -> ByteString
BC8.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'/') ByteString
rest
            matchRes :: Maybe (ByteString, RouteLeaf a, ByteString)
matchRes = Trie (RouteLeaf a)
-> ByteString -> Maybe (ByteString, RouteLeaf a, ByteString)
forall a. Trie a -> ByteString -> Maybe (ByteString, a, ByteString)
Trie.match Trie (RouteLeaf a)
routes ByteString
nextKey
        in Trie (RouteLeaf a)
-> Maybe (ByteString, RouteLeaf a, ByteString)
-> [Text]
-> Maybe ByteString
-> Maybe (RoutedResource a, (HashMap Text Text, [Text]))
forall (a :: * -> *).
Trie (RouteLeaf a)
-> Maybe (ByteString, RouteLeaf a, ByteString)
-> [Text]
-> Maybe ByteString
-> Maybe (RoutedResource a, (HashMap Text Text, [Text]))
matchRoute' Trie (RouteLeaf a)
routes Maybe (ByteString, RouteLeaf a, ByteString)
matchRes (Text
paramValText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
ps) Maybe ByteString
updDsp
    | Bool
otherwise = Maybe (RoutedResource a, (HashMap Text Text, [Text]))
forall a. Maybe a
Nothing
matchRoute' Trie (RouteLeaf a)
_routes (Just (ByteString
_matched, Wildcard RoutedResource a
r, ByteString
rest)) [Text]
_ps Maybe ByteString
_dsp =
    -- Encountered a wildcard (star) value in the trie so it's a match
    (RoutedResource a, (HashMap Text Text, [Text]))
-> Maybe (RoutedResource a, (HashMap Text Text, [Text]))
forall a. a -> Maybe a
Just (RoutedResource a
r, (HashMap Text Text
forall a. Monoid a => a
mempty, ByteString -> Text
decodeUtf8 (ByteString -> Text) -> [ByteString] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Char -> Bool) -> ByteString -> ByteString
BC8.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'/') ByteString
rest]))