core-webserver-warp 0.1.1.6 → 0.2.0.0

raw patch · 3 files changed

+313/−9 lines, 3 filesdep +bytestring-triedep ~core-programdep ~core-telemetryPVP ok

version bump matches the API change (PVP)

Dependencies added: bytestring-trie

Dependency ranges changed: core-program, core-telemetry

API changes (from Hackage documentation)

Files

• core-webserver-warp.cabal +7/−5
• lib/Core/Webserver/Router.hs +295/−0
• lib/Core/Webserver/Warp.hs +11/−4

@@ -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

@@ -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:++- <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+    { 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:++- <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 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

@@ -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