{-# LANGUAGE CPP               #-}
{-# LANGUAGE DeriveFunctor     #-}
{-# LANGUAGE GADTs             #-}
{-# LANGUAGE OverloadedStrings #-}
module Servant.Server.Internal.Router where

import           Prelude ()
import           Prelude.Compat

import           Data.Function
                 (on)
import           Data.List
                 (nub)
import           Data.Map
                 (Map)
import qualified Data.Map                                   as M
import           Data.Text
                 (Text)
import qualified Data.Text                                  as T
import           Data.Typeable
                 (TypeRep)
import           Network.Wai
                 (Response, pathInfo)
import           Servant.Server.Internal.ErrorFormatter
import           Servant.Server.Internal.RouteResult
import           Servant.Server.Internal.RoutingApplication
import           Servant.Server.Internal.ServerError

type Router env = Router' env RoutingApplication

data CaptureHint = CaptureHint
  { CaptureHint -> Text
captureName :: Text
  , CaptureHint -> TypeRep
captureType :: TypeRep
  }
  deriving (Int -> CaptureHint -> ShowS
[CaptureHint] -> ShowS
CaptureHint -> String
(Int -> CaptureHint -> ShowS)
-> (CaptureHint -> String)
-> ([CaptureHint] -> ShowS)
-> Show CaptureHint
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CaptureHint] -> ShowS
$cshowList :: [CaptureHint] -> ShowS
show :: CaptureHint -> String
$cshow :: CaptureHint -> String
showsPrec :: Int -> CaptureHint -> ShowS
$cshowsPrec :: Int -> CaptureHint -> ShowS
Show, CaptureHint -> CaptureHint -> Bool
(CaptureHint -> CaptureHint -> Bool)
-> (CaptureHint -> CaptureHint -> Bool) -> Eq CaptureHint
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CaptureHint -> CaptureHint -> Bool
$c/= :: CaptureHint -> CaptureHint -> Bool
== :: CaptureHint -> CaptureHint -> Bool
$c== :: CaptureHint -> CaptureHint -> Bool
Eq)

toCaptureTag :: CaptureHint -> Text
toCaptureTag :: CaptureHint -> Text
toCaptureTag CaptureHint
hint = CaptureHint -> Text
captureName CaptureHint
hint Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"::" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack (String -> Text) -> (TypeRep -> String) -> TypeRep -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeRep -> String
forall a. Show a => a -> String
show) (CaptureHint -> TypeRep
captureType CaptureHint
hint)

toCaptureTags :: [CaptureHint] -> Text
toCaptureTags :: [CaptureHint] -> Text
toCaptureTags [CaptureHint]
hints = Text
"<" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
"|" ((CaptureHint -> Text) -> [CaptureHint] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map CaptureHint -> Text
toCaptureTag [CaptureHint]
hints) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
">"

-- | Internal representation of a router.
--
-- The first argument describes an environment type that is
-- expected as extra input by the routers at the leaves. The
-- environment is filled while running the router, with path
-- components that can be used to process captures.
--
data Router' env a =
    StaticRouter  (Map Text (Router' env a)) [env -> a]
      -- ^ the map contains routers for subpaths (first path component used
      --   for lookup and removed afterwards), the list contains handlers
      --   for the empty path, to be tried in order
  | CaptureRouter [CaptureHint] (Router' (Text, env) a)
      -- ^ first path component is passed to the child router in its
      --   environment and removed afterwards
  | CaptureAllRouter [CaptureHint] (Router' ([Text], env) a)
      -- ^ all path components are passed to the child router in its
      --   environment and are removed afterwards
  | RawRouter     (env -> a)
      -- ^ to be used for routes we do not know anything about
  | Choice        (Router' env a) (Router' env a)
      -- ^ left-biased choice between two routers
  deriving a -> Router' env b -> Router' env a
(a -> b) -> Router' env a -> Router' env b
(forall a b. (a -> b) -> Router' env a -> Router' env b)
-> (forall a b. a -> Router' env b -> Router' env a)
-> Functor (Router' env)
forall a b. a -> Router' env b -> Router' env a
forall a b. (a -> b) -> Router' env a -> Router' env b
forall env a b. a -> Router' env b -> Router' env a
forall env a b. (a -> b) -> Router' env a -> Router' env b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Router' env b -> Router' env a
$c<$ :: forall env a b. a -> Router' env b -> Router' env a
fmap :: (a -> b) -> Router' env a -> Router' env b
$cfmap :: forall env a b. (a -> b) -> Router' env a -> Router' env b
Functor

-- | Smart constructor for a single static path component.
pathRouter :: Text -> Router' env a -> Router' env a
pathRouter :: Text -> Router' env a -> Router' env a
pathRouter Text
t Router' env a
r = Map Text (Router' env a) -> [env -> a] -> Router' env a
forall env a.
Map Text (Router' env a) -> [env -> a] -> Router' env a
StaticRouter (Text -> Router' env a -> Map Text (Router' env a)
forall k a. k -> a -> Map k a
M.singleton Text
t Router' env a
r) []

-- | Smart constructor for a leaf, i.e., a router that expects
-- the empty path.
--
leafRouter :: (env -> a) -> Router' env a
leafRouter :: (env -> a) -> Router' env a
leafRouter env -> a
l = Map Text (Router' env a) -> [env -> a] -> Router' env a
forall env a.
Map Text (Router' env a) -> [env -> a] -> Router' env a
StaticRouter Map Text (Router' env a)
forall k a. Map k a
M.empty [env -> a
l]

-- | Smart constructor for the choice between routers.
-- We currently optimize the following cases:
--
--   * Two static routers can be joined by joining their maps
--     and concatenating their leaf-lists.
--   * Two dynamic routers can be joined by joining their codomains.
--   * Choice nodes can be reordered.
--
choice :: Router' env a -> Router' env a -> Router' env a
choice :: Router' env a -> Router' env a -> Router' env a
choice (StaticRouter Map Text (Router' env a)
table1 [env -> a]
ls1) (StaticRouter Map Text (Router' env a)
table2 [env -> a]
ls2) =
  Map Text (Router' env a) -> [env -> a] -> Router' env a
forall env a.
Map Text (Router' env a) -> [env -> a] -> Router' env a
StaticRouter ((Router' env a -> Router' env a -> Router' env a)
-> Map Text (Router' env a)
-> Map Text (Router' env a)
-> Map Text (Router' env a)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith Router' env a -> Router' env a -> Router' env a
forall env a. Router' env a -> Router' env a -> Router' env a
choice Map Text (Router' env a)
table1 Map Text (Router' env a)
table2) ([env -> a]
ls1 [env -> a] -> [env -> a] -> [env -> a]
forall a. [a] -> [a] -> [a]
++ [env -> a]
ls2)
choice (CaptureRouter [CaptureHint]
hints1 Router' (Text, env) a
router1)   (CaptureRouter [CaptureHint]
hints2 Router' (Text, env) a
router2)   =
  [CaptureHint] -> Router' (Text, env) a -> Router' env a
forall env a.
[CaptureHint] -> Router' (Text, env) a -> Router' env a
CaptureRouter ([CaptureHint] -> [CaptureHint]
forall a. Eq a => [a] -> [a]
nub ([CaptureHint] -> [CaptureHint]) -> [CaptureHint] -> [CaptureHint]
forall a b. (a -> b) -> a -> b
$ [CaptureHint]
hints1 [CaptureHint] -> [CaptureHint] -> [CaptureHint]
forall a. [a] -> [a] -> [a]
++ [CaptureHint]
hints2) (Router' (Text, env) a
-> Router' (Text, env) a -> Router' (Text, env) a
forall env a. Router' env a -> Router' env a -> Router' env a
choice Router' (Text, env) a
router1 Router' (Text, env) a
router2)
choice Router' env a
router1 (Choice Router' env a
router2 Router' env a
router3) = Router' env a -> Router' env a -> Router' env a
forall env a. Router' env a -> Router' env a -> Router' env a
Choice (Router' env a -> Router' env a -> Router' env a
forall env a. Router' env a -> Router' env a -> Router' env a
choice Router' env a
router1 Router' env a
router2) Router' env a
router3
choice Router' env a
router1 Router' env a
router2 = Router' env a -> Router' env a -> Router' env a
forall env a. Router' env a -> Router' env a -> Router' env a
Choice Router' env a
router1 Router' env a
router2

-- | Datatype used for representing and debugging the
-- structure of a router. Abstracts from the handlers
-- at the leaves.
--
-- Two 'Router's can be structurally compared by computing
-- their 'RouterStructure' using 'routerStructure' and
-- then testing for equality, see 'sameStructure'.
--
data RouterStructure =
    StaticRouterStructure  (Map Text RouterStructure) Int
  | CaptureRouterStructure [CaptureHint] RouterStructure
  | RawRouterStructure
  | ChoiceStructure        RouterStructure RouterStructure
  deriving (RouterStructure -> RouterStructure -> Bool
(RouterStructure -> RouterStructure -> Bool)
-> (RouterStructure -> RouterStructure -> Bool)
-> Eq RouterStructure
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RouterStructure -> RouterStructure -> Bool
$c/= :: RouterStructure -> RouterStructure -> Bool
== :: RouterStructure -> RouterStructure -> Bool
$c== :: RouterStructure -> RouterStructure -> Bool
Eq, Int -> RouterStructure -> ShowS
[RouterStructure] -> ShowS
RouterStructure -> String
(Int -> RouterStructure -> ShowS)
-> (RouterStructure -> String)
-> ([RouterStructure] -> ShowS)
-> Show RouterStructure
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RouterStructure] -> ShowS
$cshowList :: [RouterStructure] -> ShowS
show :: RouterStructure -> String
$cshow :: RouterStructure -> String
showsPrec :: Int -> RouterStructure -> ShowS
$cshowsPrec :: Int -> RouterStructure -> ShowS
Show)

-- | Compute the structure of a router.
--
-- Assumes that the request or text being passed
-- in 'WithRequest' or 'CaptureRouter' does not
-- affect the structure of the underlying tree.
--
routerStructure :: Router' env a -> RouterStructure
routerStructure :: Router' env a -> RouterStructure
routerStructure (StaticRouter Map Text (Router' env a)
m [env -> a]
ls) =
  Map Text RouterStructure -> Int -> RouterStructure
StaticRouterStructure ((Router' env a -> RouterStructure)
-> Map Text (Router' env a) -> Map Text RouterStructure
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Router' env a -> RouterStructure
forall env a. Router' env a -> RouterStructure
routerStructure Map Text (Router' env a)
m) ([env -> a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [env -> a]
ls)
routerStructure (CaptureRouter [CaptureHint]
hints Router' (Text, env) a
router) =
  [CaptureHint] -> RouterStructure -> RouterStructure
CaptureRouterStructure [CaptureHint]
hints (RouterStructure -> RouterStructure)
-> RouterStructure -> RouterStructure
forall a b. (a -> b) -> a -> b
$
    Router' (Text, env) a -> RouterStructure
forall env a. Router' env a -> RouterStructure
routerStructure Router' (Text, env) a
router
routerStructure (CaptureAllRouter [CaptureHint]
hints Router' ([Text], env) a
router) =
  [CaptureHint] -> RouterStructure -> RouterStructure
CaptureRouterStructure [CaptureHint]
hints (RouterStructure -> RouterStructure)
-> RouterStructure -> RouterStructure
forall a b. (a -> b) -> a -> b
$
    Router' ([Text], env) a -> RouterStructure
forall env a. Router' env a -> RouterStructure
routerStructure Router' ([Text], env) a
router
routerStructure (RawRouter env -> a
_) =
  RouterStructure
RawRouterStructure
routerStructure (Choice Router' env a
r1 Router' env a
r2) =
  RouterStructure -> RouterStructure -> RouterStructure
ChoiceStructure
    (Router' env a -> RouterStructure
forall env a. Router' env a -> RouterStructure
routerStructure Router' env a
r1)
    (Router' env a -> RouterStructure
forall env a. Router' env a -> RouterStructure
routerStructure Router' env a
r2)

-- | Compare the structure of two routers.
--
sameStructure :: Router' env a -> Router' env b -> Bool
sameStructure :: Router' env a -> Router' env b -> Bool
sameStructure Router' env a
router1 Router' env b
router2 =
    Router' env a -> RouterStructure
forall env a. Router' env a -> RouterStructure
routerStructure Router' env a
router1 RouterStructure -> RouterStructure -> Bool
forall a. Eq a => a -> a -> Bool
== Router' env b -> RouterStructure
forall env a. Router' env a -> RouterStructure
routerStructure Router' env b
router2

-- | Provide a textual representation of the
-- structure of a router.
--
routerLayout :: Router' env a -> Text
routerLayout :: Router' env a -> Text
routerLayout Router' env a
router =
  [Text] -> Text
T.unlines ([Text
"/"] [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Bool -> RouterStructure -> [Text]
mkRouterLayout Bool
False (Router' env a -> RouterStructure
forall env a. Router' env a -> RouterStructure
routerStructure Router' env a
router))
  where
    mkRouterLayout :: Bool -> RouterStructure -> [Text]
    mkRouterLayout :: Bool -> RouterStructure -> [Text]
mkRouterLayout Bool
c (StaticRouterStructure Map Text RouterStructure
m Int
n) = Bool -> [(Text, RouterStructure)] -> Int -> [Text]
mkSubTrees Bool
c (Map Text RouterStructure -> [(Text, RouterStructure)]
forall k a. Map k a -> [(k, a)]
M.toList Map Text RouterStructure
m) Int
n
    mkRouterLayout Bool
c (CaptureRouterStructure [CaptureHint]
hints RouterStructure
r) =
      Bool -> Text -> [Text] -> [Text]
mkSubTree Bool
c ([CaptureHint] -> Text
toCaptureTags [CaptureHint]
hints) (Bool -> RouterStructure -> [Text]
mkRouterLayout Bool
False RouterStructure
r)
    mkRouterLayout Bool
c  RouterStructure
RawRouterStructure         =
      if Bool
c then [Text
"├─ <raw>"] else [Text
"└─ <raw>"]
    mkRouterLayout Bool
c (ChoiceStructure RouterStructure
r1 RouterStructure
r2)     =
      Bool -> RouterStructure -> [Text]
mkRouterLayout Bool
True RouterStructure
r1 [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text
"┆"] [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Bool -> RouterStructure -> [Text]
mkRouterLayout Bool
c RouterStructure
r2

    mkSubTrees :: Bool -> [(Text, RouterStructure)] -> Int -> [Text]
    mkSubTrees :: Bool -> [(Text, RouterStructure)] -> Int -> [Text]
mkSubTrees Bool
_ []             Int
0 = []
    mkSubTrees Bool
c []             Int
n =
      [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Int -> [Text] -> [[Text]]
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Bool -> [Text]
mkLeaf Bool
True) [[Text]] -> [[Text]] -> [[Text]]
forall a. [a] -> [a] -> [a]
++ [Bool -> [Text]
mkLeaf Bool
c])
    mkSubTrees Bool
c [(Text
t, RouterStructure
r)]       Int
0 =
      Bool -> Text -> [Text] -> [Text]
mkSubTree Bool
c    Text
t (Bool -> RouterStructure -> [Text]
mkRouterLayout Bool
False RouterStructure
r)
    mkSubTrees Bool
c ((Text
t, RouterStructure
r) : [(Text, RouterStructure)]
trs) Int
n =
      Bool -> Text -> [Text] -> [Text]
mkSubTree Bool
True Text
t (Bool -> RouterStructure -> [Text]
mkRouterLayout Bool
False RouterStructure
r) [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Bool -> [(Text, RouterStructure)] -> Int -> [Text]
mkSubTrees Bool
c [(Text, RouterStructure)]
trs Int
n

    mkLeaf :: Bool -> [Text]
    mkLeaf :: Bool -> [Text]
mkLeaf Bool
True  = [Text
"├─•",Text
"┆"]
    mkLeaf Bool
False = [Text
"└─•"]

    mkSubTree :: Bool -> Text -> [Text] -> [Text]
    mkSubTree :: Bool -> Text -> [Text] -> [Text]
mkSubTree Bool
True  Text
path [Text]
children = (Text
"├─ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
path Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/") Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text
"│  " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) [Text]
children
    mkSubTree Bool
False Text
path [Text]
children = (Text
"└─ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
path Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/") Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text
"   " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) [Text]
children

-- | Apply a transformation to the response of a `Router`.
tweakResponse :: (RouteResult Response -> RouteResult Response) -> Router env -> Router env
tweakResponse :: (RouteResult Response -> RouteResult Response)
-> Router env -> Router env
tweakResponse RouteResult Response -> RouteResult Response
f = ((Request
  -> (RouteResult Response -> IO ResponseReceived)
  -> IO ResponseReceived)
 -> Request
 -> (RouteResult Response -> IO ResponseReceived)
 -> IO ResponseReceived)
-> Router env -> Router env
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Request
-> (RouteResult Response -> IO ResponseReceived)
-> IO ResponseReceived
a -> \Request
req RouteResult Response -> IO ResponseReceived
cont -> Request
-> (RouteResult Response -> IO ResponseReceived)
-> IO ResponseReceived
a Request
req (RouteResult Response -> IO ResponseReceived
cont (RouteResult Response -> IO ResponseReceived)
-> (RouteResult Response -> RouteResult Response)
-> RouteResult Response
-> IO ResponseReceived
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RouteResult Response -> RouteResult Response
f))

-- | Interpret a router as an application.
runRouter :: NotFoundErrorFormatter -> Router () -> RoutingApplication
runRouter :: NotFoundErrorFormatter
-> Router ()
-> Request
-> (RouteResult Response -> IO ResponseReceived)
-> IO ResponseReceived
runRouter NotFoundErrorFormatter
fmt Router ()
r = NotFoundErrorFormatter
-> Router ()
-> ()
-> Request
-> (RouteResult Response -> IO ResponseReceived)
-> IO ResponseReceived
forall env.
NotFoundErrorFormatter
-> Router env
-> env
-> Request
-> (RouteResult Response -> IO ResponseReceived)
-> IO ResponseReceived
runRouterEnv NotFoundErrorFormatter
fmt Router ()
r ()

runRouterEnv :: NotFoundErrorFormatter -> Router env -> env -> RoutingApplication
runRouterEnv :: NotFoundErrorFormatter
-> Router env
-> env
-> Request
-> (RouteResult Response -> IO ResponseReceived)
-> IO ResponseReceived
runRouterEnv NotFoundErrorFormatter
fmt Router env
router env
env Request
request RouteResult Response -> IO ResponseReceived
respond  =
  case Router env
router of
    StaticRouter Map Text (Router env)
table [env
 -> Request
 -> (RouteResult Response -> IO ResponseReceived)
 -> IO ResponseReceived]
ls ->
      case Request -> [Text]
pathInfo Request
request of
        []   -> NotFoundErrorFormatter
-> [env
    -> Request
    -> (RouteResult Response -> IO ResponseReceived)
    -> IO ResponseReceived]
-> env
-> Request
-> (RouteResult Response -> IO ResponseReceived)
-> IO ResponseReceived
forall env.
NotFoundErrorFormatter
-> [env
    -> Request
    -> (RouteResult Response -> IO ResponseReceived)
    -> IO ResponseReceived]
-> env
-> Request
-> (RouteResult Response -> IO ResponseReceived)
-> IO ResponseReceived
runChoice NotFoundErrorFormatter
fmt [env
 -> Request
 -> (RouteResult Response -> IO ResponseReceived)
 -> IO ResponseReceived]
ls env
env Request
request RouteResult Response -> IO ResponseReceived
respond
        -- This case is to handle trailing slashes.
        [Text
""] -> NotFoundErrorFormatter
-> [env
    -> Request
    -> (RouteResult Response -> IO ResponseReceived)
    -> IO ResponseReceived]
-> env
-> Request
-> (RouteResult Response -> IO ResponseReceived)
-> IO ResponseReceived
forall env.
NotFoundErrorFormatter
-> [env
    -> Request
    -> (RouteResult Response -> IO ResponseReceived)
    -> IO ResponseReceived]
-> env
-> Request
-> (RouteResult Response -> IO ResponseReceived)
-> IO ResponseReceived
runChoice NotFoundErrorFormatter
fmt [env
 -> Request
 -> (RouteResult Response -> IO ResponseReceived)
 -> IO ResponseReceived]
ls env
env Request
request RouteResult Response -> IO ResponseReceived
respond
        Text
first : [Text]
rest | Just Router env
router' <- Text -> Map Text (Router env) -> Maybe (Router env)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
first Map Text (Router env)
table
          -> let request' :: Request
request' = Request
request { pathInfo :: [Text]
pathInfo = [Text]
rest }
             in  NotFoundErrorFormatter
-> Router env
-> env
-> Request
-> (RouteResult Response -> IO ResponseReceived)
-> IO ResponseReceived
forall env.
NotFoundErrorFormatter
-> Router env
-> env
-> Request
-> (RouteResult Response -> IO ResponseReceived)
-> IO ResponseReceived
runRouterEnv NotFoundErrorFormatter
fmt Router env
router' env
env Request
request' RouteResult Response -> IO ResponseReceived
respond
        [Text]
_ -> RouteResult Response -> IO ResponseReceived
respond (RouteResult Response -> IO ResponseReceived)
-> RouteResult Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ ServerError -> RouteResult Response
forall a. ServerError -> RouteResult a
Fail (ServerError -> RouteResult Response)
-> ServerError -> RouteResult Response
forall a b. (a -> b) -> a -> b
$ NotFoundErrorFormatter
fmt Request
request
    CaptureRouter [CaptureHint]
_ Router'
  (Text, env)
  (Request
   -> (RouteResult Response -> IO ResponseReceived)
   -> IO ResponseReceived)
router' ->
      case Request -> [Text]
pathInfo Request
request of
        []   -> RouteResult Response -> IO ResponseReceived
respond (RouteResult Response -> IO ResponseReceived)
-> RouteResult Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ ServerError -> RouteResult Response
forall a. ServerError -> RouteResult a
Fail (ServerError -> RouteResult Response)
-> ServerError -> RouteResult Response
forall a b. (a -> b) -> a -> b
$ NotFoundErrorFormatter
fmt Request
request
        -- This case is to handle trailing slashes.
        [Text
""] -> RouteResult Response -> IO ResponseReceived
respond (RouteResult Response -> IO ResponseReceived)
-> RouteResult Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ ServerError -> RouteResult Response
forall a. ServerError -> RouteResult a
Fail (ServerError -> RouteResult Response)
-> ServerError -> RouteResult Response
forall a b. (a -> b) -> a -> b
$ NotFoundErrorFormatter
fmt Request
request
        Text
first : [Text]
rest
          -> let request' :: Request
request' = Request
request { pathInfo :: [Text]
pathInfo = [Text]
rest }
             in  NotFoundErrorFormatter
-> Router'
     (Text, env)
     (Request
      -> (RouteResult Response -> IO ResponseReceived)
      -> IO ResponseReceived)
-> (Text, env)
-> Request
-> (RouteResult Response -> IO ResponseReceived)
-> IO ResponseReceived
forall env.
NotFoundErrorFormatter
-> Router env
-> env
-> Request
-> (RouteResult Response -> IO ResponseReceived)
-> IO ResponseReceived
runRouterEnv NotFoundErrorFormatter
fmt Router'
  (Text, env)
  (Request
   -> (RouteResult Response -> IO ResponseReceived)
   -> IO ResponseReceived)
router' (Text
first, env
env) Request
request' RouteResult Response -> IO ResponseReceived
respond
    CaptureAllRouter [CaptureHint]
_ Router'
  ([Text], env)
  (Request
   -> (RouteResult Response -> IO ResponseReceived)
   -> IO ResponseReceived)
router' ->
      let segments :: [Text]
segments = Request -> [Text]
pathInfo Request
request
          request' :: Request
request' = Request
request { pathInfo :: [Text]
pathInfo = [] }
      in NotFoundErrorFormatter
-> Router'
     ([Text], env)
     (Request
      -> (RouteResult Response -> IO ResponseReceived)
      -> IO ResponseReceived)
-> ([Text], env)
-> Request
-> (RouteResult Response -> IO ResponseReceived)
-> IO ResponseReceived
forall env.
NotFoundErrorFormatter
-> Router env
-> env
-> Request
-> (RouteResult Response -> IO ResponseReceived)
-> IO ResponseReceived
runRouterEnv NotFoundErrorFormatter
fmt Router'
  ([Text], env)
  (Request
   -> (RouteResult Response -> IO ResponseReceived)
   -> IO ResponseReceived)
router' ([Text]
segments, env
env) Request
request' RouteResult Response -> IO ResponseReceived
respond
    RawRouter env
-> Request
-> (RouteResult Response -> IO ResponseReceived)
-> IO ResponseReceived
app ->
      env
-> Request
-> (RouteResult Response -> IO ResponseReceived)
-> IO ResponseReceived
app env
env Request
request RouteResult Response -> IO ResponseReceived
respond
    Choice Router env
r1 Router env
r2 ->
      NotFoundErrorFormatter
-> [env
    -> Request
    -> (RouteResult Response -> IO ResponseReceived)
    -> IO ResponseReceived]
-> env
-> Request
-> (RouteResult Response -> IO ResponseReceived)
-> IO ResponseReceived
forall env.
NotFoundErrorFormatter
-> [env
    -> Request
    -> (RouteResult Response -> IO ResponseReceived)
    -> IO ResponseReceived]
-> env
-> Request
-> (RouteResult Response -> IO ResponseReceived)
-> IO ResponseReceived
runChoice NotFoundErrorFormatter
fmt [NotFoundErrorFormatter
-> Router env
-> env
-> Request
-> (RouteResult Response -> IO ResponseReceived)
-> IO ResponseReceived
forall env.
NotFoundErrorFormatter
-> Router env
-> env
-> Request
-> (RouteResult Response -> IO ResponseReceived)
-> IO ResponseReceived
runRouterEnv NotFoundErrorFormatter
fmt Router env
r1, NotFoundErrorFormatter
-> Router env
-> env
-> Request
-> (RouteResult Response -> IO ResponseReceived)
-> IO ResponseReceived
forall env.
NotFoundErrorFormatter
-> Router env
-> env
-> Request
-> (RouteResult Response -> IO ResponseReceived)
-> IO ResponseReceived
runRouterEnv NotFoundErrorFormatter
fmt Router env
r2] env
env Request
request RouteResult Response -> IO ResponseReceived
respond

-- | Try a list of routing applications in order.
-- We stop as soon as one fails fatally or succeeds.
-- If all fail normally, we pick the "best" error.
--
runChoice :: NotFoundErrorFormatter -> [env -> RoutingApplication] -> env -> RoutingApplication
runChoice :: NotFoundErrorFormatter
-> [env
    -> Request
    -> (RouteResult Response -> IO ResponseReceived)
    -> IO ResponseReceived]
-> env
-> Request
-> (RouteResult Response -> IO ResponseReceived)
-> IO ResponseReceived
runChoice NotFoundErrorFormatter
fmt [env
 -> Request
 -> (RouteResult Response -> IO ResponseReceived)
 -> IO ResponseReceived]
ls =
  case [env
 -> Request
 -> (RouteResult Response -> IO ResponseReceived)
 -> IO ResponseReceived]
ls of
    []       -> \ env
_ Request
request RouteResult Response -> IO ResponseReceived
respond -> RouteResult Response -> IO ResponseReceived
respond (ServerError -> RouteResult Response
forall a. ServerError -> RouteResult a
Fail (ServerError -> RouteResult Response)
-> ServerError -> RouteResult Response
forall a b. (a -> b) -> a -> b
$ NotFoundErrorFormatter
fmt Request
request)
    [env
-> Request
-> (RouteResult Response -> IO ResponseReceived)
-> IO ResponseReceived
r]      -> env
-> Request
-> (RouteResult Response -> IO ResponseReceived)
-> IO ResponseReceived
r
    (env
-> Request
-> (RouteResult Response -> IO ResponseReceived)
-> IO ResponseReceived
r : [env
 -> Request
 -> (RouteResult Response -> IO ResponseReceived)
 -> IO ResponseReceived]
rs) ->
      \ env
env Request
request RouteResult Response -> IO ResponseReceived
respond ->
      env
-> Request
-> (RouteResult Response -> IO ResponseReceived)
-> IO ResponseReceived
r env
env Request
request ((RouteResult Response -> IO ResponseReceived)
 -> IO ResponseReceived)
-> (RouteResult Response -> IO ResponseReceived)
-> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ \ RouteResult Response
response1 ->
      case RouteResult Response
response1 of
        Fail ServerError
_ -> NotFoundErrorFormatter
-> [env
    -> Request
    -> (RouteResult Response -> IO ResponseReceived)
    -> IO ResponseReceived]
-> env
-> Request
-> (RouteResult Response -> IO ResponseReceived)
-> IO ResponseReceived
forall env.
NotFoundErrorFormatter
-> [env
    -> Request
    -> (RouteResult Response -> IO ResponseReceived)
    -> IO ResponseReceived]
-> env
-> Request
-> (RouteResult Response -> IO ResponseReceived)
-> IO ResponseReceived
runChoice NotFoundErrorFormatter
fmt [env
 -> Request
 -> (RouteResult Response -> IO ResponseReceived)
 -> IO ResponseReceived]
rs env
env Request
request ((RouteResult Response -> IO ResponseReceived)
 -> IO ResponseReceived)
-> (RouteResult Response -> IO ResponseReceived)
-> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ \ RouteResult Response
response2 ->
          RouteResult Response -> IO ResponseReceived
respond (RouteResult Response -> IO ResponseReceived)
-> RouteResult Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ RouteResult Response
-> RouteResult Response -> RouteResult Response
forall a. RouteResult a -> RouteResult a -> RouteResult a
highestPri RouteResult Response
response1 RouteResult Response
response2
        RouteResult Response
_      -> RouteResult Response -> IO ResponseReceived
respond RouteResult Response
response1
  where
    highestPri :: RouteResult a -> RouteResult a -> RouteResult a
highestPri (Fail ServerError
e1) (Fail ServerError
e2) =
      if Int -> Int -> Bool
worseHTTPCode (ServerError -> Int
errHTTPCode ServerError
e1) (ServerError -> Int
errHTTPCode ServerError
e2)
        then ServerError -> RouteResult a
forall a. ServerError -> RouteResult a
Fail ServerError
e2
        else ServerError -> RouteResult a
forall a. ServerError -> RouteResult a
Fail ServerError
e1
    highestPri (Fail ServerError
_) RouteResult a
y = RouteResult a
y
    highestPri RouteResult a
x RouteResult a
_ = RouteResult a
x

-- Priority on HTTP codes.
--
worseHTTPCode :: Int -> Int -> Bool
worseHTTPCode :: Int -> Int -> Bool
worseHTTPCode = (Int -> Int -> Bool) -> (Int -> Int) -> Int -> Int -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
(<) Int -> Int
toPriority
  where
    toPriority :: Int -> Int
    toPriority :: Int -> Int
toPriority Int
404 = Int
0 -- not found
    toPriority Int
405 = Int
1 -- method not allowed
    toPriority Int
401 = Int
2 -- unauthorized
    toPriority Int
415 = Int
3 -- unsupported media type
    toPriority Int
406 = Int
4 -- not acceptable
    toPriority Int
400 = Int
6 -- bad request
    toPriority Int
_   = Int
5