Basic prometheus metrics

This commit is contained in:
Mats Rauhala 2023-02-12 14:47:48 +02:00
parent ca7bf79c7d
commit 06a8266ef2
4 changed files with 83 additions and 2 deletions

View File

@ -1,6 +1,7 @@
{ mkDerivation, amazonka, amazonka-s3, base, bytestring, conduit { mkDerivation, amazonka, amazonka-s3, base, bytestring, conduit
, cryptonite, directory, ekg-core, filepath, lib, mtl, servant , cryptonite, directory, ekg-core, filepath, lib, mtl, servant
, servant-server, sqlite-simple, text , servant-server, sqlite-simple, text, unordered-containers, wai
, wai-middleware-metrics, warp
}: }:
mkDerivation { mkDerivation {
pname = "image-backup"; pname = "image-backup";
@ -11,6 +12,7 @@ mkDerivation {
libraryHaskellDepends = [ libraryHaskellDepends = [
amazonka amazonka-s3 base bytestring conduit cryptonite directory amazonka amazonka-s3 base bytestring conduit cryptonite directory
ekg-core filepath mtl servant servant-server sqlite-simple text ekg-core filepath mtl servant servant-server sqlite-simple text
unordered-containers wai wai-middleware-metrics warp
]; ];
executableHaskellDepends = [ base ]; executableHaskellDepends = [ base ];
testHaskellDepends = [ base ]; testHaskellDepends = [ base ];

View File

@ -60,6 +60,7 @@ library
-- Modules exported by the library. -- Modules exported by the library.
exposed-modules: MyLib exposed-modules: MyLib
Servant.Metrics.Prometheus
-- Modules included in this library but not exported. -- Modules included in this library but not exported.
-- other-modules: -- other-modules:
@ -82,6 +83,10 @@ library
, bytestring , bytestring
, text , text
, mtl , mtl
, wai-middleware-metrics
, unordered-containers
, wai
, warp
-- Directories containing source files. -- Directories containing source files.
hs-source-dirs: src hs-source-dirs: src
@ -112,6 +117,7 @@ executable image-backup
-- Base language which the package is written in. -- Base language which the package is written in.
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -threaded -with-rtsopts=-T
test-suite image-backup-test test-suite image-backup-test
-- Import common warning flags. -- Import common warning flags.

View File

@ -1,4 +1,34 @@
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DeriveGeneric #-}
module MyLib (someFunc) where module MyLib (someFunc) where
import Network.Wai.Metrics (metrics, registerWaiMetrics)
import System.Metrics
(Store, newStore, registerGcMetrics)
import Servant.Metrics.Prometheus
import Network.Wai.Handler.Warp (runSettings, defaultSettings, setPort)
import Data.Function ((&))
import Servant
import GHC.Generics (Generic)
newtype Routes route
= Routes { _getMetrics :: route :- MetricsRoute }
deriving (Generic)
type API = NamedRoutes Routes
app :: Store -> Application
app store = serve (Proxy @API) Routes { _getMetrics = metricsServer store }
someFunc :: IO () someFunc :: IO ()
someFunc = putStrLn "someFunc" someFunc = do
store <- newStore
waiMetrics <- registerWaiMetrics store
registerGcMetrics store
runSettings settings (metrics waiMetrics $ app store)
where
settings =
defaultSettings &
setPort 8099
-- setOnException onException

View File

@ -0,0 +1,43 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
module Servant.Metrics.Prometheus where
import Control.Monad.Trans (MonadIO, liftIO)
import qualified Data.ByteString.Lazy as LB
import qualified Data.HashMap.Strict as HM
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Servant (Server, ServerT)
import Servant.API
import System.Metrics (Sample, Store, Value(..), sampleAll)
import qualified System.Metrics.Distribution as Stats
import qualified Text.Printf as Text
newtype Metrics = Metrics Sample
instance MimeRender PlainText Metrics where
mimeRender _ (Metrics sample) = LB.fromStrict . TE.encodeUtf8 . T.unlines . map (uncurry format) . HM.toList $ sample
where
formatKey :: Text -> Text
formatKey k = "feed_proxy_" <> T.replace "." "_" k
format :: Text -> Value -> Text
format key = \case
Counter n -> T.pack $ Text.printf "%s %d" (formatKey key) n
Gauge n -> T.pack $ Text.printf "%s %d" (formatKey key) n
Label n -> T.pack $ Text.printf "%s{label=\"%s\"} 1.0" (formatKey key) n
Distribution d ->
let k = formatKey key
in T.pack $ Text.printf "%s_sum %f\n%s_count %d" k (Stats.sum d) k (Stats.count d)
type MetricsRoute = "metrics" :> Get '[PlainText] Metrics
metricsServerT :: MonadIO m => Store -> ServerT MetricsRoute m
metricsServerT store = liftIO (Metrics <$> sampleAll store)
metricsServer :: Store -> Server MetricsRoute
metricsServer store = liftIO (Metrics <$> sampleAll store)