diff --git a/default.nix b/default.nix index 24bcefb..c1eb175 100644 --- a/default.nix +++ b/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 ]; diff --git a/image-backup.cabal b/image-backup.cabal index 9ac10ee..421969d 100644 --- a/image-backup.cabal +++ b/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. diff --git a/src/MyLib.hs b/src/MyLib.hs index e657c44..651ca7c 100644 --- a/src/MyLib.hs +++ b/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 diff --git a/src/Servant/Metrics/Prometheus.hs b/src/Servant/Metrics/Prometheus.hs new file mode 100644 index 0000000..dd48c25 --- /dev/null +++ b/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) +