-- |
-- Module      : ZuulWeeder.Monitoring
-- Description : Service monitoring middleware
-- Copyright   : (c) Red Hat, 2022
-- License     : Apache-2.0
--
-- Maintainer  : tdecacqu@redhat.com, fboucher@redhat.com
-- Stability   : provisional
-- Portability : portable
--
-- The monitoring middleware to export prometheus metrics.
module ZuulWeeder.Monitoring (mkMonitoring) where

import Data.ByteString qualified as BS
import Network.HTTP.Types.Status qualified as HTTP
import Network.Socket qualified
import Network.Wai qualified as Wai
import Prometheus qualified
import Prometheus.Metric.GHC qualified
import Web.HttpApiData (toHeader)
import ZuulWeeder.Prelude

-- | Create the monitoring middleware.
mkMonitoring :: Logger -> IO Wai.Middleware
mkMonitoring :: Logger -> IO Middleware
mkMonitoring Logger
logger = do
  IO ()
forall (m :: * -> *). MonadIO m => m ()
Prometheus.unregisterAll
  IO GHCMetrics -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO GHCMetrics -> IO ()) -> IO GHCMetrics -> IO ()
forall a b. (a -> b) -> a -> b
$ Metric GHCMetrics -> IO GHCMetrics
forall (m :: * -> *) s. MonadIO m => Metric s -> m s
Prometheus.register Metric GHCMetrics
Prometheus.Metric.GHC.ghcMetrics
  Counter
counter <- Metric Counter -> IO Counter
forall (m :: * -> *) s. MonadIO m => Metric s -> m s
Prometheus.register (Metric Counter -> IO Counter) -> Metric Counter -> IO Counter
forall a b. (a -> b) -> a -> b
$ Info -> Metric Counter
Prometheus.counter (Text -> Text -> Info
Prometheus.Info Text
"http_request" Text
"")
  Middleware -> IO Middleware
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Middleware -> IO Middleware) -> Middleware -> IO Middleware
forall a b. (a -> b) -> a -> b
$ Logger -> Counter -> Middleware
monitoring Logger
logger Counter
counter

monitoring :: Logger -> Prometheus.Counter -> Wai.Middleware
monitoring :: Logger -> Counter -> Middleware
monitoring Logger
logger Counter
counter Application
baseApp Request
req Response -> IO ResponseReceived
resp = case Request -> ByteString
Wai.rawPathInfo Request
req of
  ByteString
"/health" -> Response -> IO ResponseReceived
resp (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
Wai.responseLBS Status
HTTP.ok200 [] ByteString
forall a. Monoid a => a
mempty
  ByteString
"/metrics" -> Response -> IO ResponseReceived
resp (Response -> IO ResponseReceived)
-> (ByteString -> Response) -> ByteString -> IO ResponseReceived
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Status -> ResponseHeaders -> ByteString -> Response
Wai.responseLBS Status
HTTP.ok200 [] (ByteString -> IO ResponseReceived)
-> IO ByteString -> IO ResponseReceived
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO ByteString
forall (m :: * -> *). MonadIO m => m ByteString
Prometheus.exportMetricsAsText
  ByteString
p | ByteString
"/dists/" ByteString -> ByteString -> Bool
`BS.isPrefixOf` ByteString
p -> Application
baseApp Request
req Response -> IO ResponseReceived
resp
  ByteString
p -> do
    IO Int64
measure <- IO (IO Int64)
intervalMilliSec
    Application
baseApp Request
req ((Response -> IO ResponseReceived) -> IO ResponseReceived)
-> (Response -> IO ResponseReceived) -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ \Response
r -> do
      Counter -> IO ()
forall (m :: * -> *). MonadMonitor m => Counter -> m ()
Prometheus.incCounter Counter
counter
      ResponseReceived
result <- Response -> IO ResponseReceived
resp Response
r
      Int64
elapsed <- IO Int64
measure
      let statusCode :: Int
statusCode = Status -> Int
HTTP.statusCode (Status -> Int) -> Status -> Int
forall a b. (a -> b) -> a -> b
$ Response -> Status
Wai.responseStatus Response
r
          htmx :: Bool
htmx = (Header -> Bool) -> ResponseHeaders -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Header
h -> Header -> HeaderName
forall a b. (a, b) -> a
fst Header
h HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
"HX-Request") (ResponseHeaders -> Bool) -> ResponseHeaders -> Bool
forall a b. (a -> b) -> a -> b
$ Request -> ResponseHeaders
Wai.requestHeaders Request
req
          client :: Int
client = SockAddr -> Int
remoteHash (Request -> SockAddr
Wai.remoteHost Request
req) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Maybe ByteString -> Int
forall a. Hashable a => a -> Int
hash (Request -> Maybe ByteString
Wai.requestHeaderUserAgent Request
req)
          msg :: ByteString
msg =
            ByteString
p
              ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> (ByteString
" code=" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Int -> ByteString
forall a. ToHttpApiData a => a -> ByteString
toHeader Int
statusCode)
              ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> (ByteString
" ms=" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Int64 -> ByteString
forall a. ToHttpApiData a => a -> ByteString
toHeader Int64
elapsed)
              ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> (ByteString
" htmx=" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Bool -> ByteString
forall a. ToHttpApiData a => a -> ByteString
toHeader Bool
htmx)
              ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> (ByteString
" client=" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Int -> ByteString
forall a. ToHttpApiData a => a -> ByteString
toHeader Int
client)
      Logger -> ByteString -> IO ()
info Logger
logger ByteString
msg
      ResponseReceived -> IO ResponseReceived
forall (f :: * -> *) a. Applicative f => a -> f a
pure ResponseReceived
result
  where
    remoteHash :: Network.Socket.SockAddr -> Int
    remoteHash :: SockAddr -> Int
remoteHash = \case
      Network.Socket.SockAddrInet PortNumber
_ HostAddress
h -> HostAddress -> Int
forall a. Hashable a => a -> Int
hash HostAddress
h
      Network.Socket.SockAddrInet6 PortNumber
_ HostAddress
h HostAddress6
_ HostAddress
_ -> HostAddress -> Int
forall a. Hashable a => a -> Int
hash HostAddress
h
      Network.Socket.SockAddrUnix String
_ -> Int
0