{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE OverloadedStrings #-}
module Core.Webserver.Router (
Route,
Prefix,
Remainder,
literalRoute,
handleRoute,
captureRoute,
(</>),
prepareRoutes,
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
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 τ]
}
literalRoute :: Prefix -> Route τ
literalRoute :: forall τ. Prefix -> Route τ
literalRoute Prefix
prefix =
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 = []
}
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 = []
}
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 = []
}
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
(</>) :: Route τ -> [Route τ] -> Route τ
</> :: forall τ. Route τ -> [Route τ] -> Route τ
(</>) Route τ
parent [Route τ]
children =
Route τ
parent
{ routeChildren :: [Route τ]
routeChildren = [Route τ]
children
}
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)
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
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