core-webserver-warp 0.2.0.0 → 0.2.1.0
raw patch · 3 files changed
+94/−52 lines, 3 filesdep +warp-tls
Dependencies added: warp-tls
Files
- core-webserver-warp.cabal +5/−4
- lib/Core/Webserver/Router.hs +23/−25
- lib/Core/Webserver/Warp.hs +66/−23
core-webserver-warp.cabal view
@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.0.+-- This file has been generated from package.yaml by hpack version 0.35.1. -- -- see: https://github.com/sol/hpack name: core-webserver-warp-version: 0.2.0.0+version: 0.2.1.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.@@ -19,12 +19,12 @@ bug-reports: https://github.com/aesiniath/unbeliever/issues author: Andrew Cowie <istathar@gmail.com> maintainer: Andrew Cowie <istathar@gmail.com>-copyright: © 2021-2022 Athae Eredh Siniath and Others+copyright: © 2021-2023 Athae Eredh Siniath and Others license: MIT license-file: LICENSE build-type: Simple tested-with:- GHC == 8.10.7, GHC == 9.2.4+ GHC == 8.10.7, GHC == 9.2.5 source-repository head type: git@@ -53,4 +53,5 @@ , vault , wai , warp+ , warp-tls default-language: Haskell2010
lib/Core/Webserver/Router.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE InstanceSigs #-}@@ -51,26 +52,25 @@ 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,- (</>),+module Core.Webserver.Router+ ( -- * Setup+ Route+ , Prefix+ , Remainder+ , literalRoute+ , handleRoute+ , captureRoute+ , (</>) - -- * Compile- prepareRoutes,+ -- * Compile+ , prepareRoutes - -- * Internal- notFoundHandler,-) where+ -- * 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@@ -186,8 +186,8 @@ { routePrefix = prefix0 , routeHandler = ( \prefix remainder request -> do- setSpanName prefix- handler prefix remainder request+ setSpanName prefix+ handler prefix remainder request ) , routeChildren = [] }@@ -233,21 +233,21 @@ -} prepareRoutes :: [Route τ] -> Program τ Application prepareRoutes routes = do- let trie = buildTrie emptyRope routes+ 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.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+ in case children of [] -> trie1 _ -> Trie.unionL trie1 (buildTrie prefix' children) @@ -284,8 +284,6 @@ response <- subProgram context $ do let prefix = intoRope prefix' let remainder = intoRope remainder'- internal ("prefix = " <> prefix)- internal ("remainder = " <> remainder) telemetry [ metric "request.route" prefix ]
lib/Core/Webserver/Warp.hs view
@@ -66,13 +66,14 @@ recommended to use the structured logging output or to send the traces to an observability service; this will be the root span of a trace. -}-module Core.Webserver.Warp (- Port,- launchWebserver,- requestContextKey,- contextFromRequest,- ContextNotFoundInRequest(..),-) where+module Core.Webserver.Warp+ ( Port+ , launchWebserver+ , launchWebserverTLS+ , requestContextKey+ , contextFromRequest+ , ContextNotFoundInRequest (..)+ ) where -- -- We follow the convention used elsewhere in this collection of libraries of@@ -91,26 +92,34 @@ import Core.Text.Rope import Data.List qualified as List import Data.Vault.Lazy qualified as Vault-import Network.HTTP.Types (- Status,- hContentType,- status400,- status413,- status431,- status500,- statusCode,- )-import Network.HTTP2.Frame (- ErrorCodeId (UnknownErrorCode),- HTTP2Error (ConnectionError),- )+import Network.HTTP.Types+ ( Status+ , hContentType+ , status400+ , status413+ , status431+ , status500+ , statusCode+ )+import Network.HTTP2.Frame+ ( ErrorCodeId (UnknownErrorCode)+ , HTTP2Error (ConnectionError)+ ) import Network.Wai import Network.Wai.Handler.Warp (InvalidRequest, Port) import Network.Wai.Handler.Warp qualified as Warp+import Network.Wai.Handler.WarpTLS (TLSSettings)+import Network.Wai.Handler.WarpTLS qualified as Warp {- | Given a WAI 'Application', run a Warp webserver on the specified port from within the 'Program' monad.++@+ 'launchWebserver' 80 application+@++(this wraps the __warp__ package) -} launchWebserver :: Port -> Application -> Program τ () launchWebserver port application = do@@ -128,6 +137,40 @@ application ) +{- |+Given a WAI 'Application', run a Warp webserver on the specified port from+within the 'Program' monad. This variant of 'launchWebserver' runs the server+with a TLS connection.++For the common case of supplying a certificate and private key, you can do:++@+ let crypto = 'tlsSettings' \"\/path\/to\/certificate.crt\" \"\/path\/to\/private.key\"+ 'launchWebserverTLS' crypto 443 application+@++(this wraps the __warp-tls__ package; for more complex certificate management+requirements see the documentation for the 'TLSSettings' type there)++@since 0.2.1+-}+launchWebserverTLS :: TLSSettings -> Port -> Application -> Program τ ()+launchWebserverTLS crypto port application = do+ context <- getContext+ let settings =+ Warp.setOnException+ (onExceptionHandler context)+ . Warp.setPort port+ $ Warp.defaultSettings+ liftIO $ do+ Warp.runTLS+ crypto+ settings+ ( loggingMiddleware+ context+ application+ )+ requestContextKey :: forall t. Vault.Key (Context t) requestContextKey = unsafePerformIO Vault.newKey {-# NOINLINE requestContextKey #-}@@ -163,7 +206,7 @@ -- application to make sure that consumers can later fetch the appropriate -- `Context t`. let vault' = Vault.insert (requestContextKey @τ) context1 (vault request)- request' = request{vault = vault'}+ request' = request {vault = vault'} Safe.catch ( application request' $ \response -> do -- accumulate the details for logging@@ -239,7 +282,7 @@ Nothing -> pure () Just request -> let line = intoRope (requestMethod request) <> " " <> intoRope (rawPathInfo request) <> intoRope (rawQueryString request)- in debug "request" line+ in debug "request" line {- | Pull the Trace identifier and parent Span identifier out of the request@@ -261,6 +304,6 @@ extractTraceParent request = let headers = requestHeaders request possibleValue = List.lookup "traceparent" headers- in case possibleValue of+ in case possibleValue of Nothing -> Nothing Just value -> parseTraceParentHeader (intoRope value)