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

    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

    -- | Holds information about pieces of url that are captured as variables.
    data CaptureHint = CaptureHint
      { CaptureHint -> Text
    captureName :: Text
      -- ^ Holds the name of the captured variable
      , CaptureHint -> TypeRep
    captureType :: TypeRep
      -- ^ Holds the type of the captured variable
      }
      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
    $cshowsPrec :: Int -> CaptureHint -> ShowS
    showsPrec :: Int -> CaptureHint -> ShowS
    $cshow :: CaptureHint -> String
    show :: CaptureHint -> String
    $cshowList :: [CaptureHint] -> ShowS
    showList :: [CaptureHint] -> ShowS
    Show, CaptureHint -> CaptureHint -> Bool
    (CaptureHint -> CaptureHint -> Bool)
    -> (CaptureHint -> CaptureHint -> Bool) -> Eq CaptureHint
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: CaptureHint -> CaptureHint -> Bool
    == :: CaptureHint -> CaptureHint -> Bool
    $c/= :: CaptureHint -> CaptureHint -> Bool
    /= :: 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.
          --   The first argument is a list of hints for all variables that can be
          --   captured by the router. The fact that it is a list is counter-intuitive,
          --   because the 'Capture' combinator only allows to capture a single varible,
          --   with a single name and a single type. However, the 'choice' smart
          --   constructor may merge two 'Capture' combinators with different hints, thus
          --   forcing the type to be '[CaptureHint]'.
          --   Because 'CaptureRouter' is built from a 'Capture' combinator, the list of
          --   hints should always be non-empty.
      | CaptureAllRouter [CaptureHint] (Router' ([Text], env) a)
          -- ^ all path components are passed to the child router in its
          --   environment and are removed afterwards
          --   The first argument is a hint for the list of variables that can be
          --   captured by the router. Note that the 'captureType' field of the hint
          --   should always be '[a]' for some 'a'.
      | 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 (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 :: Type -> Type).
    (forall a b. (a -> b) -> f a -> f b)
    -> (forall a b. a -> f b -> f a) -> Functor f
    $cfmap :: forall env a b. (a -> b) -> Router' env a -> Router' env b
    fmap :: forall a b. (a -> b) -> Router' env a -> Router' env b
    $c<$ :: forall env a b. a -> Router' env b -> Router' env a
    <$ :: forall a b. a -> Router' env b -> Router' env a
    Functor

    -- | Smart constructor for a single static path component.
    pathRouter :: Text -> Router' env a -> Router' env a
    pathRouter :: forall env a. 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 :: forall env a. (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 :: forall env a. 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
      -- ^ The first argument holds information about variables
      -- that are captured by the router. There may be several hints
      -- if several routers have been aggregated by the 'choice'
      -- smart constructor.
      | 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
    $c== :: RouterStructure -> RouterStructure -> Bool
    == :: RouterStructure -> RouterStructure -> Bool
    $c/= :: RouterStructure -> RouterStructure -> Bool
    /= :: 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
    $cshowsPrec :: Int -> RouterStructure -> ShowS
    showsPrec :: Int -> RouterStructure -> ShowS
    $cshow :: RouterStructure -> String
    show :: RouterStructure -> String
    $cshowList :: [RouterStructure] -> ShowS
    showList :: [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 :: forall env a. 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 a b. (a -> b) -> Map Text a -> Map Text b
    forall (f :: Type -> Type) 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 a. [a] -> Int
    forall (t :: Type -> Type) 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 :: forall env a b. 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 :: forall env a. 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 :: Type -> Type) 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 :: forall env.
    (RouteResult Response -> RouteResult Response)
    -> Router env -> Router env
    tweakResponse RouteResult Response -> RouteResult Response
    f = (RoutingApplication -> RoutingApplication)
    -> Router' env RoutingApplication -> Router' env RoutingApplication
    forall a b. (a -> b) -> Router' env a -> Router' env b
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    fmap (\RoutingApplication
    a -> \Request
    req RouteResult Response -> IO ResponseReceived
    cont -> RoutingApplication
    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 () -> RoutingApplication
    runRouter NotFoundErrorFormatter
    fmt Router ()
    r = NotFoundErrorFormatter -> Router () -> () -> RoutingApplication
    forall env.
    NotFoundErrorFormatter -> Router env -> env -> RoutingApplication
    runRouterEnv NotFoundErrorFormatter
    fmt Router ()
    r ()

    runRouterEnv :: NotFoundErrorFormatter -> Router env -> env -> RoutingApplication
    runRouterEnv :: forall env.
    NotFoundErrorFormatter -> Router env -> env -> RoutingApplication
    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 -> RoutingApplication]
    ls ->
          case Request -> [Text]
    pathInfo Request
    request of
            []   -> NotFoundErrorFormatter
    -> [env -> RoutingApplication] -> env -> RoutingApplication
    forall env.
    NotFoundErrorFormatter
    -> [env -> RoutingApplication] -> env -> RoutingApplication
    runChoice NotFoundErrorFormatter
    fmt [env -> RoutingApplication]
    ls env
    env Request
    request RouteResult Response -> IO ResponseReceived
    respond
            -- This case is to handle trailing slashes.
            [Text
    ""] -> NotFoundErrorFormatter
    -> [env -> RoutingApplication] -> env -> RoutingApplication
    forall env.
    NotFoundErrorFormatter
    -> [env -> RoutingApplication] -> env -> RoutingApplication
    runChoice NotFoundErrorFormatter
    fmt [env -> RoutingApplication]
    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 = rest }
                 in  NotFoundErrorFormatter -> Router env -> env -> RoutingApplication
    forall env.
    NotFoundErrorFormatter -> Router env -> env -> RoutingApplication
    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) RoutingApplication
    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 = rest }
                 in  NotFoundErrorFormatter
    -> Router' (Text, env) RoutingApplication
    -> (Text, env)
    -> RoutingApplication
    forall env.
    NotFoundErrorFormatter -> Router env -> env -> RoutingApplication
    runRouterEnv NotFoundErrorFormatter
    fmt Router' (Text, env) RoutingApplication
    router' (Text
    first, env
    env) Request
    request' RouteResult Response -> IO ResponseReceived
    respond
        CaptureAllRouter [CaptureHint]
    _ Router' ([Text], env) RoutingApplication
    router' ->
          let segments :: [Text]
    segments = case Request -> [Text]
    pathInfo Request
    request of
                -- this case is to handle trailing slashes.
                (Text
    "":[Text]
    xs) -> [Text]
    xs
                [Text]
    xs -> [Text]
    xs
              request' :: Request
    request' = Request
    request { pathInfo = [] }
          in NotFoundErrorFormatter
    -> Router' ([Text], env) RoutingApplication
    -> ([Text], env)
    -> RoutingApplication
    forall env.
    NotFoundErrorFormatter -> Router env -> env -> RoutingApplication
    runRouterEnv NotFoundErrorFormatter
    fmt Router' ([Text], env) RoutingApplication
    router' ([Text]
    segments, env
    env) Request
    request' RouteResult Response -> IO ResponseReceived
    respond
        RawRouter env -> RoutingApplication
    app ->
          env -> RoutingApplication
    app env
    env Request
    request RouteResult Response -> IO ResponseReceived
    respond
        Choice Router env
    r1 Router env
    r2 ->
          NotFoundErrorFormatter
    -> [env -> RoutingApplication] -> env -> RoutingApplication
    forall env.
    NotFoundErrorFormatter
    -> [env -> RoutingApplication] -> env -> RoutingApplication
    runChoice NotFoundErrorFormatter
    fmt [NotFoundErrorFormatter -> Router env -> env -> RoutingApplication
    forall env.
    NotFoundErrorFormatter -> Router env -> env -> RoutingApplication
    runRouterEnv NotFoundErrorFormatter
    fmt Router env
    r1, NotFoundErrorFormatter -> Router env -> env -> RoutingApplication
    forall env.
    NotFoundErrorFormatter -> Router env -> env -> RoutingApplication
    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 :: forall env.
    NotFoundErrorFormatter
    -> [env -> RoutingApplication] -> env -> RoutingApplication
    runChoice NotFoundErrorFormatter
    fmt [env -> RoutingApplication]
    ls =
      case [env -> RoutingApplication]
    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 -> RoutingApplication
    r]      -> env -> RoutingApplication
    r
        (env -> RoutingApplication
    r : [env -> RoutingApplication]
    rs) ->
          \ env
    env Request
    request RouteResult Response -> IO ResponseReceived
    respond ->
          env -> RoutingApplication
    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 -> RoutingApplication] -> env -> RoutingApplication
    forall env.
    NotFoundErrorFormatter
    -> [env -> RoutingApplication] -> env -> RoutingApplication
    runChoice NotFoundErrorFormatter
    fmt [env -> RoutingApplication]
    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