diff --git a/core-webserver-warp.cabal b/core-webserver-warp.cabal --- a/core-webserver-warp.cabal +++ b/core-webserver-warp.cabal @@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4. +-- This file has been generated from package.yaml by hpack version 0.35.0. -- -- see: https://github.com/sol/hpack name: core-webserver-warp -version: 0.1.1.6 +version: 0.2.0.0 synopsis: Interoperability with Wai/Warp description: This is part of a library to help build command-line programs, both tools and longer-running daemons. @@ -24,7 +24,7 @@ license-file: LICENSE build-type: Simple tested-with: - GHC == 8.10.7 + GHC == 8.10.7, GHC == 9.2.4 source-repository head type: git @@ -32,6 +32,7 @@ library exposed-modules: + Core.Webserver.Router Core.Webserver.Warp hs-source-dirs: lib @@ -40,9 +41,10 @@ async , base >=4.11 && <5 , bytestring + , bytestring-trie , core-data - , core-program >=0.4.6 - , core-telemetry >=0.2.3 + , core-program >=0.6.1 + , core-telemetry >=0.2.7 , core-text , http-types , http2 diff --git a/lib/Core/Webserver/Router.hs b/lib/Core/Webserver/Router.hs new file mode 100644 --- /dev/null +++ b/lib/Core/Webserver/Router.hs @@ -0,0 +1,295 @@ +{-# 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: + +- + +- + +- + +- + +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 + { routePrefix :: Prefix + , routeHandler :: Prefix -> Remainder -> Request -> Program τ Response + , 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 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 + , routeHandler = (\_ _ request -> notFoundHandler request) + , 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 prefix handler = + Route + { routePrefix = prefix + , routeHandler = (\_ _ request -> handler request) + , 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: + +- + +- + +- + +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 prefix0 handler = + Route + { routePrefix = prefix0 + , routeHandler = + ( \prefix remainder request -> do + setSpanName prefix + handler prefix remainder request + ) + , 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 _ = do + pure (responseBuilder status404 [] (Builder.stringUtf8 "Not Found")) + +instance IsString (Route τ) where + fromString :: String -> Route τ + fromString = literalRoute . 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 τ +() parent children = + parent + { routeChildren = 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 routes = do + let trie = buildTrie emptyRope routes + pure (makeApplication trie) + +buildTrie :: Prefix -> [Route τ] -> Trie.Trie (Prefix -> Remainder -> Request -> Program τ Response) +buildTrie prefix0 routes = + List.foldl' f Trie.empty routes + where + f :: + Trie.Trie (Prefix -> Remainder -> Request -> Program τ Response) -> + Route τ -> + Trie.Trie (Prefix -> Remainder -> Request -> Program τ Response) + f trie (Route prefix1 handler children) = + let prefix' = prefix0 <> singletonRope '/' <> prefix1 + trie1 = Trie.insert (fromRope prefix') handler trie + in case children of + [] -> trie1 + _ -> Trie.unionL trie1 (buildTrie prefix' 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 trie request sendResponse = do + let possibleContext = contextFromRequest request + + context <- case possibleContext of + Nothing -> Safe.throw ContextNotFoundInRequest + Just value -> pure value + + let path = rawPathInfo 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 = Trie.match trie path + + case possibleRoute of + Nothing -> do + response <- subProgram context $ do + notFoundHandler request + sendResponse response + Just (prefix', handler, remainder') -> do + response <- subProgram context $ do + let prefix = intoRope prefix' + let remainder = intoRope remainder' + internal ("prefix = " <> prefix) + internal ("remainder = " <> remainder) + telemetry + [ metric "request.route" prefix + ] + + handler prefix remainder request + + sendResponse response diff --git a/lib/Core/Webserver/Warp.hs b/lib/Core/Webserver/Warp.hs --- a/lib/Core/Webserver/Warp.hs +++ b/lib/Core/Webserver/Warp.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -70,6 +71,7 @@ launchWebserver, requestContextKey, contextFromRequest, + ContextNotFoundInRequest(..), ) where -- @@ -80,15 +82,15 @@ -- webserver frameworks. -- -import qualified Control.Exception.Safe as Safe (catch) +import Control.Exception.Safe qualified as Safe (catch) import Core.Program.Context import Core.Program.Logging import Core.System.Base import Core.Telemetry.Identifiers import Core.Telemetry.Observability import Core.Text.Rope -import qualified Data.List as List -import qualified Data.Vault.Lazy as Vault +import Data.List qualified as List +import Data.Vault.Lazy qualified as Vault import Network.HTTP.Types ( Status, hContentType, @@ -104,7 +106,7 @@ ) import Network.Wai import Network.Wai.Handler.Warp (InvalidRequest, Port) -import qualified Network.Wai.Handler.Warp as Warp +import Network.Wai.Handler.Warp qualified as Warp {- | Given a WAI 'Application', run a Warp webserver on the specified port from @@ -132,6 +134,11 @@ contextFromRequest :: forall t. Request -> Maybe (Context t) contextFromRequest request = Vault.lookup requestContextKey (vault request) + +data ContextNotFoundInRequest = ContextNotFoundInRequest deriving (Show) + +instance Exception ContextNotFoundInRequest where + displayException _ = "Context was not found in request. This is a serious error." -- which is IO loggingMiddleware :: Context τ -> Application -> Application