{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_HADDOCK hide #-}
module Happstack.StaticRouting.Internal where

import Control.Arrow (first)
import Control.Monad (liftM, mplus)
import Data.Map (Map)
import Data.Maybe
import Happstack.Server
  ( FromReqURI, Method, ServerMonad, askRq, fromReqURI, localRq, rqMethod, rqPaths
  )
import qualified Data.ListTrie.Map as Trie
import qualified Data.Map as Map

-- | Static routing tables consisting of handlers of type 'a'.
data Route a
  = Dir Segment (Route a)
  | Param (Route a)
  | Handler EndSegment CheckApply a
  | Choice [Route a]
  deriving a -> Route b -> Route a
(a -> b) -> Route a -> Route b
(forall a b. (a -> b) -> Route a -> Route b)
-> (forall a b. a -> Route b -> Route a) -> Functor Route
forall a b. a -> Route b -> Route a
forall a b. (a -> b) -> Route a -> Route b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Route b -> Route a
$c<$ :: forall a b. a -> Route b -> Route a
fmap :: (a -> b) -> Route a -> Route b
$cfmap :: forall a b. (a -> b) -> Route a -> Route b
Functor

data Segment = StringS String | ParamS
  deriving (Int -> Segment -> ShowS
[Segment] -> ShowS
Segment -> String
(Int -> Segment -> ShowS)
-> (Segment -> String) -> ([Segment] -> ShowS) -> Show Segment
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Segment] -> ShowS
$cshowList :: [Segment] -> ShowS
show :: Segment -> String
$cshow :: Segment -> String
showsPrec :: Int -> Segment -> ShowS
$cshowsPrec :: Int -> Segment -> ShowS
Show, Segment -> Segment -> Bool
(Segment -> Segment -> Bool)
-> (Segment -> Segment -> Bool) -> Eq Segment
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Segment -> Segment -> Bool
$c/= :: Segment -> Segment -> Bool
== :: Segment -> Segment -> Bool
$c== :: Segment -> Segment -> Bool
Eq, Eq Segment
Eq Segment
-> (Segment -> Segment -> Ordering)
-> (Segment -> Segment -> Bool)
-> (Segment -> Segment -> Bool)
-> (Segment -> Segment -> Bool)
-> (Segment -> Segment -> Bool)
-> (Segment -> Segment -> Segment)
-> (Segment -> Segment -> Segment)
-> Ord Segment
Segment -> Segment -> Bool
Segment -> Segment -> Ordering
Segment -> Segment -> Segment
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Segment -> Segment -> Segment
$cmin :: Segment -> Segment -> Segment
max :: Segment -> Segment -> Segment
$cmax :: Segment -> Segment -> Segment
>= :: Segment -> Segment -> Bool
$c>= :: Segment -> Segment -> Bool
> :: Segment -> Segment -> Bool
$c> :: Segment -> Segment -> Bool
<= :: Segment -> Segment -> Bool
$c<= :: Segment -> Segment -> Bool
< :: Segment -> Segment -> Bool
$c< :: Segment -> Segment -> Bool
compare :: Segment -> Segment -> Ordering
$ccompare :: Segment -> Segment -> Ordering
$cp1Ord :: Eq Segment
Ord)

type EndSegment = (Maybe Int, Method)

type CheckApply = [String] -> Bool

-- | Support for varying number of arguments to 'path' handlers.
class Path m hm h r | h -> m r where
  pathHandler  :: forall r'. (m r -> hm r') -> h -> hm r'
  arity        :: h -> Int
  canBeApplied :: h -> [String] -> Bool

instance
  ( FromReqURI v
  , ServerMonad hm
  , Path m hm h r
  ) => Path m hm (v -> h) r where
    pathHandler :: (m r -> hm r') -> (v -> h) -> hm r'
pathHandler m r -> hm r'
trans v -> h
f = (v -> hm r') -> hm r'
forall a (m :: * -> *) b.
(FromReqURI a, ServerMonad m) =>
(a -> m b) -> m b
applyPath ((m r -> hm r') -> h -> hm r'
forall (m :: * -> *) (hm :: * -> *) h r r'.
Path m hm h r =>
(m r -> hm r') -> h -> hm r'
pathHandler m r -> hm r'
trans (h -> hm r') -> (v -> h) -> v -> hm r'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> h
f)
    arity :: (v -> h) -> Int
arity v -> h
f = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ h -> Int
forall (m :: * -> *) (hm :: * -> *) h r. Path m hm h r => h -> Int
arity @m @hm (v -> h
f v
forall a. HasCallStack => a
undefined)
    canBeApplied :: (v -> h) -> [String] -> Bool
canBeApplied v -> h
_ [] = Bool
False
    canBeApplied v -> h
f (String
s:[String]
ss) = case (String -> Maybe v
forall a. FromReqURI a => String -> Maybe a
fromReqURI String
s) of
                                Just v
p -> h -> [String] -> Bool
forall (m :: * -> *) (hm :: * -> *) h r.
Path m hm h r =>
h -> [String] -> Bool
canBeApplied @m @hm (v -> h
f v
p) [String]
ss
                                Maybe v
Nothing -> Bool
False


-- | Pop a path element and parse it using the 'fromReqURI' in the
-- 'FromReqURI' class.  Variant of Happstack.Server.path without 'mzero'
applyPath :: (FromReqURI a, ServerMonad m) => (a -> m b) -> m b
applyPath :: (a -> m b) -> m b
applyPath a -> m b
handle = do
    Request
rq <- m Request
forall (m :: * -> *). ServerMonad m => m Request
askRq
    case Request -> [String]
rqPaths Request
rq of
        (String
p:[String]
xs) | Just a
a <- String -> Maybe a
forall a. FromReqURI a => String -> Maybe a
fromReqURI String
p
                            -> (Request -> Request) -> m b -> m b
forall (m :: * -> *) a.
ServerMonad m =>
(Request -> Request) -> m a -> m a
localRq (\Request
newRq -> Request
newRq{rqPaths :: [String]
rqPaths = [String]
xs}) (a -> m b
handle a
a)
        [String]
_ -> String -> m b
forall a. HasCallStack => String -> a
error String
"Happstack.StaticRouting.applyPath"


instance Path m hm (m r) r where
  pathHandler :: (m r -> hm r') -> m r -> hm r'
pathHandler m r -> hm r'
trans m r
mr = m r -> hm r'
trans m r
mr
  arity :: m r -> Int
arity m r
_ = Int
0
  canBeApplied :: m r -> [String] -> Bool
canBeApplied m r
_ [String]
_ = Bool
True

-- | Pop a path element if it matches the given string.
dir :: String -> Route a -> Route a
dir :: String -> Route a -> Route a
dir = Segment -> Route a -> Route a
forall a. Segment -> Route a -> Route a
Dir (Segment -> Route a -> Route a)
-> (String -> Segment) -> String -> Route a -> Route a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Segment
StringS

-- | Pop a path element, and store it to use with handler
param :: Route a -> Route a
param :: Route a -> Route a
param = Route a -> Route a
forall a. Route a -> Route a
Param

-- | Combine several route alternatives into one.
choice :: [Route a] -> Route a
choice :: [Route a] -> Route a
choice = [Route a] -> Route a
forall a. [Route a] -> Route a
Choice

-- | Expect the given method, and exactly 'n' more segments, where 'n' is the arity of the handler.
path :: forall m hm h r r'. Path m hm h r
     => Method -> (m r -> hm r') -> h -> Route (hm r')
path :: Method -> (m r -> hm r') -> h -> Route (hm r')
path Method
m m r -> hm r'
trans h
h = EndSegment -> ([String] -> Bool) -> hm r' -> Route (hm r')
forall a. EndSegment -> ([String] -> Bool) -> a -> Route a
Handler (Int -> Maybe Int
forall a. a -> Maybe a
Just (h -> Int
forall (m :: * -> *) (hm :: * -> *) h r. Path m hm h r => h -> Int
arity @m @hm h
h), Method
m) (h -> [String] -> Bool
forall (m :: * -> *) (hm :: * -> *) h r.
Path m hm h r =>
h -> [String] -> Bool
canBeApplied @m @hm h
h) ((m r -> hm r') -> h -> hm r'
forall (m :: * -> *) (hm :: * -> *) h r r'.
Path m hm h r =>
(m r -> hm r') -> h -> hm r'
pathHandler m r -> hm r'
trans h
h)

-- | Expect zero or more segments.
remainingPath :: Method -> h -> Route h
remainingPath :: Method -> h -> Route h
remainingPath Method
m = EndSegment -> ([String] -> Bool) -> h -> Route h
forall a. EndSegment -> ([String] -> Bool) -> a -> Route a
Handler (Maybe Int
forall a. Maybe a
Nothing,Method
m) (\[String]
_ -> Bool
True)

newtype RouteTree a =
  R { RouteTree a -> TrieMap Map Segment (Map EndSegment a)
unR :: Trie.TrieMap Map Segment (Map EndSegment a) } deriving (Int -> RouteTree a -> ShowS
[RouteTree a] -> ShowS
RouteTree a -> String
(Int -> RouteTree a -> ShowS)
-> (RouteTree a -> String)
-> ([RouteTree a] -> ShowS)
-> Show (RouteTree a)
forall a. Show a => Int -> RouteTree a -> ShowS
forall a. Show a => [RouteTree a] -> ShowS
forall a. Show a => RouteTree a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RouteTree a] -> ShowS
$cshowList :: forall a. Show a => [RouteTree a] -> ShowS
show :: RouteTree a -> String
$cshow :: forall a. Show a => RouteTree a -> String
showsPrec :: Int -> RouteTree a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> RouteTree a -> ShowS
Show, a -> RouteTree b -> RouteTree a
(a -> b) -> RouteTree a -> RouteTree b
(forall a b. (a -> b) -> RouteTree a -> RouteTree b)
-> (forall a b. a -> RouteTree b -> RouteTree a)
-> Functor RouteTree
forall a b. a -> RouteTree b -> RouteTree a
forall a b. (a -> b) -> RouteTree a -> RouteTree b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> RouteTree b -> RouteTree a
$c<$ :: forall a b. a -> RouteTree b -> RouteTree a
fmap :: (a -> b) -> RouteTree a -> RouteTree b
$cfmap :: forall a b. (a -> b) -> RouteTree a -> RouteTree b
Functor)

type Segments = ([Segment], EndSegment)

-- | Compile a route into a 'RouteTree'.  Turn overlapping routes into 'Nothing'
routeTreeWithOverlaps :: Route a -> RouteTree (Maybe (CheckApply,a))
routeTreeWithOverlaps :: Route a -> RouteTree (Maybe ([String] -> Bool, a))
routeTreeWithOverlaps Route a
r =
  TrieMap Map Segment (Map EndSegment (Maybe ([String] -> Bool, a)))
-> RouteTree (Maybe ([String] -> Bool, a))
forall a. TrieMap Map Segment (Map EndSegment a) -> RouteTree a
R (TrieMap Map Segment (Map EndSegment (Maybe ([String] -> Bool, a)))
 -> RouteTree (Maybe ([String] -> Bool, a)))
-> TrieMap
     Map Segment (Map EndSegment (Maybe ([String] -> Bool, a)))
-> RouteTree (Maybe ([String] -> Bool, a))
forall a b. (a -> b) -> a -> b
$ ((([Segment], EndSegment), ([String] -> Bool, a))
 -> TrieMap
      Map Segment (Map EndSegment (Maybe ([String] -> Bool, a)))
 -> TrieMap
      Map Segment (Map EndSegment (Maybe ([String] -> Bool, a))))
-> TrieMap
     Map Segment (Map EndSegment (Maybe ([String] -> Bool, a)))
-> [(([Segment], EndSegment), ([String] -> Bool, a))]
-> TrieMap
     Map Segment (Map EndSegment (Maybe ([String] -> Bool, a)))
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(([Segment]
ps,EndSegment
es),([String] -> Bool, a)
m) ->
              (Map EndSegment (Maybe ([String] -> Bool, a))
 -> Map EndSegment (Maybe ([String] -> Bool, a))
 -> Map EndSegment (Maybe ([String] -> Bool, a)))
-> [Segment]
-> Map EndSegment (Maybe ([String] -> Bool, a))
-> TrieMap
     Map Segment (Map EndSegment (Maybe ([String] -> Bool, a)))
-> TrieMap
     Map Segment (Map EndSegment (Maybe ([String] -> Bool, a)))
forall (map :: * -> * -> *) k a.
Map map k =>
(a -> a -> a) -> [k] -> a -> TrieMap map k a -> TrieMap map k a
Trie.insertWith ((Maybe ([String] -> Bool, a)
 -> Maybe ([String] -> Bool, a) -> Maybe ([String] -> Bool, a))
-> Map EndSegment (Maybe ([String] -> Bool, a))
-> Map EndSegment (Maybe ([String] -> Bool, a))
-> Map EndSegment (Maybe ([String] -> Bool, a))
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Maybe ([String] -> Bool, a)
-> Maybe ([String] -> Bool, a) -> Maybe ([String] -> Bool, a)
forall a a. Maybe a -> Maybe a -> Maybe a
merge)
                  [Segment]
ps
                  (EndSegment
-> Maybe ([String] -> Bool, a)
-> Map EndSegment (Maybe ([String] -> Bool, a))
forall k a. k -> a -> Map k a
Map.singleton EndSegment
es (([String] -> Bool, a) -> Maybe ([String] -> Bool, a)
forall a. a -> Maybe a
Just ([String] -> Bool, a)
m)))
      TrieMap Map Segment (Map EndSegment (Maybe ([String] -> Bool, a)))
forall (map :: * -> * -> *) k a. Map map k => TrieMap map k a
Trie.empty
      (Route a -> [(([Segment], EndSegment), ([String] -> Bool, a))]
forall a.
Route a -> [(([Segment], EndSegment), ([String] -> Bool, a))]
flatten Route a
r)
  where merge :: Maybe a -> Maybe a -> Maybe a
merge (Just a
_) Maybe a
_ = Maybe a
forall a. Maybe a
Nothing -- overlap
        merge Maybe a
Nothing  Maybe a
m = Maybe a
m

-- | Check for overlaps in a 'RouteTree', returning either an error
-- message in case of an overlap, or a 'RouteTree' without overlaps.
routeTree :: RouteTree (Maybe (CheckApply, a)) -> Either String (RouteTree (CheckApply, a))
routeTree :: RouteTree (Maybe ([String] -> Bool, a))
-> Either String (RouteTree ([String] -> Bool, a))
routeTree RouteTree (Maybe ([String] -> Bool, a))
t | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [([Segment], EndSegment)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [([Segment], EndSegment)]
os =
                String -> Either String (RouteTree ([String] -> Bool, a))
forall a b. a -> Either a b
Left (String -> Either String (RouteTree ([String] -> Bool, a)))
-> String -> Either String (RouteTree ([String] -> Bool, a))
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
                  String
"Happstack.StaticRouting: Overlapping handlers in" String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
                  (([Segment], EndSegment) -> String)
-> [([Segment], EndSegment)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String
"  "String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS
-> (([Segment], EndSegment) -> String)
-> ([Segment], EndSegment)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Segment], EndSegment) -> String
showSegments) [([Segment], EndSegment)]
os
            | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [([Segment], EndSegment)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [([Segment], EndSegment)]
is =
                String -> Either String (RouteTree ([String] -> Bool, a))
forall a b. a -> Either a b
Left (String -> Either String (RouteTree ([String] -> Bool, a)))
-> String -> Either String (RouteTree ([String] -> Bool, a))
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
                  String
"Happstack.StaticRouting: Unreachable handler due to ignored parameter in" String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
                  (([Segment], EndSegment) -> String)
-> [([Segment], EndSegment)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String
"  "String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS
-> (([Segment], EndSegment) -> String)
-> ([Segment], EndSegment)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Segment], EndSegment) -> String
showSegments) [([Segment], EndSegment)]
is
            | Bool
otherwise = RouteTree ([String] -> Bool, a)
-> Either String (RouteTree ([String] -> Bool, a))
forall a b. b -> Either a b
Right (RouteTree ([String] -> Bool, a)
 -> Either String (RouteTree ([String] -> Bool, a)))
-> RouteTree ([String] -> Bool, a)
-> Either String (RouteTree ([String] -> Bool, a))
forall a b. (a -> b) -> a -> b
$ (Maybe ([String] -> Bool, a) -> ([String] -> Bool, a))
-> RouteTree (Maybe ([String] -> Bool, a))
-> RouteTree ([String] -> Bool, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe ([String] -> Bool, a) -> ([String] -> Bool, a)
forall a. HasCallStack => Maybe a -> a
fromJust RouteTree (Maybe ([String] -> Bool, a))
t

  where os :: [([Segment], EndSegment)]
os = [ ([Segment]
ss, EndSegment
es) | ([Segment]
ss, Map EndSegment (Maybe ([String] -> Bool, a))
m) <- TrieMap Map Segment (Map EndSegment (Maybe ([String] -> Bool, a)))
-> [([Segment], Map EndSegment (Maybe ([String] -> Bool, a)))]
forall (map :: * -> * -> *) k a.
Map map k =>
TrieMap map k a -> [([k], a)]
Trie.toList (RouteTree (Maybe ([String] -> Bool, a))
-> TrieMap
     Map Segment (Map EndSegment (Maybe ([String] -> Bool, a)))
forall a. RouteTree a -> TrieMap Map Segment (Map EndSegment a)
unR RouteTree (Maybe ([String] -> Bool, a))
t)
             , (EndSegment
es, Maybe ([String] -> Bool, a)
Nothing) <- Map EndSegment (Maybe ([String] -> Bool, a))
-> [(EndSegment, Maybe ([String] -> Bool, a))]
forall k a. Map k a -> [(k, a)]
Map.toList Map EndSegment (Maybe ([String] -> Bool, a))
m
             ]
        is :: [([Segment], EndSegment)]
is = [ ([Segment]
ss, EndSegment
es) | ([Segment]
ss, Map EndSegment (Maybe ([String] -> Bool, a))
m) <- TrieMap Map Segment (Map EndSegment (Maybe ([String] -> Bool, a)))
-> [([Segment], Map EndSegment (Maybe ([String] -> Bool, a)))]
forall (map :: * -> * -> *) k a.
Map map k =>
TrieMap map k a -> [([k], a)]
Trie.toList (RouteTree (Maybe ([String] -> Bool, a))
-> TrieMap
     Map Segment (Map EndSegment (Maybe ([String] -> Bool, a)))
forall a. RouteTree a -> TrieMap Map Segment (Map EndSegment a)
unR RouteTree (Maybe ([String] -> Bool, a))
t)
             , (es :: EndSegment
es@(Just Int
p, Method
_), Maybe ([String] -> Bool, a)
_) <- Map EndSegment (Maybe ([String] -> Bool, a))
-> [(EndSegment, Maybe ([String] -> Bool, a))]
forall k a. Map k a -> [(k, a)]
Map.toList Map EndSegment (Maybe ([String] -> Bool, a))
m
             , Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [Segment] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Segment -> Bool) -> [Segment] -> [Segment]
forall a. (a -> Bool) -> [a] -> [a]
filter (Segment -> Segment -> Bool
forall a. Eq a => a -> a -> Bool
(==) Segment
ParamS) ([Segment] -> [Segment]) -> [Segment] -> [Segment]
forall a b. (a -> b) -> a -> b
$ [Segment]
ss)
             ]
showSegments :: Segments -> String
showSegments :: ([Segment], EndSegment) -> String
showSegments ([Segment]
ss, EndSegment
es) = (Segment -> String) -> [Segment] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Segment -> String
showSegment [Segment]
ss String -> ShowS
forall a. [a] -> [a] -> [a]
++ EndSegment -> String
showEndSegment EndSegment
es
  where

  showSegment :: Segment -> String
  showSegment :: Segment -> String
showSegment (StringS String
e) = String
"dir " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
e String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" $ "
  showSegment (Segment
ParamS) = String
"param (used in handler) $ "

  showEndSegment :: EndSegment -> String
  showEndSegment :: EndSegment -> String
showEndSegment (Just Int
a, Method
m) = String
"<handler> -- with method " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Method -> String
forall a. Show a => a -> String
show Method
m String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" and arity " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
a
  showEndSegment (Maybe Int
Nothing, Method
m) = String
"remainingPath $ <handler> -- with method " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Method -> String
forall a. Show a => a -> String
show Method
m

flatten :: Route a -> [(Segments, (CheckApply, a))]
flatten :: Route a -> [(([Segment], EndSegment), ([String] -> Bool, a))]
flatten = Route a -> [(([Segment], EndSegment), ([String] -> Bool, a))]
forall a.
Route a -> [(([Segment], EndSegment), ([String] -> Bool, a))]
f where
  f :: Route b -> [(([Segment], EndSegment), ([String] -> Bool, b))]
f (Dir Segment
s Route b
r) = ((([Segment], EndSegment), ([String] -> Bool, b))
 -> (([Segment], EndSegment), ([String] -> Bool, b)))
-> [(([Segment], EndSegment), ([String] -> Bool, b))]
-> [(([Segment], EndSegment), ([String] -> Bool, b))]
forall a b. (a -> b) -> [a] -> [b]
map ((([Segment], EndSegment) -> ([Segment], EndSegment))
-> (([Segment], EndSegment), ([String] -> Bool, b))
-> (([Segment], EndSegment), ([String] -> Bool, b))
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (([Segment] -> [Segment])
-> ([Segment], EndSegment) -> ([Segment], EndSegment)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (Segment
sSegment -> [Segment] -> [Segment]
forall a. a -> [a] -> [a]
:))) (Route b -> [(([Segment], EndSegment), ([String] -> Bool, b))]
f Route b
r)
  f (Param Route b
r) = ((([Segment], EndSegment), ([String] -> Bool, b))
 -> (([Segment], EndSegment), ([String] -> Bool, b)))
-> [(([Segment], EndSegment), ([String] -> Bool, b))]
-> [(([Segment], EndSegment), ([String] -> Bool, b))]
forall a b. (a -> b) -> [a] -> [b]
map ((([Segment], EndSegment) -> ([Segment], EndSegment))
-> (([Segment], EndSegment), ([String] -> Bool, b))
-> (([Segment], EndSegment), ([String] -> Bool, b))
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (([Segment] -> [Segment])
-> ([Segment], EndSegment) -> ([Segment], EndSegment)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (Segment
ParamSSegment -> [Segment] -> [Segment]
forall a. a -> [a] -> [a]
:))) (Route b -> [(([Segment], EndSegment), ([String] -> Bool, b))]
f Route b
r)
  f (Handler EndSegment
e [String] -> Bool
ca b
a) = [(([], EndSegment
e), ([String] -> Bool
ca, b
a))]
  f (Choice [Route b]
rs) = (Route b -> [(([Segment], EndSegment), ([String] -> Bool, b))])
-> [Route b] -> [(([Segment], EndSegment), ([String] -> Bool, b))]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Route b -> [(([Segment], EndSegment), ([String] -> Bool, b))]
f [Route b]
rs

-- | Compile routes or return overlap report.  Returns 'Left e' in
-- case of order-dependent overlap between handlers, where 'e'
-- describes the overlap.  Returns 'Right h', where h is a compiled
-- handler that returns 'Nothing' in case no matching handler was
-- found, otherwise 'Just response'.
compile :: ServerMonad m => Route (m r) -> Either String (m (Maybe r))
compile :: Route (m r) -> Either String (m (Maybe r))
compile Route (m r)
r = case RouteTree (Maybe ([String] -> Bool, m r))
-> Either String (RouteTree ([String] -> Bool, m r))
forall a.
RouteTree (Maybe ([String] -> Bool, a))
-> Either String (RouteTree ([String] -> Bool, a))
routeTree (RouteTree (Maybe ([String] -> Bool, m r))
 -> Either String (RouteTree ([String] -> Bool, m r)))
-> RouteTree (Maybe ([String] -> Bool, m r))
-> Either String (RouteTree ([String] -> Bool, m r))
forall a b. (a -> b) -> a -> b
$ Route (m r) -> RouteTree (Maybe ([String] -> Bool, m r))
forall a. Route a -> RouteTree (Maybe ([String] -> Bool, a))
routeTreeWithOverlaps Route (m r)
r of
              Left String
s -> String -> Either String (m (Maybe r))
forall a b. a -> Either a b
Left String
s
              Right RouteTree ([String] -> Bool, m r)
t -> m (Maybe r) -> Either String (m (Maybe r))
forall a b. b -> Either a b
Right (m (Maybe r) -> Either String (m (Maybe r)))
-> m (Maybe r) -> Either String (m (Maybe r))
forall a b. (a -> b) -> a -> b
$ RouteTree ([String] -> Bool, m r) -> m (Maybe r)
forall (m :: * -> *) r.
ServerMonad m =>
RouteTree ([String] -> Bool, m r) -> m (Maybe r)
dispatch RouteTree ([String] -> Bool, m r)
t

-- | Dispatch a request given a route.  Give priority to more specific paths.
dispatch :: ServerMonad m => RouteTree (CheckApply, m r) -> m (Maybe r)
dispatch :: RouteTree ([String] -> Bool, m r) -> m (Maybe r)
dispatch RouteTree ([String] -> Bool, m r)
t = do
  Request
rq  <- m Request
forall (m :: * -> *). ServerMonad m => m Request
askRq
  case [String]
-> Method
-> [String]
-> RouteTree ([String] -> Bool, m r)
-> Maybe ([String], m r)
forall a.
[String]
-> Method
-> [String]
-> RouteTree ([String] -> Bool, a)
-> Maybe ([String], a)
dispatch' [] (Request -> Method
rqMethod Request
rq) (Request -> [String]
rqPaths Request
rq) RouteTree ([String] -> Bool, m r)
t of
    Just ([String]
rq', m r
h) -> r -> Maybe r
forall a. a -> Maybe a
Just (r -> Maybe r) -> m r -> m (Maybe r)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` (Request -> Request) -> m r -> m r
forall (m :: * -> *) a.
ServerMonad m =>
(Request -> Request) -> m a -> m a
localRq (\Request
newRq -> Request
newRq{ rqPaths :: [String]
rqPaths = [String]
rq'}) m r
h
    Maybe ([String], m r)
Nothing       -> Maybe r -> m (Maybe r)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe r
forall a. Maybe a
Nothing

-- | Dispatch a request given a method and path.  Give priority to more specific paths.
-- 'params' holds path segments that where matched 'ParamS' segment.
dispatch' :: forall a. [String] -> Method -> [String] -> RouteTree (CheckApply, a) -> Maybe ([String], a)
dispatch' :: [String]
-> Method
-> [String]
-> RouteTree ([String] -> Bool, a)
-> Maybe ([String], a)
dispatch' [String]
params Method
m [String]
ps (R TrieMap Map Segment (Map EndSegment ([String] -> Bool, a))
t) = [String] -> Maybe ([String], a)
dChildren [String]
ps Maybe ([String], a) -> Maybe ([String], a) -> Maybe ([String], a)
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` (a -> ([String], a)) -> Maybe a -> Maybe ([String], a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([String]
params [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
ps,) Maybe a
dNode
  where
  -- most specific: look up a segment in the children and recurse
  dChildren :: [String] -> Maybe ([String], a)
  dChildren :: [String] -> Maybe ([String], a)
dChildren (String
p:[String]
ps') = ((Segment
-> Map
     Segment
     (TrieMap Map Segment (Map EndSegment ([String] -> Bool, a)))
-> Maybe
     (TrieMap Map Segment (Map EndSegment ([String] -> Bool, a)))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (String -> Segment
StringS String
p) (TrieMap Map Segment (Map EndSegment ([String] -> Bool, a))
-> Map
     Segment
     (TrieMap Map Segment (Map EndSegment ([String] -> Bool, a)))
forall (map :: * -> * -> *) k a.
Map map k =>
TrieMap map k a -> map k (TrieMap map k a)
Trie.children1 TrieMap Map Segment (Map EndSegment ([String] -> Bool, a))
t)) Maybe (TrieMap Map Segment (Map EndSegment ([String] -> Bool, a)))
-> (TrieMap Map Segment (Map EndSegment ([String] -> Bool, a))
    -> Maybe ([String], a))
-> Maybe ([String], a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [String]
-> Method
-> [String]
-> RouteTree ([String] -> Bool, a)
-> Maybe ([String], a)
forall a.
[String]
-> Method
-> [String]
-> RouteTree ([String] -> Bool, a)
-> Maybe ([String], a)
dispatch' [String]
params Method
m [String]
ps' (RouteTree ([String] -> Bool, a) -> Maybe ([String], a))
-> (TrieMap Map Segment (Map EndSegment ([String] -> Bool, a))
    -> RouteTree ([String] -> Bool, a))
-> TrieMap Map Segment (Map EndSegment ([String] -> Bool, a))
-> Maybe ([String], a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TrieMap Map Segment (Map EndSegment ([String] -> Bool, a))
-> RouteTree ([String] -> Bool, a)
forall a. TrieMap Map Segment (Map EndSegment a) -> RouteTree a
R)
              Maybe ([String], a) -> Maybe ([String], a) -> Maybe ([String], a)
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` ((Segment
-> Map
     Segment
     (TrieMap Map Segment (Map EndSegment ([String] -> Bool, a)))
-> Maybe
     (TrieMap Map Segment (Map EndSegment ([String] -> Bool, a)))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Segment
ParamS) (TrieMap Map Segment (Map EndSegment ([String] -> Bool, a))
-> Map
     Segment
     (TrieMap Map Segment (Map EndSegment ([String] -> Bool, a)))
forall (map :: * -> * -> *) k a.
Map map k =>
TrieMap map k a -> map k (TrieMap map k a)
Trie.children1 TrieMap Map Segment (Map EndSegment ([String] -> Bool, a))
t)) Maybe (TrieMap Map Segment (Map EndSegment ([String] -> Bool, a)))
-> (TrieMap Map Segment (Map EndSegment ([String] -> Bool, a))
    -> Maybe ([String], a))
-> Maybe ([String], a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [String]
-> Method
-> [String]
-> RouteTree ([String] -> Bool, a)
-> Maybe ([String], a)
forall a.
[String]
-> Method
-> [String]
-> RouteTree ([String] -> Bool, a)
-> Maybe ([String], a)
dispatch' ([String]
params [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
p]) Method
m [String]
ps' (RouteTree ([String] -> Bool, a) -> Maybe ([String], a))
-> (TrieMap Map Segment (Map EndSegment ([String] -> Bool, a))
    -> RouteTree ([String] -> Bool, a))
-> TrieMap Map Segment (Map EndSegment ([String] -> Bool, a))
-> Maybe ([String], a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TrieMap Map Segment (Map EndSegment ([String] -> Bool, a))
-> RouteTree ([String] -> Bool, a)
forall a. TrieMap Map Segment (Map EndSegment a) -> RouteTree a
R)
  dChildren []      = Maybe ([String], a)
forall a. Maybe a
Nothing
  dNode :: Maybe a
  dNode :: Maybe a
dNode = do
    -- Find a handler that does not need any more segments
    Map EndSegment ([String] -> Bool, a)
em <- [Segment]
-> TrieMap Map Segment (Map EndSegment ([String] -> Bool, a))
-> Maybe (Map EndSegment ([String] -> Bool, a))
forall (map :: * -> * -> *) k a.
Map map k =>
[k] -> TrieMap map k a -> Maybe a
Trie.lookup [] TrieMap Map Segment (Map EndSegment ([String] -> Bool, a))
t
    -- Select one that matches number of parameters or one that will ignore them (created with 'remainingPath')
    ([String] -> Bool
ac,a
h)  <- (EndSegment
-> Map EndSegment ([String] -> Bool, a)
-> Maybe ([String] -> Bool, a)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Int -> Maybe Int
forall a. a -> Maybe a
Just ([String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
ps Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
params), Method
m) Map EndSegment ([String] -> Bool, a)
em) Maybe ([String] -> Bool, a)
-> Maybe ([String] -> Bool, a) -> Maybe ([String] -> Bool, a)
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` (EndSegment
-> Map EndSegment ([String] -> Bool, a)
-> Maybe ([String] -> Bool, a)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Maybe Int
forall a. Maybe a
Nothing, Method
m) Map EndSegment ([String] -> Bool, a)
em)
    -- Make sure that params can converted with fromReqURI
    if ([String] -> Bool
ac ([String]
params [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
ps))
     then a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return a
h
     else Maybe a
forall a. Maybe a
Nothing