{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Network.Wai.Routing.Route
( Routes
, App
, Config (..)
, Continue
, Meta (..)
, prepare
, route
, routeWith
, continue
, addRoute
, attach
, examine
, get
, Network.Wai.Routing.Route.head
, post
, put
, delete
, trace
, options
, connect
, patch
, Renderer
, renderer
, Tree
, Tree.toList
, Tree.foldTree
, Tree.mapTree
, Tree.Payload
, Tree.path
, Tree.value
) where
import Control.Applicative hiding (Const)
import Control.Monad
import Control.Monad.Trans.State.Strict hiding (get, put)
import Data.ByteString (ByteString)
import Data.Default
import Data.Either
import Data.Function
import Data.List hiding (head, delete)
import Data.Maybe (mapMaybe, catMaybes)
import Data.Monoid
import Network.HTTP.Types
import Network.Wai
import Network.Wai.Predicate hiding (def)
import Network.Wai.Predicate.Request
import Network.Wai.Route.Tree (Tree)
import Network.Wai.Routing.Request
import Prelude
import qualified Data.ByteString.Char8 as C
import qualified Data.ByteString.Lazy as Lazy
import qualified Data.List as L
import qualified Network.Wai.Route.Tree as Tree
data Route a m = Route
{ forall a (m :: * -> *). Route a m -> ByteString
_method :: !Method
, forall a (m :: * -> *). Route a m -> ByteString
_path :: !ByteString
, forall a (m :: * -> *). Route a m -> Maybe a
_meta :: Maybe a
, forall a (m :: * -> *). Route a m -> Pack m
_pred :: Pack m
}
data Handler m = Handler
{ forall (m :: * -> *). Handler m -> Double
_delta :: !Double
, forall (m :: * -> *). Handler m -> m ResponseReceived
_handler :: m ResponseReceived
}
data Config = Config
{ Config -> Response
notFoundResponse :: !Response
}
instance Default Config where
def :: Config
def = Response -> Config
Config (Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
status404 [] ByteString
Lazy.empty)
data Pack m where
Pack :: Predicate RoutingReq Error a
-> (a -> Continue m -> m ResponseReceived)
-> Pack m
type Continue m = Response -> m ResponseReceived
type App m = RoutingReq -> Continue m -> m ResponseReceived
type Renderer = Error -> Maybe (Lazy.ByteString, ResponseHeaders)
data Meta a = Meta
{ forall a. Meta a -> ByteString
routeMethod :: !Method
, forall a. Meta a -> ByteString
routePath :: !ByteString
, forall a. Meta a -> a
routeMeta :: a
}
renderer :: Renderer -> Routes a m ()
renderer :: forall a (m :: * -> *). Renderer -> Routes a m ()
renderer Renderer
f = State (St a m) () -> Routes a m ()
forall a (m :: * -> *) b. State (St a m) b -> Routes a m b
Routes (State (St a m) () -> Routes a m ())
-> ((St a m -> St a m) -> State (St a m) ())
-> (St a m -> St a m)
-> Routes a m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (St a m -> St a m) -> State (St a m) ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify ((St a m -> St a m) -> Routes a m ())
-> (St a m -> St a m) -> Routes a m ()
forall a b. (a -> b) -> a -> b
$ \St a m
s -> St a m
s { renderfn = f }
defRenderer :: Renderer
defRenderer :: Renderer
defRenderer Error
e =
let r :: Maybe ByteString
r = Reason -> ByteString
forall {a}. IsString a => Reason -> a
reason2str (Reason -> ByteString) -> Maybe Reason -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Error -> Maybe Reason
reason Error
e
s :: Maybe ByteString
s = ByteString -> ByteString
source2str (ByteString -> ByteString) -> Maybe ByteString -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Error -> Maybe ByteString
source Error
e
m :: Maybe ByteString
m = ByteString -> ByteString
message2str (ByteString -> ByteString) -> Maybe ByteString -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Error -> Maybe ByteString
message Error
e
l :: Maybe ByteString
l = [ByteString] -> Maybe ByteString
labels2str ([ByteString] -> Maybe ByteString)
-> ([ByteString] -> [ByteString])
-> [ByteString]
-> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> ByteString) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> ByteString
Lazy.fromStrict ([ByteString] -> Maybe ByteString)
-> [ByteString] -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Error -> [ByteString]
labels Error
e
x :: Maybe ByteString
x = case [Maybe ByteString] -> [ByteString]
forall a. [Maybe a] -> [a]
catMaybes [Maybe ByteString
s, Maybe ByteString
r, Maybe ByteString
l] of
[] -> Maybe ByteString
forall a. Maybe a
Nothing
[ByteString]
xs -> ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> [ByteString] -> ByteString
Lazy.intercalate ByteString
" " [ByteString]
xs)
in ByteString -> (ByteString, ResponseHeaders)
forall {b} {a}. IsString b => a -> (a, [(HeaderName, b)])
plainText (ByteString -> (ByteString, ResponseHeaders))
-> Maybe ByteString -> Maybe (ByteString, ResponseHeaders)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ByteString
-> (ByteString -> Maybe ByteString)
-> Maybe ByteString
-> Maybe ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe ByteString
x (\ByteString
y -> (ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> (ByteString
" -- " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
y)) (ByteString -> ByteString) -> Maybe ByteString -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ByteString
x) Maybe ByteString
m
where
reason2str :: Reason -> a
reason2str Reason
NotAvailable = a
"not-available"
reason2str Reason
TypeError = a
"type-error"
source2str :: ByteString -> ByteString
source2str ByteString
s = ByteString
"'" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
Lazy.fromStrict ByteString
s ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"'"
message2str :: ByteString -> ByteString
message2str ByteString
s = ByteString -> ByteString
Lazy.fromStrict ByteString
s
labels2str :: [ByteString] -> Maybe ByteString
labels2str [] = Maybe ByteString
forall a. Maybe a
Nothing
labels2str [ByteString]
xs = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
"[" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> [ByteString] -> ByteString
Lazy.intercalate ByteString
"," [ByteString]
xs ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"]"
plainText :: a -> (a, [(HeaderName, b)])
plainText a
s = (a
s, [(HeaderName
hContentType, b
"text/plain")])
data St a m = St
{ forall a (m :: * -> *). St a m -> [Route a m]
routes :: [Route a m]
, forall a (m :: * -> *). St a m -> Renderer
renderfn :: Renderer
}
zero :: St a m
zero :: forall a (m :: * -> *). St a m
zero = [Route a m] -> Renderer -> St a m
forall a (m :: * -> *). [Route a m] -> Renderer -> St a m
St [] Renderer
defRenderer
newtype Routes a m b = Routes { forall a (m :: * -> *) b. Routes a m b -> State (St a m) b
_unroutes :: State (St a m) b }
instance Functor (Routes a m) where
fmap :: forall a b. (a -> b) -> Routes a m a -> Routes a m b
fmap = (a -> b) -> Routes a m a -> Routes a m b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM
instance Applicative (Routes a m) where
pure :: forall a. a -> Routes a m a
pure = a -> Routes a m a
forall a. a -> Routes a m a
forall (m :: * -> *) a. Monad m => a -> m a
return
<*> :: forall a b. Routes a m (a -> b) -> Routes a m a -> Routes a m b
(<*>) = Routes a m (a -> b) -> Routes a m a -> Routes a m b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
instance Monad (Routes a m) where
return :: forall a. a -> Routes a m a
return = State (St a m) a -> Routes a m a
forall a (m :: * -> *) b. State (St a m) b -> Routes a m b
Routes (State (St a m) a -> Routes a m a)
-> (a -> State (St a m) a) -> a -> Routes a m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> State (St a m) a
forall a. a -> StateT (St a m) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return
Routes a m a
m >>= :: forall a b. Routes a m a -> (a -> Routes a m b) -> Routes a m b
>>= a -> Routes a m b
f = State (St a m) b -> Routes a m b
forall a (m :: * -> *) b. State (St a m) b -> Routes a m b
Routes (State (St a m) b -> Routes a m b)
-> State (St a m) b -> Routes a m b
forall a b. (a -> b) -> a -> b
$ Routes a m a -> State (St a m) a
forall a (m :: * -> *) b. Routes a m b -> State (St a m) b
_unroutes Routes a m a
m State (St a m) a -> (a -> State (St a m) b) -> State (St a m) b
forall a b.
StateT (St a m) Identity a
-> (a -> StateT (St a m) Identity b) -> StateT (St a m) Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Routes a m b -> State (St a m) b
forall a (m :: * -> *) b. Routes a m b -> State (St a m) b
_unroutes (Routes a m b -> State (St a m) b)
-> (a -> Routes a m b) -> a -> State (St a m) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Routes a m b
f
addRoute :: Monad m
=> Method
-> ByteString
-> (a -> Continue m -> m ResponseReceived)
-> Predicate RoutingReq Error a
-> Routes b m ()
addRoute :: forall (m :: * -> *) a b.
Monad m =>
ByteString
-> ByteString
-> (a -> Continue m -> m ResponseReceived)
-> Predicate RoutingReq Error a
-> Routes b m ()
addRoute ByteString
m ByteString
r a -> Continue m -> m ResponseReceived
x Predicate RoutingReq Error a
p = State (St b m) () -> Routes b m ()
forall a (m :: * -> *) b. State (St a m) b -> Routes a m b
Routes (State (St b m) () -> Routes b m ())
-> ((St b m -> St b m) -> State (St b m) ())
-> (St b m -> St b m)
-> Routes b m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (St b m -> St b m) -> State (St b m) ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify ((St b m -> St b m) -> Routes b m ())
-> (St b m -> St b m) -> Routes b m ()
forall a b. (a -> b) -> a -> b
$ \St b m
s ->
St b m
s { routes = Route m r Nothing (Pack p x) : routes s }
get, head, post, put, delete, trace, options, connect, patch ::
Monad m
=> ByteString
-> (a -> Continue m -> m ResponseReceived)
-> Predicate RoutingReq Error a
-> Routes b m ()
get :: forall (m :: * -> *) a b.
Monad m =>
ByteString
-> (a -> Continue m -> m ResponseReceived)
-> Predicate RoutingReq Error a
-> Routes b m ()
get = ByteString
-> ByteString
-> (a -> Continue m -> m ResponseReceived)
-> Predicate RoutingReq Error a
-> Routes b m ()
forall (m :: * -> *) a b.
Monad m =>
ByteString
-> ByteString
-> (a -> Continue m -> m ResponseReceived)
-> Predicate RoutingReq Error a
-> Routes b m ()
addRoute (StdMethod -> ByteString
renderStdMethod StdMethod
GET)
head :: forall (m :: * -> *) a b.
Monad m =>
ByteString
-> (a -> Continue m -> m ResponseReceived)
-> Predicate RoutingReq Error a
-> Routes b m ()
head = ByteString
-> ByteString
-> (a -> Continue m -> m ResponseReceived)
-> Predicate RoutingReq Error a
-> Routes b m ()
forall (m :: * -> *) a b.
Monad m =>
ByteString
-> ByteString
-> (a -> Continue m -> m ResponseReceived)
-> Predicate RoutingReq Error a
-> Routes b m ()
addRoute (StdMethod -> ByteString
renderStdMethod StdMethod
HEAD)
post :: forall (m :: * -> *) a b.
Monad m =>
ByteString
-> (a -> Continue m -> m ResponseReceived)
-> Predicate RoutingReq Error a
-> Routes b m ()
post = ByteString
-> ByteString
-> (a -> Continue m -> m ResponseReceived)
-> Predicate RoutingReq Error a
-> Routes b m ()
forall (m :: * -> *) a b.
Monad m =>
ByteString
-> ByteString
-> (a -> Continue m -> m ResponseReceived)
-> Predicate RoutingReq Error a
-> Routes b m ()
addRoute (StdMethod -> ByteString
renderStdMethod StdMethod
POST)
put :: forall (m :: * -> *) a b.
Monad m =>
ByteString
-> (a -> Continue m -> m ResponseReceived)
-> Predicate RoutingReq Error a
-> Routes b m ()
put = ByteString
-> ByteString
-> (a -> Continue m -> m ResponseReceived)
-> Predicate RoutingReq Error a
-> Routes b m ()
forall (m :: * -> *) a b.
Monad m =>
ByteString
-> ByteString
-> (a -> Continue m -> m ResponseReceived)
-> Predicate RoutingReq Error a
-> Routes b m ()
addRoute (StdMethod -> ByteString
renderStdMethod StdMethod
PUT)
delete :: forall (m :: * -> *) a b.
Monad m =>
ByteString
-> (a -> Continue m -> m ResponseReceived)
-> Predicate RoutingReq Error a
-> Routes b m ()
delete = ByteString
-> ByteString
-> (a -> Continue m -> m ResponseReceived)
-> Predicate RoutingReq Error a
-> Routes b m ()
forall (m :: * -> *) a b.
Monad m =>
ByteString
-> ByteString
-> (a -> Continue m -> m ResponseReceived)
-> Predicate RoutingReq Error a
-> Routes b m ()
addRoute (StdMethod -> ByteString
renderStdMethod StdMethod
DELETE)
trace :: forall (m :: * -> *) a b.
Monad m =>
ByteString
-> (a -> Continue m -> m ResponseReceived)
-> Predicate RoutingReq Error a
-> Routes b m ()
trace = ByteString
-> ByteString
-> (a -> Continue m -> m ResponseReceived)
-> Predicate RoutingReq Error a
-> Routes b m ()
forall (m :: * -> *) a b.
Monad m =>
ByteString
-> ByteString
-> (a -> Continue m -> m ResponseReceived)
-> Predicate RoutingReq Error a
-> Routes b m ()
addRoute (StdMethod -> ByteString
renderStdMethod StdMethod
TRACE)
options :: forall (m :: * -> *) a b.
Monad m =>
ByteString
-> (a -> Continue m -> m ResponseReceived)
-> Predicate RoutingReq Error a
-> Routes b m ()
options = ByteString
-> ByteString
-> (a -> Continue m -> m ResponseReceived)
-> Predicate RoutingReq Error a
-> Routes b m ()
forall (m :: * -> *) a b.
Monad m =>
ByteString
-> ByteString
-> (a -> Continue m -> m ResponseReceived)
-> Predicate RoutingReq Error a
-> Routes b m ()
addRoute (StdMethod -> ByteString
renderStdMethod StdMethod
OPTIONS)
connect :: forall (m :: * -> *) a b.
Monad m =>
ByteString
-> (a -> Continue m -> m ResponseReceived)
-> Predicate RoutingReq Error a
-> Routes b m ()
connect = ByteString
-> ByteString
-> (a -> Continue m -> m ResponseReceived)
-> Predicate RoutingReq Error a
-> Routes b m ()
forall (m :: * -> *) a b.
Monad m =>
ByteString
-> ByteString
-> (a -> Continue m -> m ResponseReceived)
-> Predicate RoutingReq Error a
-> Routes b m ()
addRoute (StdMethod -> ByteString
renderStdMethod StdMethod
CONNECT)
patch :: forall (m :: * -> *) a b.
Monad m =>
ByteString
-> (a -> Continue m -> m ResponseReceived)
-> Predicate RoutingReq Error a
-> Routes b m ()
patch = ByteString
-> ByteString
-> (a -> Continue m -> m ResponseReceived)
-> Predicate RoutingReq Error a
-> Routes b m ()
forall (m :: * -> *) a b.
Monad m =>
ByteString
-> ByteString
-> (a -> Continue m -> m ResponseReceived)
-> Predicate RoutingReq Error a
-> Routes b m ()
addRoute (StdMethod -> ByteString
renderStdMethod StdMethod
PATCH)
attach :: a -> Routes a m ()
attach :: forall a (m :: * -> *). a -> Routes a m ()
attach a
a = State (St a m) () -> Routes a m ()
forall a (m :: * -> *) b. State (St a m) b -> Routes a m b
Routes (State (St a m) () -> Routes a m ())
-> State (St a m) () -> Routes a m ()
forall a b. (a -> b) -> a -> b
$ (St a m -> St a m) -> State (St a m) ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify St a m -> St a m
addToLast
where
addToLast :: St a m -> St a m
addToLast s :: St a m
s@(St [] Renderer
_) = St a m
s
addToLast (St (Route a m
r:[Route a m]
rr) Renderer
f) = [Route a m] -> Renderer -> St a m
forall a (m :: * -> *). [Route a m] -> Renderer -> St a m
St (Route a m
r { _meta = Just a } Route a m -> [Route a m] -> [Route a m]
forall a. a -> [a] -> [a]
: [Route a m]
rr) Renderer
f
examine :: Routes a m b -> [Meta a]
examine :: forall a (m :: * -> *) b. Routes a m b -> [Meta a]
examine (Routes State (St a m) b
r) = let St [Route a m]
rr Renderer
_ = State (St a m) b -> St a m -> St a m
forall s a. State s a -> s -> s
execState State (St a m) b
r St a m
forall a (m :: * -> *). St a m
zero in
(Route a m -> Maybe (Meta a)) -> [Route a m] -> [Meta a]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\Route a m
x -> ByteString -> ByteString -> a -> Meta a
forall a. ByteString -> ByteString -> a -> Meta a
Meta (Route a m -> ByteString
forall a (m :: * -> *). Route a m -> ByteString
_method Route a m
x) (Route a m -> ByteString
forall a (m :: * -> *). Route a m -> ByteString
_path Route a m
x) (a -> Meta a) -> Maybe a -> Maybe (Meta a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Route a m -> Maybe a
forall a (m :: * -> *). Route a m -> Maybe a
_meta Route a m
x) [Route a m]
rr
route :: Monad m => Tree (App m) -> Request -> Continue m -> m ResponseReceived
route :: forall (m :: * -> *).
Monad m =>
Tree (App m) -> Request -> Continue m -> m ResponseReceived
route = Config
-> Tree (App m) -> Request -> Continue m -> m ResponseReceived
forall (m :: * -> *).
Monad m =>
Config
-> Tree (App m) -> Request -> Continue m -> m ResponseReceived
routeWith Config
forall a. Default a => a
def
routeWith :: Monad m => Config -> Tree (App m) -> Request -> Continue m -> m ResponseReceived
routeWith :: forall (m :: * -> *).
Monad m =>
Config
-> Tree (App m) -> Request -> Continue m -> m ResponseReceived
routeWith Config
cfg Tree (App m)
tr Request
rq Continue m
k =
case Tree (App m) -> [ByteString] -> Maybe (Payload (App m))
forall a. Tree a -> [ByteString] -> Maybe (Payload a)
Tree.lookup Tree (App m)
tr (ByteString -> [ByteString]
Tree.segments (ByteString -> [ByteString]) -> ByteString -> [ByteString]
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
rawPathInfo Request
rq) of
Just Payload (App m)
e -> Payload (App m) -> App m
forall a. Payload a -> a
Tree.value Payload (App m)
e ([(ByteString, ByteString)] -> Req -> RoutingReq
fromReq (Captures -> [(ByteString, ByteString)]
Tree.captured (Captures -> [(ByteString, ByteString)])
-> Captures -> [(ByteString, ByteString)]
forall a b. (a -> b) -> a -> b
$ Payload (App m) -> Captures
forall a. Payload a -> Captures
Tree.captures Payload (App m)
e) (Request -> Req
fromRequest Request
rq)) Continue m
k
Maybe (Payload (App m))
Nothing -> Continue m
k (Config -> Response
notFoundResponse Config
cfg)
continue :: Monad m => (a -> m Response) -> a -> Continue m -> m ResponseReceived
continue :: forall (m :: * -> *) a.
Monad m =>
(a -> m Response) -> a -> Continue m -> m ResponseReceived
continue a -> m Response
f a
a Continue m
k = a -> m Response
f a
a m Response -> Continue m -> m ResponseReceived
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Continue m
k
{-# INLINE continue #-}
prepare :: Monad m => Routes a m b -> Tree (App m)
prepare :: forall (m :: * -> *) a b. Monad m => Routes a m b -> Tree (App m)
prepare (Routes State (St a m) b
rr) =
let s :: St a m
s = State (St a m) b -> St a m -> St a m
forall s a. State s a -> s -> s
execState State (St a m) b
rr St a m
forall a (m :: * -> *). St a m
zero
r :: [[Route a m]]
r = [Route a m] -> [[Route a m]]
forall a (m :: * -> *). [Route a m] -> [[Route a m]]
normalise (St a m -> [Route a m]
forall a (m :: * -> *). St a m -> [Route a m]
routes St a m
s)
in [(ByteString, App m)] -> Tree (App m)
forall a. [(ByteString, a)] -> Tree a
Tree.fromList ([(ByteString, App m)] -> Tree (App m))
-> [(ByteString, App m)] -> Tree (App m)
forall a b. (a -> b) -> a -> b
$ ([Route a m] -> (ByteString, App m))
-> [[Route a m]] -> [(ByteString, App m)]
forall a b. (a -> b) -> [a] -> [b]
map (\[Route a m]
g -> (Route a m -> ByteString
forall a (m :: * -> *). Route a m -> ByteString
_path ([Route a m] -> Route a m
forall a. HasCallStack => [a] -> a
L.head [Route a m]
g), Renderer -> [Route a m] -> App m
forall a (m :: * -> *). Monad m => Renderer -> [Route a m] -> App m
select (St a m -> Renderer
forall a (m :: * -> *). St a m -> Renderer
renderfn St a m
s) [Route a m]
g)) [[Route a m]]
r
normalise :: [Route a m] -> [[Route a m]]
normalise :: forall a (m :: * -> *). [Route a m] -> [[Route a m]]
normalise [Route a m]
rr =
let rg :: [[Route a m]]
rg = [Route a m] -> [[Route a m]]
forall a (m :: * -> *). [Route a m] -> [[Route a m]]
grouped ([Route a m] -> [[Route a m]])
-> ([Route a m] -> [Route a m]) -> [Route a m] -> [[Route a m]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Route a m] -> [Route a m]
forall a (m :: * -> *). [Route a m] -> [Route a m]
sorted ([Route a m] -> [[Route a m]]) -> [Route a m] -> [[Route a m]]
forall a b. (a -> b) -> a -> b
$ [Route a m]
rr
paths :: [ByteString]
paths = ([Route a m] -> ByteString) -> [[Route a m]] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (Route a m -> ByteString
forall a (m :: * -> *). Route a m -> ByteString
namelessPath (Route a m -> ByteString)
-> ([Route a m] -> Route a m) -> [Route a m] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Route a m] -> Route a m
forall a. HasCallStack => [a] -> a
L.head) [[Route a m]]
rg
ambig :: [ByteString]
ambig = [ByteString]
paths [ByteString] -> [ByteString] -> [ByteString]
forall a. Eq a => [a] -> [a] -> [a]
\\ [ByteString] -> [ByteString]
forall a. Eq a => [a] -> [a]
nub [ByteString]
paths
in if [ByteString] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ByteString]
ambig then [[Route a m]]
rg else [Char] -> [[Route a m]]
forall a. HasCallStack => [Char] -> a
error ([ByteString] -> [Char]
forall {a}. Show a => a -> [Char]
ambiguityMessage [ByteString]
ambig)
where
sorted :: [Route a m] -> [Route a m]
sorted :: forall a (m :: * -> *). [Route a m] -> [Route a m]
sorted = (Route a m -> Route a m -> Ordering) -> [Route a m] -> [Route a m]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (ByteString -> ByteString -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (ByteString -> ByteString -> Ordering)
-> (Route a m -> ByteString) -> Route a m -> Route a m -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Route a m -> ByteString
forall a (m :: * -> *). Route a m -> ByteString
_path)
grouped :: [Route a m] -> [[Route a m]]
grouped :: forall a (m :: * -> *). [Route a m] -> [[Route a m]]
grouped = (Route a m -> Route a m -> Bool) -> [Route a m] -> [[Route a m]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
(==) (ByteString -> ByteString -> Bool)
-> (Route a m -> ByteString) -> Route a m -> Route a m -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Route a m -> ByteString
forall a (m :: * -> *). Route a m -> ByteString
_path)
namelessPath :: Route a m -> ByteString
namelessPath :: forall a (m :: * -> *). Route a m -> ByteString
namelessPath =
let fun :: ByteString -> ByteString
fun ByteString
s = if ByteString
s ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
"" Bool -> Bool -> Bool
&& ByteString -> Char
C.head ByteString
s Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':' then ByteString
"<>" else ByteString
s
in ByteString -> [ByteString] -> ByteString
C.intercalate ByteString
"/" ([ByteString] -> ByteString)
-> (Route a m -> [ByteString]) -> Route a m -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> ByteString) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> ByteString
fun ([ByteString] -> [ByteString])
-> (Route a m -> [ByteString]) -> Route a m -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ByteString -> [ByteString]
C.split Char
'/' (ByteString -> [ByteString])
-> (Route a m -> ByteString) -> Route a m -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Route a m -> ByteString
forall a (m :: * -> *). Route a m -> ByteString
_path
ambiguityMessage :: a -> [Char]
ambiguityMessage a
a =
[Char]
"Paths differing only in variable names are not supported.\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
[Char]
"Problematic paths (with variable positions denoted by <>):\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
a -> [Char]
forall {a}. Show a => a -> [Char]
show a
a
select :: forall a m. Monad m => Renderer -> [Route a m] -> App m
select :: forall a (m :: * -> *). Monad m => Renderer -> [Route a m] -> App m
select Renderer
render [Route a m]
rr RoutingReq
req Continue m
k = do
let ms :: [Route a m]
ms = (Route a m -> Bool) -> [Route a m] -> [Route a m]
forall a. (a -> Bool) -> [a] -> [a]
filter ((RoutingReq -> ByteString
forall a. HasMethod a => a -> ByteString
method RoutingReq
req ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
==) (ByteString -> Bool)
-> (Route a m -> ByteString) -> Route a m -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Route a m -> ByteString
forall a (m :: * -> *). Route a m -> ByteString
_method) [Route a m]
rr
if [Route a m] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Route a m]
ms
then Continue m
k Continue m -> Continue m
forall a b. (a -> b) -> a -> b
$ Renderer -> Error -> ResponseHeaders -> Response
respond Renderer
render Error
e405 [(HeaderName
allow, ByteString
validMethods)]
else [Route a m] -> m ResponseReceived
evalAll [Route a m]
ms
where
evalAll :: [Route a m] -> m ResponseReceived
evalAll :: [Route a m] -> m ResponseReceived
evalAll [Route a m]
rs =
let ([Error]
n, [Handler m]
y) = [Either Error (Handler m)] -> ([Error], [Handler m])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either Error (Handler m)] -> ([Error], [Handler m]))
-> [Either Error (Handler m)] -> ([Error], [Handler m])
forall a b. (a -> b) -> a -> b
$ ([Either Error (Handler m)]
-> Route a m -> [Either Error (Handler m)])
-> [Either Error (Handler m)]
-> [Route a m]
-> [Either Error (Handler m)]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' [Either Error (Handler m)]
-> Route a m -> [Either Error (Handler m)]
evalSingle [] [Route a m]
rs
in if [Handler m] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Handler m]
y
then Continue m
k Continue m -> Continue m
forall a b. (a -> b) -> a -> b
$ Renderer -> Error -> ResponseHeaders -> Response
respond Renderer
render ([Error] -> Error
forall a. HasCallStack => [a] -> a
L.head [Error]
n) []
else [Handler m] -> m ResponseReceived
closest [Handler m]
y
evalSingle :: [Either Error (Handler m)] -> Route a m -> [Either Error (Handler m)]
evalSingle :: [Either Error (Handler m)]
-> Route a m -> [Either Error (Handler m)]
evalSingle [Either Error (Handler m)]
rs Route a m
r =
case Route a m -> Pack m
forall a (m :: * -> *). Route a m -> Pack m
_pred Route a m
r of
Pack Predicate RoutingReq Error a
p a -> Continue m -> m ResponseReceived
h -> case Predicate RoutingReq Error a
p RoutingReq
req of
Fail Error
m -> Error -> Either Error (Handler m)
forall a b. a -> Either a b
Left Error
m Either Error (Handler m)
-> [Either Error (Handler m)] -> [Either Error (Handler m)]
forall a. a -> [a] -> [a]
: [Either Error (Handler m)]
rs
Okay Double
d a
v -> Handler m -> Either Error (Handler m)
forall a b. b -> Either a b
Right (Double -> m ResponseReceived -> Handler m
forall (m :: * -> *). Double -> m ResponseReceived -> Handler m
Handler Double
d (a -> Continue m -> m ResponseReceived
h a
v Continue m
k)) Either Error (Handler m)
-> [Either Error (Handler m)] -> [Either Error (Handler m)]
forall a. a -> [a] -> [a]
: [Either Error (Handler m)]
rs
closest :: [Handler m] -> m ResponseReceived
closest :: [Handler m] -> m ResponseReceived
closest [Handler m]
hh = case (Handler m -> m ResponseReceived)
-> [Handler m] -> [m ResponseReceived]
forall a b. (a -> b) -> [a] -> [b]
map Handler m -> m ResponseReceived
forall (m :: * -> *). Handler m -> m ResponseReceived
_handler ([Handler m] -> [m ResponseReceived])
-> ([Handler m] -> [Handler m])
-> [Handler m]
-> [m ResponseReceived]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Handler m -> Handler m -> Ordering) -> [Handler m] -> [Handler m]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Double -> Double -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Double -> Double -> Ordering)
-> (Handler m -> Double) -> Handler m -> Handler m -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Handler m -> Double
forall (m :: * -> *). Handler m -> Double
_delta) ([Handler m] -> [m ResponseReceived])
-> [Handler m] -> [m ResponseReceived]
forall a b. (a -> b) -> a -> b
$ [Handler m]
hh of
[] -> Continue m
k Continue m -> Continue m
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> Builder -> Response
responseBuilder Status
status404 [] Builder
forall a. Monoid a => a
mempty
m ResponseReceived
h:[m ResponseReceived]
_ -> m ResponseReceived
h
validMethods :: ByteString
validMethods :: ByteString
validMethods = ByteString -> [ByteString] -> ByteString
C.intercalate ByteString
"," ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> [ByteString]
forall a. Eq a => [a] -> [a]
nub ([Char] -> ByteString
C.pack ([Char] -> ByteString)
-> (Route a m -> [Char]) -> Route a m -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Char]
forall {a}. Show a => a -> [Char]
show (ByteString -> [Char])
-> (Route a m -> ByteString) -> Route a m -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Route a m -> ByteString
forall a (m :: * -> *). Route a m -> ByteString
_method (Route a m -> ByteString) -> [Route a m] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Route a m]
rr)
allow :: HeaderName
allow :: HeaderName
allow = HeaderName
"Allow"
respond :: Renderer -> Error -> ResponseHeaders -> Response
respond :: Renderer -> Error -> ResponseHeaders -> Response
respond Renderer
f Error
e ResponseHeaders
r = case Renderer
f Error
e of
Just (ByteString
b, ResponseHeaders
h) -> Status -> ResponseHeaders -> ByteString -> Response
responseLBS (Error -> Status
status Error
e) (ResponseHeaders
r ResponseHeaders -> ResponseHeaders -> ResponseHeaders
forall a. [a] -> [a] -> [a]
++ ResponseHeaders
h) ByteString
b
Maybe (ByteString, ResponseHeaders)
Nothing -> Status -> ResponseHeaders -> ByteString -> Response
responseLBS (Error -> Status
status Error
e) ResponseHeaders
r ByteString
Lazy.empty