{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE OverloadedStrings #-}

{- |
Machinery for routing HTTP requests to appropriate handler functions.

Most of the time when writing a webserver or backend service for an
application we need to handle multiple different request paths. Even if the
process handles a only single primary endpoint there is often still a
requirement to respond to requests for status and to have simple health checks
that can be used to inform load balancers that the service is available in
addition to that primary endpoint. Sending different requests to different
functions is called /routing/.

= Usage

This module provides a simple mechanism for declaring routes and their
corresponding targets. You do this by creating a list of "handlers", one for
each context path prefix you want to route requests to, then using the
'prepareRoutes' function to compile this list into a WAI 'Application' that
can be passed to 'Core.Webserver.Warp.launchWebserver'.

@
    application <- 'prepareRoutes'
        [ \"api\"
            '</>' [ \"check\" `'handleRoute'` checkHandler
                , \"servicename\"
                    '</>' [ \"v3\"
                            '</>' [ \"status\" `'handleRoute'` statusHandler
                                , \"update\" `'captureRoute'` updateHandler
                                ]
                        ]
                ]
        ]

    'Core.Webserver.Warp.launchWebserver' 80 application
@

This results in an HTTP server responding to the following routes:

- <http:\/\/www.example.com\/api\/check>

- <http:\/\/www.example.com\/api\/servicename\/v3\/status>

- <http:\/\/www.example.com\/api\/servicename\/v3\/update>

- <http:\/\/www.example.com\/api\/servicename\/v3\/update\/12345678/field>

Requests to any other paths (for example @\/api@ and
@\/api\/servicename\/v3@) will result in a @404 Not Found@ response.
-}
module Core.Webserver.Router (
    -- * Setup
    Route,
    Prefix,
    Remainder,
    literalRoute,
    handleRoute,
    captureRoute,
    (</>),

    -- * Compile
    prepareRoutes,

    -- * Internal
    notFoundHandler,
) where

import Control.Exception.Safe qualified as Safe
import Core.Program.Context (Program)
import Core.Program.Logging
import Core.Program.Unlift (subProgram)
import Core.Telemetry.Observability (metric, setSpanName, telemetry)
import Core.Text.Rope
import Core.Webserver.Warp (ContextNotFoundInRequest (..), contextFromRequest)
import Data.ByteString.Builder qualified as Builder
import Data.List qualified as List (foldl')
import Data.String (IsString (fromString))
import Data.Trie qualified as Trie
import Network.HTTP.Types (status404)
import Network.Wai (Application, Request (rawPathInfo), Response, ResponseReceived, responseBuilder)
import Prelude hiding ((+), (/))

type Prefix = Rope

type Remainder = Rope

{- |
Component of a context path in a URL request that can be routed to a hander in
the 'Program' @τ@ monad. Routes can be nested under other routes, building up
the familiar tree structure commonly used by webservers.

@since 0.2.0
-}
data Route τ = Route
    { forall τ. Route τ -> Prefix
routePrefix :: Prefix
    , forall τ.
Route τ -> Prefix -> Prefix -> Request -> Program τ Response
routeHandler :: Prefix -> Remainder -> Request -> Program τ Response
    , forall τ. Route τ -> [Route τ]
routeChildren :: [Route τ]
    }

{- |
A segment of a route that is to be matched exactly. For example,

@
    'literalRoute' \"api\"
@

will match the context path @\/api@.

This is the used for the definition of the 'IsString' instance enabling use of
@OverloadedStrings@, so

@
    \"api\"
@

will /also/ match the context path @\/api@ and makes for cleaner routing
specifications when building up nested paths with '(</>)'.

@since 0.2.0
-}
literalRoute :: Prefix -> Route τ
literalRoute :: forall τ. Prefix -> Route τ
literalRoute Prefix
prefix =
    -- if this is the node that gets served, then it's 404 Not Found because, by definition, there wasn't an actual
    -- handler defined by the user!
    Route
        { routePrefix :: Prefix
routePrefix = Prefix
prefix
        , routeHandler :: Prefix -> Prefix -> Request -> Program τ Response
routeHandler = (\Prefix
_ Prefix
_ Request
request -> forall τ. Request -> Program τ Response
notFoundHandler Request
request)
        , routeChildren :: [Route τ]
routeChildren = []
        }

{- |
Route a given prefix to the supplied handler. You specify the prefix that you
want covered, and if the request path a matches the handler function will be
invoked.

@
    'handleRoute' \"status\" statusHandler
@

will match the context path @/status@ and invoke your function called
@statusHandler@ when requests for this path come in.

@since 0.2.0
-}
handleRoute :: Prefix -> (Request -> Program τ Response) -> Route τ
handleRoute :: forall τ. Prefix -> (Request -> Program τ Response) -> Route τ
handleRoute Prefix
prefix Request -> Program τ Response
handler =
    Route
        { routePrefix :: Prefix
routePrefix = Prefix
prefix
        , routeHandler :: Prefix -> Prefix -> Request -> Program τ Response
routeHandler = (\Prefix
_ Prefix
_ Request
request -> Request -> Program τ Response
handler Request
request)
        , routeChildren :: [Route τ]
routeChildren = []
        }

{- |
Route a given prefix to the supplied handler, passing any following components
of the path to that handler.

This is a more general variation of 'handleRoute' which allows you to
\"capture\" the part of the context path that came /after/ the route prefix,
if there is one (and an empty string otherwise).

For example,

@
    'captureRoute' \"person\"
@

will match the context paths in the URLs like these:

- <http:\/\/www.example.com\/person>

- <http:\/\/www.example.com\/person\/U37gcRTh>

- <http:\/\/www.example.com\/person\/U37gcRTh\/name>

In the case of the third example the result of matching on this 'Route' would
have a prefix of @\/person@ and a remainder of @\/U37gcRTh\/name@.

@since 0.2.0
-}
captureRoute :: Prefix -> (Prefix -> Remainder -> Request -> Program τ Response) -> Route τ
captureRoute :: forall τ.
Prefix
-> (Prefix -> Prefix -> Request -> Program τ Response) -> Route τ
captureRoute Prefix
prefix0 Prefix -> Prefix -> Request -> Program τ Response
handler =
    Route
        { routePrefix :: Prefix
routePrefix = Prefix
prefix0
        , routeHandler :: Prefix -> Prefix -> Request -> Program τ Response
routeHandler =
            ( \Prefix
prefix Prefix
remainder Request
request -> do
                    forall τ. Prefix -> Program τ ()
setSpanName Prefix
prefix
                    Prefix -> Prefix -> Request -> Program τ Response
handler Prefix
prefix Prefix
remainder Request
request
            )
        , routeChildren :: [Route τ]
routeChildren = []
        }

{- |
A default handler for routes that are encountered that don't have actual
handlers defined. This is what is served if the user requests an endpoint that
is defined by a 'literalRoute' or if the user requests a path that does not
route successfully..

@since 0.2.0
-}
notFoundHandler :: Request -> Program τ Response
notFoundHandler :: forall τ. Request -> Program τ Response
notFoundHandler Request
_ = do
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (Status -> ResponseHeaders -> Builder -> Response
responseBuilder Status
status404 [] (String -> Builder
Builder.stringUtf8 String
"Not Found"))

instance IsString (Route τ) where
    fromString :: String -> Route τ
    fromString :: String -> Route τ
fromString = forall τ. Prefix -> Route τ
literalRoute forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Prefix
packRope

{- |
Nest a set of routes below a parent. This will take the prefix inherited to
this point and insert it in front of the prefixes of each of the `Route`s
listed as children.

@since 0.2.0
-}
(</>) :: Route τ -> [Route τ] -> Route τ
</> :: forall τ. Route τ -> [Route τ] -> Route τ
(</>) Route τ
parent [Route τ]
children =
    Route τ
parent
        { routeChildren :: [Route τ]
routeChildren = [Route τ]
children
        }

{- |
Compile a list of route handlers into a WAI 'Application' suitable to be
passed to 'Core.Webserver.Warp.launchWebserver'.

Internally this builds up a patricia tree of the different route prefixes.
Incoming requests are matched against these possibilities, and either the
corresponding handler is invoked or @404 Not Found@ is returned.

@since 0.2.0
-}
prepareRoutes :: [Route τ] -> Program τ Application
prepareRoutes :: forall τ. [Route τ] -> Program τ Application
prepareRoutes [Route τ]
routes = do
    let trie :: Trie (Prefix -> Prefix -> Request -> Program τ Response)
trie = forall τ.
Prefix
-> [Route τ]
-> Trie (Prefix -> Prefix -> Request -> Program τ Response)
buildTrie Prefix
emptyRope [Route τ]
routes
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall τ.
Trie (Prefix -> Prefix -> Request -> Program τ Response)
-> Application
makeApplication Trie (Prefix -> Prefix -> Request -> Program τ Response)
trie)

buildTrie :: Prefix -> [Route τ] -> Trie.Trie (Prefix -> Remainder -> Request -> Program τ Response)
buildTrie :: forall τ.
Prefix
-> [Route τ]
-> Trie (Prefix -> Prefix -> Request -> Program τ Response)
buildTrie Prefix
prefix0 [Route τ]
routes =
    forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' forall τ.
Trie (Prefix -> Prefix -> Request -> Program τ Response)
-> Route τ
-> Trie (Prefix -> Prefix -> Request -> Program τ Response)
f forall a. Trie a
Trie.empty [Route τ]
routes
  where
    f ::
        Trie.Trie (Prefix -> Remainder -> Request -> Program τ Response) ->
        Route τ ->
        Trie.Trie (Prefix -> Remainder -> Request -> Program τ Response)
    f :: forall τ.
Trie (Prefix -> Prefix -> Request -> Program τ Response)
-> Route τ
-> Trie (Prefix -> Prefix -> Request -> Program τ Response)
f Trie (Prefix -> Prefix -> Request -> Program τ Response)
trie (Route Prefix
prefix1 Prefix -> Prefix -> Request -> Program τ Response
handler [Route τ]
children) =
        let prefix' :: Prefix
prefix' = Prefix
prefix0 forall a. Semigroup a => a -> a -> a
<> Char -> Prefix
singletonRope Char
'/' forall a. Semigroup a => a -> a -> a
<> Prefix
prefix1
            trie1 :: Trie (Prefix -> Prefix -> Request -> Program τ Response)
trie1 = forall a. ByteString -> a -> Trie a -> Trie a
Trie.insert (forall α. Textual α => Prefix -> α
fromRope Prefix
prefix') Prefix -> Prefix -> Request -> Program τ Response
handler Trie (Prefix -> Prefix -> Request -> Program τ Response)
trie
         in case [Route τ]
children of
                [] -> Trie (Prefix -> Prefix -> Request -> Program τ Response)
trie1
                [Route τ]
_ -> forall a. Trie a -> Trie a -> Trie a
Trie.unionL Trie (Prefix -> Prefix -> Request -> Program τ Response)
trie1 (forall τ.
Prefix
-> [Route τ]
-> Trie (Prefix -> Prefix -> Request -> Program τ Response)
buildTrie Prefix
prefix' [Route τ]
children)

-- We invoke makeApplication here partially applied in order to return an
-- Application,
--
--              :: Trie.Trie (Request -> Program τ Response) -> Application
--
-- but we expand out the signature in here in full in order to understand
-- where ther request object and response functions come from.
makeApplication :: Trie.Trie (Prefix -> Remainder -> Request -> Program τ Response) -> Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived
makeApplication :: forall τ.
Trie (Prefix -> Prefix -> Request -> Program τ Response)
-> Application
makeApplication Trie (Prefix -> Prefix -> Request -> Program τ Response)
trie Request
request Response -> IO ResponseReceived
sendResponse = do
    let possibleContext :: Maybe (Context t)
possibleContext = forall t. Request -> Maybe (Context t)
contextFromRequest Request
request

    Context τ
context <- case forall {t}. Maybe (Context t)
possibleContext of
        Maybe (Context τ)
Nothing -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
Safe.throw ContextNotFoundInRequest
ContextNotFoundInRequest
        Just Context τ
value -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Context τ
value

    let path :: ByteString
path = Request -> ByteString
rawPathInfo Request
request

    --
    -- And now the magic at the heart of this module. Data.Trie's match function
    -- looks up the longest entry in the trie that matches the supplied path.
    --

    let possibleRoute :: Maybe
  (ByteString, Prefix -> Prefix -> Request -> Program τ Response,
   ByteString)
possibleRoute = forall a. Trie a -> ByteString -> Maybe (ByteString, a, ByteString)
Trie.match Trie (Prefix -> Prefix -> Request -> Program τ Response)
trie ByteString
path

    case Maybe
  (ByteString, Prefix -> Prefix -> Request -> Program τ Response,
   ByteString)
possibleRoute of
        Maybe
  (ByteString, Prefix -> Prefix -> Request -> Program τ Response,
   ByteString)
Nothing -> do
            Response
response <- forall τ α. Context τ -> Program τ α -> IO α
subProgram Context τ
context forall a b. (a -> b) -> a -> b
$ do
                forall τ. Request -> Program τ Response
notFoundHandler Request
request
            Response -> IO ResponseReceived
sendResponse Response
response
        Just (ByteString
prefix', Prefix -> Prefix -> Request -> Program τ Response
handler, ByteString
remainder') -> do
            Response
response <- forall τ α. Context τ -> Program τ α -> IO α
subProgram Context τ
context forall a b. (a -> b) -> a -> b
$ do
                let prefix :: Prefix
prefix = forall α. Textual α => α -> Prefix
intoRope ByteString
prefix'
                let remainder :: Prefix
remainder = forall α. Textual α => α -> Prefix
intoRope ByteString
remainder'
                forall τ. Prefix -> Program τ ()
internal (Prefix
"prefix = " forall a. Semigroup a => a -> a -> a
<> Prefix
prefix)
                forall τ. Prefix -> Program τ ()
internal (Prefix
"remainder = " forall a. Semigroup a => a -> a -> a
<> Prefix
remainder)
                forall τ. [MetricValue] -> Program τ ()
telemetry
                    [ forall σ. Telemetry σ => Prefix -> σ -> MetricValue
metric Prefix
"request.route" Prefix
prefix
                    ]

                Prefix -> Prefix -> Request -> Program τ Response
handler Prefix
prefix Prefix
remainder Request
request

            Response -> IO ResponseReceived
sendResponse Response
response