prometheus 0.1.0.2 → 0.1.0.3
raw patch · 10 files changed
+234/−52 lines, 10 filesdep +http-typesdep +waidep +warp
Dependencies added: http-types, wai, warp
Files
- prometheus.cabal +6/−1
- src/System/Metrics/Prometheus/Encode.hs +22/−12
- src/System/Metrics/Prometheus/Encode/Histogram.hs +22/−18
- src/System/Metrics/Prometheus/Encode/MetricId.hs +40/−5
- src/System/Metrics/Prometheus/GlobalRegistry.hs +52/−0
- src/System/Metrics/Prometheus/Http.hs +40/−0
- src/System/Metrics/Prometheus/Metric/Counter.hs +8/−1
- src/System/Metrics/Prometheus/Metric/Gauge.hs +11/−1
- src/System/Metrics/Prometheus/Metric/Histogram.hs +21/−11
- src/System/Metrics/Prometheus/Registry.hs +12/−3
prometheus.cabal view
@@ -1,5 +1,5 @@ name: prometheus-version: 0.1.0.2+version: 0.1.0.3 synopsis: Prometheus Haskell Client description: Idiomatic Haskell client for Prometheus.io monitoring. homepage: http://github.com/LukeHoersten/prometheus#readme@@ -19,6 +19,8 @@ exposed-modules: System.Metrics.Prometheus.Encode , System.Metrics.Prometheus.Encode.Histogram , System.Metrics.Prometheus.Encode.MetricId+ , System.Metrics.Prometheus.GlobalRegistry+ , System.Metrics.Prometheus.Http , System.Metrics.Prometheus.Metric , System.Metrics.Prometheus.Metric.Counter , System.Metrics.Prometheus.Metric.Gauge@@ -32,9 +34,12 @@ , base >= 4.7 && < 5.0 , bytestring >= 0.10 && < 0.11 , containers >= 0.5 && < 0.6+ , http-types >= 0.9 && < 0.10 , mtl >= 2.2 && < 2.3 , text >= 1.2 && < 1.3 , transformers >= 0.4 && < 0.5+ , wai >= 3.2 && < 3.3+ , warp >= 3.2 && < 3.3 source-repository head type: git
src/System/Metrics/Prometheus/Encode.hs view
@@ -5,16 +5,19 @@ , serializeMetrics ) where -import Data.ByteString.Builder (Builder, doubleDec,- intDec,+import Data.ByteString.Builder (Builder, toLazyByteString) import Data.ByteString.Lazy (ByteString)-import Data.List (intersperse)+import Data.Function (on)+import Data.List (groupBy,+ intersperse) import qualified Data.Map as Map import Data.Monoid ((<>)) import System.Metrics.Prometheus.Encode.Histogram (encodeHistogram)-import System.Metrics.Prometheus.Encode.MetricId (encodeHeader,+import System.Metrics.Prometheus.Encode.MetricId (encodeDouble,+ encodeHeader,+ encodeInt, encodeMetricId, newline, space) import System.Metrics.Prometheus.Metric (MetricSample (..),@@ -30,21 +33,28 @@ encodeMetrics :: RegistrySample -> Builder-encodeMetrics = mconcat . intersperse "\n\n" .- map (uncurry encodeMetric) . Map.toList . unRegistrySample+encodeMetrics = mconcat . intersperse "\n\n" . map encodeMetricGroup . groupByName+ . Map.toList . unRegistrySample+ where groupByName = groupBy ((==) `on` (name . fst)) -encodeMetric :: MetricId -> MetricSample -> Builder-encodeMetric mid sample- = encodeHeader mid sample <> newline- <> metricSample (encodeCounter mid) (encodeGauge mid) (encodeHistogram mid) (encodeSummary mid) sample+encodeMetricGroup :: [(MetricId, MetricSample)] -> Builder+encodeMetricGroup group = encodeHeader mid sample <> newline+ <> mconcat (intersperse newline $ map encodeMetric group) where+ (mid, sample) = head group+++encodeMetric :: (MetricId, MetricSample) -> Builder+encodeMetric (mid, sample) = metricSample (encodeCounter mid) (encodeGauge mid)+ (encodeHistogram mid) (encodeSummary mid) sample+ where encodeSummary = undefined encodeCounter :: MetricId -> CounterSample -> Builder-encodeCounter mid counter = encodeMetricId mid <> space <> intDec (unCounterSample counter)+encodeCounter mid counter = encodeMetricId mid <> space <> encodeInt (unCounterSample counter) encodeGauge :: MetricId -> GaugeSample -> Builder-encodeGauge mid gauge = encodeMetricId mid <> space <> doubleDec (unGaugeSample gauge)+encodeGauge mid gauge = encodeMetricId mid <> space <> encodeDouble (unGaugeSample gauge)
src/System/Metrics/Prometheus/Encode/Histogram.hs view
@@ -1,20 +1,22 @@ {-# LANGUAGE OverloadedStrings #-} -module System.Metrics.Prometheus.Encode.Histogram where+module System.Metrics.Prometheus.Encode.Histogram+ ( encodeHistogram+ ) where -import Data.ByteString.Builder (Builder, doubleDec,- intDec)+import Data.ByteString.Builder (Builder)+import Data.List (intersperse) import qualified Data.Map as Map import Data.Monoid ((<>))-import Data.Text.Lazy (toStrict)-import Data.Text.Lazy.Builder (toLazyText)-import Data.Text.Lazy.Builder.RealFloat (FPFormat (Generic),- formatRealFloat) -import System.Metrics.Prometheus.Encode.MetricId (encodeLabels,- encodeName, space)-import System.Metrics.Prometheus.Metric.Histogram (Count, HistogramSample (..),+import System.Metrics.Prometheus.Encode.MetricId (encodeDouble,+ encodeInt,+ encodeLabels,+ encodeName,+ newline, space,+ textValue)+import System.Metrics.Prometheus.Metric.Histogram (HistogramSample (..), UpperBound) import System.Metrics.Prometheus.MetricId (MetricId (..), addLabel)@@ -22,19 +24,21 @@ encodeHistogram :: MetricId -> HistogramSample -> Builder encodeHistogram mid histogram- = encodeHistogramBuckets mid histogram- <> encodeName (name mid) <> "_sum" <> space <> doubleDec (histSum histogram)- <> encodeName (name mid) <> "_count" <> space <> intDec (histCount histogram)+ = encodeHistogramBuckets mid histogram <> newline+ <> n <> "_sum" <> ls <> space <> encodeDouble (histSum histogram) <> newline+ <> n <> "_count" <> ls <> space <> encodeInt (histCount histogram)+ where+ n = encodeName $ name mid+ ls = encodeLabels $ labels mid encodeHistogramBuckets :: MetricId -> HistogramSample -> Builder-encodeHistogramBuckets mid = mconcat . map snd . Map.toList+encodeHistogramBuckets mid = mconcat . intersperse newline . map snd . Map.toList . Map.mapWithKey (encodeHistogramBucket mid) . histBuckets -encodeHistogramBucket :: MetricId -> UpperBound -> Count -> Builder+encodeHistogramBucket :: MetricId -> UpperBound -> Double -> Builder encodeHistogramBucket mid upperBound count- = encodeName (name mid) <> "_bucket" <> encodeLabels labels' <> space <> intDec count+ = encodeName (name mid) <> "_bucket" <> encodeLabels labels' <> space <> encodeDouble count where- upperBoundValue = toStrict . toLazyText $ formatRealFloat Generic Nothing upperBound- labels' = addLabel "le" upperBoundValue $ labels mid+ labels' = addLabel "le" (textValue upperBound) (labels mid)
src/System/Metrics/Prometheus/Encode/MetricId.hs view
@@ -1,13 +1,29 @@ {-# LANGUAGE OverloadedStrings #-} -module System.Metrics.Prometheus.Encode.MetricId where+module System.Metrics.Prometheus.Encode.MetricId+ ( encodeHeader+ , encodeMetricId+ , encodeLabels+ , encodeName+ , textValue+ , encodeDouble+ , encodeInt+ , escape+ , newline+ , space+ ) where -import Data.ByteString.Builder (Builder, byteString, char8)+import Data.ByteString.Builder (Builder, byteString, char8,+ intDec) import Data.List (intersperse) import qualified Data.Map as Map import Data.Monoid ((<>))-import Data.Text (Text)+import Data.Text (Text, replace) import Data.Text.Encoding (encodeUtf8)+import Data.Text.Lazy (toStrict)+import Data.Text.Lazy.Builder (toLazyText)+import Data.Text.Lazy.Builder.RealFloat (FPFormat (Generic),+ formatRealFloat) import System.Metrics.Prometheus.Metric (MetricSample (..), metricSample)@@ -18,7 +34,7 @@ encodeHeader :: MetricId -> MetricSample -> Builder encodeHeader mid sample = "# TYPE " <> nm <> space <> encodeSampleType sample- -- <> "# HELP " <> nm <> space <> "help" <> newline <>+ -- <> "# HELP " <> nm <> space <> escape "help" <> newline <> where nm = encodeName (name mid) @@ -46,11 +62,30 @@ encodeLabel :: (Text, Text) -> Builder-encodeLabel (key, value) = text key <> equals <> quote <> text value <> quote+encodeLabel (key, val) = text key <> equals <> quote <> text (escape val) <> quote +textValue :: RealFloat f => f -> Text+textValue x | isInfinite x && x > 0 = "+Inf"+ | isInfinite x && x < 0 = "-Inf"+ | isNaN x = "Nan"+ | otherwise = toStrict . toLazyText $ formatRealFloat Generic Nothing x+++encodeDouble :: RealFloat f => f -> Builder+encodeDouble = text . textValue+++encodeInt :: Int -> Builder+encodeInt = intDec++ text :: Text -> Builder text = byteString . encodeUtf8+++escape :: Text -> Text+escape = replace "\n" "\\n" . replace "\"" "\\\"" . replace "\\" "\\\\" space :: Builder
+ src/System/Metrics/Prometheus/GlobalRegistry.hs view
@@ -0,0 +1,52 @@+module System.Metrics.Prometheus.GlobalRegistry+ ( GlobalRegistry+ , new+ , registerCounter+ , registerGauge+ , registerHistogram+ , sample+ ) where+++import Control.Concurrent.MVar (MVar,+ modifyMVarMasked,+ newMVar, withMVar)+import Data.Tuple (swap)++import System.Metrics.Prometheus.Metric.Counter (Counter)+import System.Metrics.Prometheus.Metric.Gauge (Gauge)+import System.Metrics.Prometheus.Metric.Histogram (Histogram,+ UpperBound)+import System.Metrics.Prometheus.MetricId (Labels, Name)+import System.Metrics.Prometheus.Registry (Registry (..),+ RegistrySample)+import qualified System.Metrics.Prometheus.Registry as R+++newtype GlobalRegistry = GlobalRegistry { unGlobalRegistry :: MVar Registry }+++new :: IO GlobalRegistry+new = GlobalRegistry <$> newMVar R.new+++registerCounter :: Name -> Labels -> GlobalRegistry -> IO Counter+registerCounter name labels = flip modifyMVarMasked register . unGlobalRegistry+ where+ register = fmap swap . R.registerCounter name labels+++registerGauge :: Name -> Labels -> GlobalRegistry -> IO Gauge+registerGauge name labels = flip modifyMVarMasked register . unGlobalRegistry+ where+ register = fmap swap . R.registerGauge name labels+++registerHistogram :: Name -> Labels -> [UpperBound] -> GlobalRegistry -> IO Histogram+registerHistogram name labels buckets = flip modifyMVarMasked register . unGlobalRegistry+ where+ register = fmap swap . R.registerHistogram name labels buckets+++sample :: GlobalRegistry -> IO RegistrySample+sample = flip withMVar R.sample . unGlobalRegistry
+ src/System/Metrics/Prometheus/Http.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE OverloadedStrings #-}++module System.Metrics.Prometheus.Http where+++import Network.HTTP.Types (hContentType,+ methodGet, status200,+ status404)+import Network.Wai (Application,+ Response, pathInfo,+ requestMethod,+ responseBuilder,+ responseLBS)+import Network.Wai.Handler.Warp (Port, run)++import System.Metrics.Prometheus.Encode (encodeMetrics)+import System.Metrics.Prometheus.GlobalRegistry (GlobalRegistry,+ sample)+++serveHttpTextMetrics :: Port -> GlobalRegistry -> IO ()+serveHttpTextMetrics port = run port . prometheusApp+++prometheusApp :: GlobalRegistry -> Application+prometheusApp globalRegistry request respond+ | prometheusRequest = prometheusResponse respond globalRegistry+ | otherwise = respond $ responseLBS status404 header404 body404+ where+ prometheusRequest = requestMethod request == methodGet && pathInfo request == ["metrics"]+ header404 = [(hContentType, "text/plain")]+ body404 = "404"+++prometheusResponse :: (Response -> IO b) -> GlobalRegistry -> IO b+prometheusResponse respond globalRegistry = do+ s <- sample globalRegistry+ respond . responseBuilder status200 headers $ encodeMetrics s+ where+ headers = [(hContentType, "text/plain; version=0.0.4")]
src/System/Metrics/Prometheus/Metric/Counter.hs view
@@ -1,4 +1,11 @@-module System.Metrics.Prometheus.Metric.Counter where+module System.Metrics.Prometheus.Metric.Counter+ ( Counter+ , CounterSample (..)+ , new+ , add+ , inc+ , sample+ ) where import Data.Atomics.Counter (AtomicCounter, incrCounter_, newCounter,
src/System/Metrics/Prometheus/Metric/Gauge.hs view
@@ -1,4 +1,14 @@-module System.Metrics.Prometheus.Metric.Gauge where+module System.Metrics.Prometheus.Metric.Gauge+ ( Gauge+ , GaugeSample (..)+ , new+ , add+ , sub+ , inc+ , dec+ , set+ , sample+ ) where import Data.IORef (IORef, atomicModifyIORef', atomicWriteIORef, newIORef, readIORef)
src/System/Metrics/Prometheus/Metric/Histogram.hs view
@@ -1,6 +1,13 @@ {-# LANGUAGE TupleSections #-} -module System.Metrics.Prometheus.Metric.Histogram where+module System.Metrics.Prometheus.Metric.Histogram+ ( Histogram+ , HistogramSample (..)+ , UpperBound+ , new+ , put+ , sample+ ) where import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef)@@ -12,31 +19,34 @@ type UpperBound = Double -- Inclusive upper bounds-type Count = Int-type Buckets = Map UpperBound Count+type Buckets = Map UpperBound Double data HistogramSample = HistogramSample { histBuckets :: Buckets , histSum :: Double- , histCount :: Count+ , histCount :: Int } new :: [UpperBound] -> IO Histogram new buckets = Histogram <$> newIORef empty- where empty = HistogramSample (Map.fromList $ map (, 0) (read "Infinity" : buckets)) 0.0 0+ where+ empty = HistogramSample (Map.fromList $ map (, 0) (read "Infinity" : buckets)) zeroSum zeroCount+ zeroSum = 0.0+ zeroCount = 0 put :: Double -> Histogram -> IO () put x ioref = atomicModifyIORef' (unHistogram ioref) update- where update histData = (hist' histData, ())- hist' histData =- histData { histBuckets = updateBuckets x $ histBuckets histData- , histSum = histSum histData + x- , histCount = histCount histData + 1- }+ where+ update histData = (hist' histData, ())+ hist' histData =+ histData { histBuckets = updateBuckets x $ histBuckets histData+ , histSum = histSum histData + x+ , histCount = histCount histData + 1+ } updateBuckets :: Double -> Buckets -> Buckets
src/System/Metrics/Prometheus/Registry.hs view
@@ -1,7 +1,15 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} -module System.Metrics.Prometheus.Registry where+module System.Metrics.Prometheus.Registry+ ( Registry+ , RegistrySample (..)+ , new+ , registerCounter+ , registerGauge+ , registerHistogram+ , sample+ ) where import Control.Exception (Exception, throw) import Data.Map (Map)@@ -14,7 +22,8 @@ import qualified System.Metrics.Prometheus.Metric.Counter as Counter import System.Metrics.Prometheus.Metric.Gauge (Gauge) import qualified System.Metrics.Prometheus.Metric.Gauge as Gauge-import System.Metrics.Prometheus.Metric.Histogram (Histogram)+import System.Metrics.Prometheus.Metric.Histogram (Histogram,+ UpperBound) import qualified System.Metrics.Prometheus.Metric.Histogram as Histogram import System.Metrics.Prometheus.MetricId (Labels, MetricId (MetricId),@@ -49,7 +58,7 @@ collision k _ _ = throw (KeyError k) -registerHistogram :: Name -> Labels -> [Histogram.UpperBound] -> Registry -> IO (Histogram, Registry)+registerHistogram :: Name -> Labels -> [UpperBound] -> Registry -> IO (Histogram, Registry) registerHistogram name labels buckets registry = do histogram <- Histogram.new buckets return (histogram, Registry $ Map.insertWithKey collision mid (HistogramMetric histogram) (unRegistry registry))