module Servant.Server.Internal.Router where
import Data.Map (Map)
import qualified Data.Map as M
import Data.Text (Text)
import Network.Wai (Request, Response, pathInfo)
import Servant.Server.Internal.RoutingApplication
import Servant.Server.Internal.ServantErr
type Router = Router' RoutingApplication
data Router' a =
WithRequest (Request -> Router)
| StaticRouter (Map Text Router)
| DynamicRouter (Text -> Router)
| LeafRouter a
| Choice Router Router
deriving Functor
tweakResponse :: (RouteResult Response -> RouteResult Response) -> Router -> Router
tweakResponse f = fmap (\a -> \req cont -> a req (cont . f))
choice :: Router -> Router -> Router
choice (StaticRouter table1) (StaticRouter table2) =
StaticRouter (M.unionWith choice table1 table2)
choice (DynamicRouter fun1) (DynamicRouter fun2) =
DynamicRouter (\ first -> choice (fun1 first) (fun2 first))
choice (WithRequest router1) (WithRequest router2) =
WithRequest (\ request -> choice (router1 request) (router2 request))
choice (WithRequest router1) router2 =
WithRequest (\ request -> choice (router1 request) router2)
choice router1 (WithRequest router2) =
WithRequest (\ request -> choice router1 (router2 request))
choice router1 router2 = Choice router1 router2
runRouter :: Router -> RoutingApplication
runRouter (WithRequest router) request respond =
runRouter (router request) request respond
runRouter (StaticRouter table) request respond =
case pathInfo request of
first : rest
| Just router <- M.lookup first table
-> let request' = request { pathInfo = rest }
in runRouter router request' respond
_ -> respond $ Fail err404
runRouter (DynamicRouter fun) request respond =
case pathInfo request of
first : rest
-> let request' = request { pathInfo = rest }
in runRouter (fun first) request' respond
_ -> respond $ Fail err404
runRouter (LeafRouter app) request respond = app request respond
runRouter (Choice r1 r2) request respond =
runRouter r1 request $ \ mResponse1 -> case mResponse1 of
Fail _ -> runRouter r2 request $ \ mResponse2 ->
respond (highestPri mResponse1 mResponse2)
_ -> respond mResponse1
where
highestPri (Fail e1) (Fail e2) =
if worseHTTPCode (errHTTPCode e1) (errHTTPCode e2)
then Fail e2
else Fail e1
highestPri (Fail _) y = y
highestPri x _ = x
worseHTTPCode :: Int -> Int -> Bool
worseHTTPCode = (<)