Basic prometheus metrics

src/MyLib.hs

@@ -1,4 +1,34 @@
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE DeriveGeneric #-}
 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 = putStrLn "someFunc"
+someFunc = do
+  store <- newStore
+  waiMetrics <- registerWaiMetrics store
+  registerGcMetrics store
+  runSettings settings (metrics waiMetrics $ app store)
+  where
+    settings =
+      defaultSettings &
+      setPort 8099
+      -- setOnException onException

src/Servant/Metrics/Prometheus.hs

@@ -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)
+