{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_HADDOCK prune #-}
module Core.Webserver.Warp
( Port
, launchWebserver
, launchWebserverTLS
, requestContextKey
, contextFromRequest
, ContextNotFoundInRequest (..)
) where
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 Data.List qualified as List
import Data.Vault.Lazy qualified as Vault
import Network.HTTP.Types
( Status
, hContentType
, status400
, status500
, statusCode
)
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
launchWebserver :: Port -> Application -> Program τ ()
launchWebserver :: forall τ. Port -> Application -> Program τ ()
launchWebserver Port
port Application
application = do
Context τ
context <- forall τ. Program τ (Context τ)
getContext
let settings :: Settings
settings =
(Maybe Request -> SomeException -> IO ()) -> Settings -> Settings
Warp.setOnException
(forall τ. Context τ -> Maybe Request -> SomeException -> IO ()
onExceptionHandler Context τ
context)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Port -> Settings -> Settings
Warp.setPort Port
port
forall a b. (a -> b) -> a -> b
$ Settings
Warp.defaultSettings
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
Settings -> Application -> IO ()
Warp.runSettings
Settings
settings
( forall τ. Context τ -> Application -> Application
loggingMiddleware
Context τ
context
Application
application
)
launchWebserverTLS :: TLSSettings -> Port -> Application -> Program τ ()
launchWebserverTLS :: forall τ. TLSSettings -> Port -> Application -> Program τ ()
launchWebserverTLS TLSSettings
crypto Port
port Application
application = do
Context τ
context <- forall τ. Program τ (Context τ)
getContext
let settings :: Settings
settings =
(Maybe Request -> SomeException -> IO ()) -> Settings -> Settings
Warp.setOnException
(forall τ. Context τ -> Maybe Request -> SomeException -> IO ()
onExceptionHandler Context τ
context)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Port -> Settings -> Settings
Warp.setPort Port
port
forall a b. (a -> b) -> a -> b
$ Settings
Warp.defaultSettings
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
TLSSettings -> Settings -> Application -> IO ()
Warp.runTLS
TLSSettings
crypto
Settings
settings
( forall τ. Context τ -> Application -> Application
loggingMiddleware
Context τ
context
Application
application
)
requestContextKey :: forall t. Vault.Key (Context t)
requestContextKey :: forall t. Key (Context t)
requestContextKey = forall a. IO a -> a
unsafePerformIO forall a. IO (Key a)
Vault.newKey
{-# NOINLINE requestContextKey #-}
contextFromRequest :: forall t. Request -> Maybe (Context t)
contextFromRequest :: forall t. Request -> Maybe (Context t)
contextFromRequest Request
request = forall a. Key a -> Vault -> Maybe a
Vault.lookup forall t. Key (Context t)
requestContextKey (Request -> Vault
vault Request
request)
data ContextNotFoundInRequest = ContextNotFoundInRequest deriving (Port -> ContextNotFoundInRequest -> ShowS
[ContextNotFoundInRequest] -> ShowS
ContextNotFoundInRequest -> String
forall a.
(Port -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ContextNotFoundInRequest] -> ShowS
$cshowList :: [ContextNotFoundInRequest] -> ShowS
show :: ContextNotFoundInRequest -> String
$cshow :: ContextNotFoundInRequest -> String
showsPrec :: Port -> ContextNotFoundInRequest -> ShowS
$cshowsPrec :: Port -> ContextNotFoundInRequest -> ShowS
Show)
instance Exception ContextNotFoundInRequest where
displayException :: ContextNotFoundInRequest -> String
displayException ContextNotFoundInRequest
_ = String
"Context was not found in request. This is a serious error."
loggingMiddleware :: Context τ -> Application -> Application
loggingMiddleware :: forall τ. Context τ -> Application -> Application
loggingMiddleware (Context τ
context0 :: Context τ) Application
application Request
request Response -> IO ResponseReceived
sendResponse = do
let path :: Rope
path = forall α. Textual α => α -> Rope
intoRope (Request -> ByteString
rawPathInfo Request
request)
query :: Rope
query = forall α. Textual α => α -> Rope
intoRope (Request -> ByteString
rawQueryString Request
request)
method :: Rope
method = forall α. Textual α => α -> Rope
intoRope (Request -> ByteString
requestMethod Request
request)
forall τ α. Context τ -> Program τ α -> IO α
subProgram Context τ
context0 forall a b. (a -> b) -> a -> b
$ do
forall z a. Request -> Program z a -> Program z a
resumeTraceIf Request
request forall a b. (a -> b) -> a -> b
$ do
forall z a. Rope -> Program z a -> Program z a
encloseSpan Rope
path forall a b. (a -> b) -> a -> b
$ do
Context τ
context1 <- forall τ. Program τ (Context τ)
getContext
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
let vault' :: Vault
vault' = forall a. Key a -> a -> Vault -> Vault
Vault.insert (forall t. Key (Context t)
requestContextKey @τ) Context τ
context1 (Request -> Vault
vault Request
request)
request' :: Request
request' = Request
request {vault :: Vault
vault = Vault
vault'}
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
Safe.catch
( Application
application Request
request' forall a b. (a -> b) -> a -> b
$ \Response
response -> do
let code :: Port
code = Status -> Port
statusCode (Response -> Status
responseStatus Response
response)
forall τ α. Context τ -> Program τ α -> IO α
subProgram Context τ
context1 forall a b. (a -> b) -> a -> b
$ do
forall τ. [MetricValue] -> Program τ ()
telemetry
[ forall σ. Telemetry σ => Rope -> σ -> MetricValue
metric Rope
"request.method" Rope
method
, forall σ. Telemetry σ => Rope -> σ -> MetricValue
metric Rope
"request.path" Rope
path
, if Rope -> Bool
nullRope Rope
query then forall σ. Telemetry σ => Rope -> σ -> MetricValue
metric Rope
"request.query" () else forall σ. Telemetry σ => Rope -> σ -> MetricValue
metric Rope
"request.query" Rope
query
, forall σ. Telemetry σ => Rope -> σ -> MetricValue
metric Rope
"response.status_code" Port
code
]
Response -> IO ResponseReceived
sendResponse Response
response
)
( \(SomeException
e :: SomeException) -> do
let text :: Rope
text = forall α. Textual α => α -> Rope
intoRope (forall e. Exception e => e -> String
displayException SomeException
e)
(Status
status, Rope
detail) = SomeException -> (Status, Rope)
assignException SomeException
e
code :: Port
code = Status -> Port
statusCode Status
status
forall τ α. Context τ -> Program τ α -> IO α
subProgram Context τ
context1 forall a b. (a -> b) -> a -> b
$ do
forall τ. Rope -> Program τ ()
warn Rope
"Trapped internal exception"
forall τ. Rope -> Rope -> Program τ ()
debug Rope
"e" Rope
text
forall τ. [MetricValue] -> Program τ ()
telemetry
[ forall σ. Telemetry σ => Rope -> σ -> MetricValue
metric Rope
"request.method" Rope
method
, forall σ. Telemetry σ => Rope -> σ -> MetricValue
metric Rope
"request.path" Rope
path
, if Rope -> Bool
nullRope Rope
query then forall σ. Telemetry σ => Rope -> σ -> MetricValue
metric Rope
"request.query" () else forall σ. Telemetry σ => Rope -> σ -> MetricValue
metric Rope
"request.query" Rope
query
, forall σ. Telemetry σ => Rope -> σ -> MetricValue
metric Rope
"response.status_code" Port
code
, forall σ. Telemetry σ => Rope -> σ -> MetricValue
metric Rope
"error" Rope
text
]
Response -> IO ResponseReceived
sendResponse
( Status -> ResponseHeaders -> ByteString -> Response
responseLBS
Status
status
[(HeaderName
hContentType, ByteString
"text/plain; charset=utf-8")]
(forall α. Textual α => Rope -> α
fromRope Rope
detail)
)
)
assignException :: SomeException -> (Status, Rope)
assignException :: SomeException -> (Status, Rope)
assignException SomeException
e
| Just (InvalidRequest
_ :: InvalidRequest) <-
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e =
(Status
status400, forall α. Textual α => α -> Rope
intoRope (forall e. Exception e => e -> String
displayException SomeException
e))
| Bool
otherwise =
(Status
status500, Rope
"Internal Server Error")
onExceptionHandler :: Context τ -> Maybe Request -> SomeException -> IO ()
onExceptionHandler :: forall τ. Context τ -> Maybe Request -> SomeException -> IO ()
onExceptionHandler Context τ
context Maybe Request
possibleRequest SomeException
e = do
forall τ α. Context τ -> Program τ α -> IO α
subProgram Context τ
context forall a b. (a -> b) -> a -> b
$ do
forall τ. Rope -> Program τ ()
critical Rope
"Exception escaped webserver"
forall α τ. Show α => Rope -> α -> Program τ ()
debugS Rope
"e" SomeException
e
case Maybe Request
possibleRequest of
Maybe Request
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just Request
request ->
let line :: Rope
line = forall α. Textual α => α -> Rope
intoRope (Request -> ByteString
requestMethod Request
request) forall a. Semigroup a => a -> a -> a
<> Rope
" " forall a. Semigroup a => a -> a -> a
<> forall α. Textual α => α -> Rope
intoRope (Request -> ByteString
rawPathInfo Request
request) forall a. Semigroup a => a -> a -> a
<> forall α. Textual α => α -> Rope
intoRope (Request -> ByteString
rawQueryString Request
request)
in forall τ. Rope -> Rope -> Program τ ()
debug Rope
"request" Rope
line
resumeTraceIf :: Request -> Program z a -> Program z a
resumeTraceIf :: forall z a. Request -> Program z a -> Program z a
resumeTraceIf Request
request Program z a
action =
case Request -> Maybe (Trace, Span)
extractTraceParent Request
request of
Maybe (Trace, Span)
Nothing -> do
forall τ α. Program τ α -> Program τ α
beginTrace Program z a
action
Just (Trace
trace, Span
parent) -> do
forall τ α. Trace -> Span -> Program τ α -> Program τ α
usingTrace Trace
trace Span
parent Program z a
action
extractTraceParent :: Request -> Maybe (Trace, Span)
Request
request =
let headers :: ResponseHeaders
headers = Request -> ResponseHeaders
requestHeaders Request
request
possibleValue :: Maybe ByteString
possibleValue = forall a b. Eq a => a -> [(a, b)] -> Maybe b
List.lookup HeaderName
"traceparent" ResponseHeaders
headers
in case Maybe ByteString
possibleValue of
Maybe ByteString
Nothing -> forall a. Maybe a
Nothing
Just ByteString
value -> Rope -> Maybe (Trace, Span)
parseTraceParentHeader (forall α. Textual α => α -> Rope
intoRope ByteString
value)