-- 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/.

{-# 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

      -- * Re-exports
    , 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
    }

-- | Configuration to customize the route handler
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

-- | The WAI 3.0 application continuation for arbitrary @m@ instead of @IO@.
type Continue m = Response -> m ResponseReceived

-- | Similar to a WAI 'Application' but for 'RoutingReq' and not specific
-- to @IO@.
type App m = RoutingReq -> Continue m -> m ResponseReceived

-- | Function to turn an 'Error' value into a 'Lazy.ByteString'
-- to send as the response body and a list of additional response headers.
-- Clients can provide their own renderer using 'renderer'.
type Renderer = Error -> Maybe (Lazy.ByteString, ResponseHeaders)

-- | Data added to a route via 'attach' is returned in this @Meta@ record.
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
    }

-- | Set a custom render function, i.e. a function to turn 'Error's into
-- 'Lazy.ByteString's.
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")])

-- | The Routes monad state type.
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
    }

-- | Initial state.
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

-- | The Routes monad is used to add routing declarations
-- via 'addRoute' or one of 'get', 'post', etc.
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

-- | Add a route for some 'Method' and path (potentially with variable
-- captures) and constrained by some 'Predicate'.
--
-- A route handler is like a WAI 'Application' but instead of 'Request'
-- the first parameter is the result-type of the associated 'Predicate'
-- evaluation. I.e. the handler is applied to the predicate's metadata
-- value iff the predicate is true.
addRoute :: Monad m
         => Method
         -> ByteString                              -- ^ path
         -> (a -> Continue m -> m ResponseReceived) -- ^ handler
         -> Predicate RoutingReq Error a            -- ^ 'Predicate'
         -> 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 }

-- | Specialisation of 'addRoute' for a specific HTTP 'Method'.
get, head, post, put, delete, trace, options, connect, patch ::
    Monad m
    => ByteString                              -- ^ path
    -> (a -> Continue m -> m ResponseReceived) -- ^ handler
    -> Predicate RoutingReq Error a            -- ^ 'Predicate'
    -> 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)

-- | Add some metadata to the last route.
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

-- | Get back all attached metadata.
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

-- | Routes requests to handlers based on predicated route declarations.
-- Note that @route (prepare ...)@ behaves like a WAI 'Application' generalised to
-- arbitrary monads.
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)

-- | Prior to WAI 3.0 applications returned a plain 'Response'. @continue@
-- turns such a function into a corresponding CPS version. For example:
--
-- @
-- sitemap :: Monad m => Routes a m ()
-- sitemap = do
--     get "\/f\/:foo" (/continue/ f) $ capture "foo"
--     get "\/g\/:foo" g            $ capture "foo"
--
-- f :: Monad m => Int -> m Response
-- f x = ...
--
-- g :: Monad m => Int -> Continue m -> m ResponseReceived
-- g x k = k $ ...
-- @
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 #-}

-- | Run the 'Routes' monad and return the handlers per path.
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

-- | Group routes by path.
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

-- The handler selection proceeds as follows:
-- (1) Consider only handlers with matching methods, or else return 405.
-- (2) Evaluate 'Route' predicates.
-- (3) Pick the first one which is 'Good', or else respond with status
--     and message of the first one.
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