{-# 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
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
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 forall a. Semigroup a => a -> a -> a
<> Text
"::" forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) (CaptureHint -> TypeRep
captureType CaptureHint
hint)

toCaptureTags :: [CaptureHint] -> Text
toCaptureTags :: [CaptureHint] -> Text
toCaptureTags [CaptureHint]
hints = Text
"<" forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
"|" (forall a b. (a -> b) -> [a] -> [b]
map CaptureHint -> Text
toCaptureTag [CaptureHint]
hints) 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 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
<$ :: forall a b. a -> Router' env b -> Router' env a
$c<$ :: forall env a b. a -> Router' env b -> Router' env a
fmap :: forall a b. (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 :: forall env a. Text -> Router' env a -> Router' env a
pathRouter Text
t Router' env a
r = forall env a.
Map Text (Router' env a) -> [env -> a] -> Router' env a
StaticRouter (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 = forall env a.
Map Text (Router' env a) -> [env -> a] -> Router' env a
StaticRouter 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) =
  forall env a.
Map Text (Router' env a) -> [env -> a] -> Router' env a
StaticRouter (forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith 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 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)   =
  forall env a.
[CaptureHint] -> Router' (Text, env) a -> Router' env a
CaptureRouter (forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ [CaptureHint]
hints1 forall a. [a] -> [a] -> [a]
++ [CaptureHint]
hints2) (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) = forall env a. Router' env a -> Router' env a -> Router' env a
Choice (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 = 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
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
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 :: forall env a. Router' env a -> RouterStructure
routerStructure (StaticRouter Map Text (Router' env a)
m [env -> a]
ls) =
  Map Text RouterStructure -> Int -> RouterStructure
StaticRouterStructure (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall env a. Router' env a -> RouterStructure
routerStructure Map Text (Router' env a)
m) (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 forall a b. (a -> b) -> a -> b
$
    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 forall a b. (a -> b) -> a -> b
$
    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
    (forall env a. Router' env a -> RouterStructure
routerStructure Router' env a
r1)
    (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 =
    forall env a. Router' env a -> RouterStructure
routerStructure Router' env a
router1 forall a. Eq a => a -> a -> Bool
== 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
"/"] forall a. [a] -> [a] -> [a]
++ Bool -> RouterStructure -> [Text]
mkRouterLayout Bool
False (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 (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 forall a. [a] -> [a] -> [a]
++ [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 =
      forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a. Int -> a -> [a]
replicate (Int
n forall a. Num a => a -> a -> a
- Int
1) (Bool -> [Text]
mkLeaf Bool
True) 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) 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
"├─ " forall a. Semigroup a => a -> a -> a
<> Text
path forall a. Semigroup a => a -> a -> a
<> Text
"/") forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (Text
"│  " forall a. Semigroup a => a -> a -> a
<>) [Text]
children
    mkSubTree Bool
False Text
path [Text]
children = (Text
"└─ " forall a. Semigroup a => a -> a -> a
<> Text
path forall a. Semigroup a => a -> a -> a
<> Text
"/") forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (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 = forall (f :: * -> *) 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 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 = 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
        []   -> 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
""] -> 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' <- 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  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 forall a b. (a -> b) -> a -> b
$ forall a. ServerError -> RouteResult a
Fail 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 forall a b. (a -> b) -> a -> b
$ forall a. ServerError -> RouteResult a
Fail forall a b. (a -> b) -> a -> b
$ NotFoundErrorFormatter
fmt Request
request
        -- This case is to handle trailing slashes.
        [Text
""] -> RouteResult Response -> IO ResponseReceived
respond forall a b. (a -> b) -> a -> b
$ forall a. ServerError -> RouteResult a
Fail 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  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 = Request -> [Text]
pathInfo Request
request
          request' :: Request
request' = Request
request { pathInfo :: [Text]
pathInfo = [] }
      in 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 ->
      forall env.
NotFoundErrorFormatter
-> [env -> RoutingApplication] -> env -> RoutingApplication
runChoice NotFoundErrorFormatter
fmt [forall env.
NotFoundErrorFormatter -> Router env -> env -> RoutingApplication
runRouterEnv NotFoundErrorFormatter
fmt Router env
r1, 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 (forall a. ServerError -> RouteResult a
Fail 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 forall a b. (a -> b) -> a -> b
$ \ RouteResult Response
response1 ->
      case RouteResult Response
response1 of
        Fail ServerError
_ -> forall env.
NotFoundErrorFormatter
-> [env -> RoutingApplication] -> env -> RoutingApplication
runChoice NotFoundErrorFormatter
fmt [env -> RoutingApplication]
rs env
env Request
request forall a b. (a -> b) -> a -> b
$ \ RouteResult Response
response2 ->
          RouteResult Response -> IO ResponseReceived
respond forall a b. (a -> b) -> a -> b
$ 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 forall a. ServerError -> RouteResult a
Fail ServerError
e2
        else 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 = forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on 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