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.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 maintainer: Andrew Cowie -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 diff --git a/lib/Core/Webserver/Router.hs b/lib/Core/Webserver/Router.hs --- a/lib/Core/Webserver/Router.hs +++ b/lib/Core/Webserver/Router.hs @@ -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 ] 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 @@ -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)