{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_HADDOCK prune #-}

{- |
Many programs present their interface in the form of a webservice, be it
internet-facing, for internal use, or even just as a machine-local daemon. The
Haskell language has numerous frameworks for building webservices and a number
of high-quality HTTP server implementations. This module provides support for
the Web Application Interface from the __wai__ package and the __warp__
webserver.

Given an 'Network.Wai.Application' type (the definition of your web service) and a
'Network.Wai.Middleware' (which is just @Application -> Application@), run a the
"Core.Program"'s 'Core.Program.Execute.Program' monad. Metrics values (aka web
server logs) will be sent as key/value pairs via "Core.Telemetry".

= Usage

First set up your program and initialize the telemetry subsystem.

@
import "Core.Program"
import "Core.Telemetry"
import "Core.Webservice.Warp"

main :: 'IO' ()
main = do
    context <- 'Core.Program.Execute.configure' \"1.0\" 'Core.Program.Execute.None' ('Core.Program.Arguments.simpleConfig' [])
    context' <- 'initializeTelemetry' ['Core.Telemetry.Console.consoleExporter', 'Core.Telemetry.Structured.structuredExporter', 'Core.Telemetry.Honeycomb.honeycombExporter'] context
    'Core.Program.Execute.executeWith' context' \$ do
        'Core.Program.Logging.info' \"Starting...\"
        'launchWebserver' 8080 application
@

You can then describe your webservice 'Application', for example

@
application :: 'Application'
application = request sendResponse =
    sendResponse ('Network.WAI.responseLBS' 'Network.HTTP.Types.status200' [] \"Hello World\")
@

performs the heroic duty of replying to you with the given string. In
practice, if you're using something like __servant__ to define the shape of
your webservice its 'Servant.serve' function will give you the 'Application'
you're trying to run.

Logging output is sent to the telemtry channel. If you run your program with
the console exporter, and hit something like
<http://localhost:8080/hello?question=answer> will see something like this:

@
\$ __hello-service --telemetry=console__
03:16:01Z (00.002) Starting...
03:16:04Z (00.259)                                             <-- this is the request duration, 259 ms
/hello:                                                        <-- the base of the context path aka \"endpoint\"
  request.method = \"GET\"
  request.path = "/hello?question=answer"                      <-- the full context path with query string
  response.status_code = "200"
@

This is useful for debugging during development but for production you are
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,
) where

--
-- We follow the convention used elsewhere in this collection of libraries of
-- using a qualified name for the imports of significant libraries. It's a bit
-- cumbersome, but makes it easier to disambiguate what's going on when
-- comparing to almost identical code in sibling modules covering other
-- webserver frameworks.
--

import qualified Control.Exception.Safe 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 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 qualified Network.Wai.Handler.Warp as Warp

{- |
Given a WAI 'Application', run a Warp webserver on the specified port from
within the 'Program' monad.
-}
launchWebserver :: Port -> Application -> Program τ ()
launchWebserver :: Port -> Application -> Program τ ()
launchWebserver Port
port Application
application = do
    Context τ
context <- Program τ (Context τ)
forall τ. Program τ (Context τ)
getContext
    let settings :: Settings
settings =
            (Maybe Request -> SomeException -> IO ()) -> Settings -> Settings
Warp.setOnException
                (Context τ -> Maybe Request -> SomeException -> IO ()
forall τ. Context τ -> Maybe Request -> SomeException -> IO ()
onExceptionHandler Context τ
context)
                (Settings -> Settings)
-> (Settings -> Settings) -> Settings -> Settings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Port -> Settings -> Settings
Warp.setPort Port
port
                (Settings -> Settings) -> Settings -> Settings
forall a b. (a -> b) -> a -> b
$ Settings
Warp.defaultSettings
    IO () -> Program τ ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Program τ ()) -> IO () -> Program τ ()
forall a b. (a -> b) -> a -> b
$ do
        Settings -> Application -> IO ()
Warp.runSettings
            Settings
settings
            ( Context τ -> Application -> Application
forall τ. Context τ -> Application -> Application
loggingMiddleware
                Context τ
context
                Application
application
            )

requestContextKey :: forall t. Vault.Key (Context t)
requestContextKey :: Key (Context t)
requestContextKey = IO (Key (Context t)) -> Key (Context t)
forall a. IO a -> a
unsafePerformIO IO (Key (Context t))
forall a. IO (Key a)
Vault.newKey
{-# NOINLINE requestContextKey #-}

contextFromRequest :: forall t. Request -> Maybe (Context t)
contextFromRequest :: Request -> Maybe (Context t)
contextFromRequest Request
request = Key (Context t) -> Vault -> Maybe (Context t)
forall a. Key a -> Vault -> Maybe a
Vault.lookup Key (Context t)
forall t. Key (Context t)
requestContextKey (Request -> Vault
vault Request
request)

-- which is IO
loggingMiddleware :: Context τ -> Application -> Application
loggingMiddleware :: Context τ -> Application -> Application
loggingMiddleware (Context τ
context0 :: Context τ) Application
application Request
request Response -> IO ResponseReceived
sendResponse = do
    let path :: Rope
path = ByteString -> Rope
forall α. Textual α => α -> Rope
intoRope (Request -> ByteString
rawPathInfo Request
request)
        query :: Rope
query = ByteString -> Rope
forall α. Textual α => α -> Rope
intoRope (Request -> ByteString
rawQueryString Request
request)
        method :: Rope
method = ByteString -> Rope
forall α. Textual α => α -> Rope
intoRope (Request -> ByteString
requestMethod Request
request)

    Context τ -> Program τ ResponseReceived -> IO ResponseReceived
forall τ α. Context τ -> Program τ α -> IO α
subProgram Context τ
context0 (Program τ ResponseReceived -> IO ResponseReceived)
-> Program τ ResponseReceived -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ do
        Request -> Program τ ResponseReceived -> Program τ ResponseReceived
forall z a. Request -> Program z a -> Program z a
resumeTraceIf Request
request (Program τ ResponseReceived -> Program τ ResponseReceived)
-> Program τ ResponseReceived -> Program τ ResponseReceived
forall a b. (a -> b) -> a -> b
$ do
            Rope -> Program τ ResponseReceived -> Program τ ResponseReceived
forall z a. Rope -> Program z a -> Program z a
encloseSpan Rope
path (Program τ ResponseReceived -> Program τ ResponseReceived)
-> Program τ ResponseReceived -> Program τ ResponseReceived
forall a b. (a -> b) -> a -> b
$ do
                Context τ
context1 <- Program τ (Context τ)
forall τ. Program τ (Context τ)
getContext

                -- we could call `telemetry` here with the request values, but
                -- since we call into nested actions which could clear the
                -- state without starting a new span, we duplicate adding them
                -- below to ensure they get passed through.

                IO ResponseReceived -> Program τ ResponseReceived
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ResponseReceived -> Program τ ResponseReceived)
-> IO ResponseReceived -> Program τ ResponseReceived
forall a b. (a -> b) -> a -> b
$ do
                    -- The below wires the context in the request's `vault`. As the type of
                    -- `Context` is polymorphic to support user data, we have to use a type
                    -- application to make sure that consumers can later fetch the appropriate
                    -- `Context t`.
                    let vault' :: Vault
vault' = Key (Context τ) -> Context τ -> Vault -> Vault
forall a. Key a -> a -> Vault -> Vault
Vault.insert (Key (Context τ)
forall t. Key (Context t)
requestContextKey @τ) Context τ
context1 (Request -> Vault
vault Request
request)
                        request' :: Request
request' = Request
request{vault :: Vault
vault = Vault
vault'}
                    IO ResponseReceived
-> (SomeException -> IO ResponseReceived) -> IO ResponseReceived
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
Safe.catch
                        ( Application
application Request
request' ((Response -> IO ResponseReceived) -> IO ResponseReceived)
-> (Response -> IO ResponseReceived) -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ \Response
response -> do
                            -- accumulate the details for logging
                            let code :: Port
code = Status -> Port
statusCode (Response -> Status
responseStatus Response
response)

                            Context τ -> Program τ () -> IO ()
forall τ α. Context τ -> Program τ α -> IO α
subProgram Context τ
context1 (Program τ () -> IO ()) -> Program τ () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                                [MetricValue] -> Program τ ()
forall τ. [MetricValue] -> Program τ ()
telemetry
                                    [ Rope -> Rope -> MetricValue
forall σ. Telemetry σ => Rope -> σ -> MetricValue
metric Rope
"request.method" Rope
method
                                    , Rope -> Rope -> MetricValue
forall σ. Telemetry σ => Rope -> σ -> MetricValue
metric Rope
"request.path" Rope
path
                                    , Rope -> Rope -> MetricValue
forall σ. Telemetry σ => Rope -> σ -> MetricValue
metric Rope
"request.query" Rope
query
                                    , Rope -> Port -> MetricValue
forall σ. Telemetry σ => Rope -> σ -> MetricValue
metric Rope
"response.status_code" Port
code
                                    ]

                            -- actually handle the request
                            Response -> IO ResponseReceived
sendResponse Response
response
                        )
                        ( \(SomeException
e :: SomeException) -> do
                            -- set the magic `error` field with the exception text.
                            let text :: Rope
text = String -> Rope
forall α. Textual α => α -> Rope
intoRope (SomeException -> String
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

                            Context τ -> Program τ () -> IO ()
forall τ α. Context τ -> Program τ α -> IO α
subProgram Context τ
context1 (Program τ () -> IO ()) -> Program τ () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                                Rope -> Program τ ()
forall τ. Rope -> Program τ ()
warn Rope
"Trapped internal exception"
                                Rope -> Rope -> Program τ ()
forall τ. Rope -> Rope -> Program τ ()
debug Rope
"e" Rope
text
                                [MetricValue] -> Program τ ()
forall τ. [MetricValue] -> Program τ ()
telemetry
                                    [ Rope -> Rope -> MetricValue
forall σ. Telemetry σ => Rope -> σ -> MetricValue
metric Rope
"request.method" Rope
method
                                    , Rope -> Rope -> MetricValue
forall σ. Telemetry σ => Rope -> σ -> MetricValue
metric Rope
"request.path" Rope
path
                                    , Rope -> Rope -> MetricValue
forall σ. Telemetry σ => Rope -> σ -> MetricValue
metric Rope
"request.query" Rope
query
                                    , Rope -> Port -> MetricValue
forall σ. Telemetry σ => Rope -> σ -> MetricValue
metric Rope
"response.status_code" Port
code
                                    , Rope -> Rope -> MetricValue
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")]
                                    (Rope -> ByteString
forall α. Textual α => Rope -> α
fromRope Rope
detail)
                                )
                        )

assignException :: SomeException -> (Status, Rope)
assignException :: SomeException -> (Status, Rope)
assignException SomeException
e
    | Just (InvalidRequest
_ :: InvalidRequest) <-
        SomeException -> Maybe InvalidRequest
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e =
        (Status
status400, String -> Rope
forall α. Textual α => α -> Rope
intoRope (SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
e))
    | Just (ConnectionError (UnknownErrorCode ErrorCode
413) ByteString
t) <-
        SomeException -> Maybe HTTP2Error
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e =
        (Status
status413, ByteString -> Rope
forall α. Textual α => α -> Rope
intoRope ByteString
t)
    | Just (ConnectionError (UnknownErrorCode ErrorCode
431) ByteString
t) <-
        SomeException -> Maybe HTTP2Error
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e =
        (Status
status431, ByteString -> Rope
forall α. Textual α => α -> Rope
intoRope ByteString
t)
    | Bool
otherwise =
        (Status
status500, Rope
"Internal Server Error")

--
-- Ideally this would be a catch-all and not be hit; our application wrapper
-- should have caught this beforehand. However, it turns out "Bad Request"
-- type protocol problems that don't even result in a coherent request -
-- which, sadly, are somewhat to be expected on the wild and wooly internet.
-- So we note them briefly and move on.
--
-- Much more interesting are exceptions which occur within the request path,
-- which means that we can annotate the current span with an `error` field and
-- send it down the telemetry channel.
--
onExceptionHandler :: Context τ -> Maybe Request -> SomeException -> IO ()
onExceptionHandler :: Context τ -> Maybe Request -> SomeException -> IO ()
onExceptionHandler Context τ
context Maybe Request
possibleRequest SomeException
e = do
    Context τ -> Program τ () -> IO ()
forall τ α. Context τ -> Program τ α -> IO α
subProgram Context τ
context (Program τ () -> IO ()) -> Program τ () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Rope -> Program τ ()
forall τ. Rope -> Program τ ()
critical Rope
"Exception escaped webserver"
        Rope -> SomeException -> Program τ ()
forall α τ. Show α => Rope -> α -> Program τ ()
debugS Rope
"e" SomeException
e
        case Maybe Request
possibleRequest of
            Maybe Request
Nothing -> () -> Program τ ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Just Request
request ->
                let line :: Rope
line = ByteString -> Rope
forall α. Textual α => α -> Rope
intoRope (Request -> ByteString
requestMethod Request
request) Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> Rope
" " Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> ByteString -> Rope
forall α. Textual α => α -> Rope
intoRope (Request -> ByteString
rawPathInfo Request
request) Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> ByteString -> Rope
forall α. Textual α => α -> Rope
intoRope (Request -> ByteString
rawQueryString Request
request)
                 in Rope -> Rope -> Program τ ()
forall τ. Rope -> Rope -> Program τ ()
debug Rope
"request" Rope
line

{- |
Pull the Trace identifier and parent Span identifier out of the request
headers, if present. Resume using those values, otherwise start a new trace.
-}
resumeTraceIf :: Request -> Program z a -> Program z a
resumeTraceIf :: 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
            Program z a -> Program z a
forall τ α. Program τ α -> Program τ α
beginTrace Program z a
action
        Just (Trace
trace, Span
parent) -> do
            Trace -> Span -> Program z a -> Program z a
forall τ α. Trace -> Span -> Program τ α -> Program τ α
usingTrace Trace
trace Span
parent Program z a
action

--
-- This is wildly inefficient. Surely warp must provide a better way to search
-- header values?!?
--
extractTraceParent :: Request -> Maybe (Trace, Span)
extractTraceParent :: Request -> Maybe (Trace, Span)
extractTraceParent Request
request =
    let headers :: ResponseHeaders
headers = Request -> ResponseHeaders
requestHeaders Request
request
        possibleValue :: Maybe ByteString
possibleValue = HeaderName -> ResponseHeaders -> Maybe ByteString
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 -> Maybe (Trace, Span)
forall a. Maybe a
Nothing
            Just ByteString
value -> Rope -> Maybe (Trace, Span)
parseTraceParentHeader (ByteString -> Rope
forall α. Textual α => α -> Rope
intoRope ByteString
value)