diff --git a/prometheus.cabal b/prometheus.cabal --- a/prometheus.cabal +++ b/prometheus.cabal @@ -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 diff --git a/src/System/Metrics/Prometheus/Encode.hs b/src/System/Metrics/Prometheus/Encode.hs --- a/src/System/Metrics/Prometheus/Encode.hs +++ b/src/System/Metrics/Prometheus/Encode.hs @@ -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) diff --git a/src/System/Metrics/Prometheus/Encode/Histogram.hs b/src/System/Metrics/Prometheus/Encode/Histogram.hs --- a/src/System/Metrics/Prometheus/Encode/Histogram.hs +++ b/src/System/Metrics/Prometheus/Encode/Histogram.hs @@ -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) diff --git a/src/System/Metrics/Prometheus/Encode/MetricId.hs b/src/System/Metrics/Prometheus/Encode/MetricId.hs --- a/src/System/Metrics/Prometheus/Encode/MetricId.hs +++ b/src/System/Metrics/Prometheus/Encode/MetricId.hs @@ -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 diff --git a/src/System/Metrics/Prometheus/GlobalRegistry.hs b/src/System/Metrics/Prometheus/GlobalRegistry.hs new file mode 100644 --- /dev/null +++ b/src/System/Metrics/Prometheus/GlobalRegistry.hs @@ -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 diff --git a/src/System/Metrics/Prometheus/Http.hs b/src/System/Metrics/Prometheus/Http.hs new file mode 100644 --- /dev/null +++ b/src/System/Metrics/Prometheus/Http.hs @@ -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")] diff --git a/src/System/Metrics/Prometheus/Metric/Counter.hs b/src/System/Metrics/Prometheus/Metric/Counter.hs --- a/src/System/Metrics/Prometheus/Metric/Counter.hs +++ b/src/System/Metrics/Prometheus/Metric/Counter.hs @@ -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, diff --git a/src/System/Metrics/Prometheus/Metric/Gauge.hs b/src/System/Metrics/Prometheus/Metric/Gauge.hs --- a/src/System/Metrics/Prometheus/Metric/Gauge.hs +++ b/src/System/Metrics/Prometheus/Metric/Gauge.hs @@ -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) diff --git a/src/System/Metrics/Prometheus/Metric/Histogram.hs b/src/System/Metrics/Prometheus/Metric/Histogram.hs --- a/src/System/Metrics/Prometheus/Metric/Histogram.hs +++ b/src/System/Metrics/Prometheus/Metric/Histogram.hs @@ -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 diff --git a/src/System/Metrics/Prometheus/Registry.hs b/src/System/Metrics/Prometheus/Registry.hs --- a/src/System/Metrics/Prometheus/Registry.hs +++ b/src/System/Metrics/Prometheus/Registry.hs @@ -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))