Basic prometheus metrics

default.nix

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

image-backup.cabal

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

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