packages feed

prometheus 2.2.3 → 2.2.4

raw patch · 18 files changed

+536/−358 lines, 18 filesdep ~bytestringdep ~textdep ~transformers

Dependency ranges changed: bytestring, text, transformers

Files

Example.hs view
@@ -2,19 +2,20 @@  module Example where -import           Control.Monad.IO.Class                         (liftIO)-import           System.Metrics.Prometheus.Http.Scrape          (serveMetricsT)-import           System.Metrics.Prometheus.Concurrent.RegistryT-import           System.Metrics.Prometheus.Metric.Counter       (inc)-import           System.Metrics.Prometheus.MetricId+import Control.Monad.IO.Class (liftIO)+import System.Metrics.Prometheus.Concurrent.RegistryT+import System.Metrics.Prometheus.Http.Scrape (serveMetricsT)+import System.Metrics.Prometheus.Metric.Counter (inc)+import System.Metrics.Prometheus.MetricId + main :: IO () main = runRegistryT $ do     -- Labels can be defined as lists or added to an empty label set     connectSuccessGauge <- registerGauge "example_connections" (fromList [("login", "success")])     connectFailureGauge <- registerGauge "example_connections" (addLabel "login" "failure" mempty)     connectCounter <- registerCounter "example_connection_total" mempty-    latencyHistogram <- registerHistogram "example_round_trip_latency_ms" mempty [10, 20..100]+    latencyHistogram <- registerHistogram "example_round_trip_latency_ms" mempty [10, 20 .. 100]      liftIO $ inc connectCounter -- increment a counter
README.md view
@@ -42,7 +42,7 @@      -- [...] pass metric handles to the rest of the app -    serveMetricsT 8080 ["metrics"] -- http://localhost:8080/metric server+    serveMetricsT 8080 ["metrics"] -- http://localhost:8080/metrics server ```  ## Advanced Usage
prometheus.cabal view
@@ -1,5 +1,5 @@ name:                prometheus-version:             2.2.3+version:             2.2.4 synopsis:            Prometheus Haskell Client homepage:            http://github.com/bitnomial/prometheus bug-reports:         http://github.com/bitnomial/prometheus/issues@@ -90,8 +90,8 @@                , http-client-tls >= 0.3  && < 0.4                , http-types      >= 0.8  && < 0.13                , network-uri     >= 2.5  && < 2.7-               , text            >= 1.2  && < 1.3-               , transformers    >= 0.4  && < 0.6+               , text            >= 1.2  && < 2.1+               , transformers    >= 0.4  && < 0.7                , wai             >= 3.2  && < 3.3                , warp            >= 3.2  && < 3.5
src/System/Metrics/Prometheus/Concurrent/Registry.hs view
@@ -1,28 +1,39 @@-module System.Metrics.Prometheus.Concurrent.Registry-       ( Registry-       , new-       , registerCounter-       , registerGauge-       , registerHistogram-       , sample-       ) where-+module System.Metrics.Prometheus.Concurrent.Registry (+    Registry,+    new,+    registerCounter,+    registerGauge,+    registerHistogram,+    listMetricIds,+    removeMetric,+    sample,+) where -import           Control.Applicative                        ((<$>))-import           Control.Concurrent.MVar                    (MVar,-                                                             modifyMVarMasked,-                                                             newMVar, withMVar)-import           Data.Tuple                                 (swap)+import Control.Applicative ((<$>))+import Control.Concurrent.MVar (+    MVar,+    modifyMVarMasked,+    newMVar,+    readMVar,+    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 qualified System.Metrics.Prometheus.Registry         as R+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,+    MetricId,+    Name,+ )+import qualified System.Metrics.Prometheus.Registry as R  -newtype Registry = Registry { unRegistry :: MVar R.Registry }+newtype Registry = Registry {unRegistry :: MVar R.Registry}   new :: IO Registry@@ -45,6 +56,16 @@ registerHistogram name labels buckets = flip modifyMVarMasked register . unRegistry   where     register = fmap swap . R.registerHistogram name labels buckets+++removeMetric :: MetricId -> Registry -> IO ()+removeMetric i = flip modifyMVarMasked remove . unRegistry+  where+    remove reg = pure (R.removeMetric i reg, ())+++listMetricIds :: Registry -> IO [MetricId]+listMetricIds = fmap R.listMetricIds . readMVar . unRegistry   sample :: Registry -> IO R.RegistrySample
src/System/Metrics/Prometheus/Concurrent/RegistryT.hs view
@@ -2,24 +2,32 @@  module System.Metrics.Prometheus.Concurrent.RegistryT where -import           Control.Applicative                           ((<$>))-import           Control.Monad.IO.Class                        (MonadIO, liftIO)-import           Control.Monad.Trans.Class                     (MonadTrans)-import           Control.Monad.Trans.Reader                    (ReaderT (..),-                                                                ask)+import Control.Applicative ((<$>))+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Trans.Class (MonadTrans)+import Control.Monad.Trans.Reader (+    ReaderT (..),+    ask,+ ) -import           System.Metrics.Prometheus.Concurrent.Registry (Registry, new)+import System.Metrics.Prometheus.Concurrent.Registry (Registry, new) import qualified System.Metrics.Prometheus.Concurrent.Registry as R-import           System.Metrics.Prometheus.Metric.Counter      (Counter)-import           System.Metrics.Prometheus.Metric.Gauge        (Gauge)-import           System.Metrics.Prometheus.Metric.Histogram    (Histogram)-import qualified System.Metrics.Prometheus.Metric.Histogram    as Histogram-import           System.Metrics.Prometheus.MetricId            (Labels, Name)-import           System.Metrics.Prometheus.Registry            (RegistrySample)+import System.Metrics.Prometheus.Metric.Counter (Counter)+import System.Metrics.Prometheus.Metric.Gauge (Gauge)+import System.Metrics.Prometheus.Metric.Histogram (Histogram)+import qualified System.Metrics.Prometheus.Metric.Histogram as Histogram+import System.Metrics.Prometheus.MetricId (+    Labels,+    MetricId,+    Name,+ )+import System.Metrics.Prometheus.Registry (+    RegistrySample,+    listMetricIds,+ )  -newtype RegistryT m a =-    RegistryT { unRegistryT :: ReaderT Registry m a }+newtype RegistryT m a = RegistryT {unRegistryT :: ReaderT Registry m a}     deriving (Monad, MonadTrans, Applicative, Functor, MonadIO)  @@ -37,6 +45,14 @@  registerHistogram :: MonadIO m => Name -> Labels -> [Histogram.UpperBound] -> RegistryT m Histogram registerHistogram n l b = RegistryT ask >>= liftIO . R.registerHistogram n l b+++removeMetric :: MonadIO m => MetricId -> RegistryT m ()+removeMetric i = RegistryT ask >>= liftIO . R.removeMetric i+++listMetricIds :: MonadIO m => RegistryT m [MetricId]+listMetricIds = RegistryT ask >>= liftIO . R.listMetricIds   sample :: Monad m => RegistryT m (IO RegistrySample)
src/System/Metrics/Prometheus/Encode/Text.hs view
@@ -1,45 +1,61 @@-module System.Metrics.Prometheus.Encode.Text-       ( encodeMetrics-       ) where+module System.Metrics.Prometheus.Encode.Text (+    encodeMetrics,+) where -import           Data.ByteString.Builder                         (Builder)-import           Data.Function                                   (on)-import           Data.List                                       (groupBy,-                                                                  intersperse)-import qualified Data.Map                                        as Map-import           Data.Monoid                                     ((<>))+import Data.ByteString.Builder (Builder)+import Data.Function (on)+import Data.List (+    groupBy,+    intersperse,+ )+import qualified Data.Map as Map+import Data.Monoid ((<>)) -import           System.Metrics.Prometheus.Encode.Text.Histogram (encodeHistogram)-import           System.Metrics.Prometheus.Encode.Text.MetricId  (encodeDouble,-                                                                  encodeHeader,-                                                                  encodeInt,-                                                                  encodeMetricId,-                                                                  newline,-                                                                  space)-import           System.Metrics.Prometheus.Metric                (MetricSample (..),-                                                                  metricSample)-import           System.Metrics.Prometheus.Metric.Counter        (CounterSample (..))-import           System.Metrics.Prometheus.Metric.Gauge          (GaugeSample (..))-import           System.Metrics.Prometheus.MetricId              (MetricId (..))-import           System.Metrics.Prometheus.Registry              (RegistrySample (..))+import System.Metrics.Prometheus.Encode.Text.Histogram (encodeHistogram)+import System.Metrics.Prometheus.Encode.Text.MetricId (+    encodeDouble,+    encodeHeader,+    encodeInt,+    encodeMetricId,+    newline,+    space,+ )+import System.Metrics.Prometheus.Metric (+    MetricSample (..),+    metricSample,+ )+import System.Metrics.Prometheus.Metric.Counter (CounterSample (..))+import System.Metrics.Prometheus.Metric.Gauge (GaugeSample (..))+import System.Metrics.Prometheus.MetricId (MetricId (..))+import System.Metrics.Prometheus.Registry (RegistrySample (..))   encodeMetrics :: RegistrySample -> Builder-encodeMetrics = (<> newline) . mconcat . intersperse newline . map encodeMetricGroup-    . groupByName . Map.toList . unRegistrySample-  where groupByName = groupBy ((==) `on` (name . fst))+encodeMetrics =+    (<> newline) . mconcat . intersperse newline . map encodeMetricGroup+        . groupByName+        . Map.toList+        . unRegistrySample+  where+    groupByName = groupBy ((==) `on` (name . fst))   encodeMetricGroup :: [(MetricId, MetricSample)] -> Builder-encodeMetricGroup group = encodeHeader mid sample <> newline-    <> mconcat (intersperse newline $ map encodeMetric group)+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+encodeMetric (mid, sample) =+    metricSample+        (encodeCounter mid)+        (encodeGauge mid)+        (encodeHistogram mid)+        (encodeSummary mid)+        sample   where     encodeSummary = undefined
src/System/Metrics/Prometheus/Encode/Text/Histogram.hs view
@@ -1,44 +1,61 @@ {-# LANGUAGE OverloadedStrings #-} -module System.Metrics.Prometheus.Encode.Text.Histogram-       ( encodeHistogram-       ) where-+module System.Metrics.Prometheus.Encode.Text.Histogram (+    encodeHistogram,+) where -import           Data.ByteString.Builder                    (Builder)-import           Data.List                                  (intersperse)-import qualified Data.Map                                   as Map-import           Data.Monoid                                ((<>))+import Data.ByteString.Builder (Builder)+import Data.List (intersperse)+import qualified Data.Map as Map+import Data.Monoid ((<>)) -import           System.Metrics.Prometheus.Encode.Text.MetricId  (encodeDouble,-                                                             encodeInt,-                                                             encodeLabels,-                                                             encodeName,-                                                             newline, space,-                                                             textValue)-import           System.Metrics.Prometheus.Metric.Histogram (HistogramSample (..),-                                                             UpperBound)-import           System.Metrics.Prometheus.MetricId         (MetricId (..),-                                                             addLabel)+import System.Metrics.Prometheus.Encode.Text.MetricId (+    encodeDouble,+    encodeInt,+    encodeLabels,+    encodeName,+    newline,+    space,+    textValue,+ )+import System.Metrics.Prometheus.Metric.Histogram (+    HistogramSample (..),+    UpperBound,+ )+import System.Metrics.Prometheus.MetricId (+    MetricId (..),+    addLabel,+ )   encodeHistogram :: MetricId -> HistogramSample -> Builder-encodeHistogram mid histogram-    =  encodeHistogramBuckets mid histogram <> newline-    <> n <> "_sum"   <> ls <> space <> encodeDouble (histSum histogram) <> newline-    <> n <> "_count" <> ls <> space <> encodeInt (histCount histogram)+encodeHistogram mid 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 . intersperse newline . map snd . Map.toList-    . Map.mapWithKey (encodeHistogramBucket mid) . histBuckets+encodeHistogramBuckets mid =+    mconcat . intersperse newline . map snd . Map.toList+        . Map.mapWithKey (encodeHistogramBucket mid)+        . histBuckets   encodeHistogramBucket :: MetricId -> UpperBound -> Double -> Builder-encodeHistogramBucket mid upperBound count-    = encodeName (name mid) <> "_bucket" <> encodeLabels labels' <> space <> encodeDouble count+encodeHistogramBucket mid upperBound count =+    encodeName (name mid) <> "_bucket" <> encodeLabels labels' <> space <> encodeDouble count   where     labels' = addLabel "le" (textValue upperBound) (labels mid)
src/System/Metrics/Prometheus/Encode/Text/MetricId.hs view
@@ -1,46 +1,65 @@ {-# LANGUAGE OverloadedStrings #-} -module System.Metrics.Prometheus.Encode.Text.MetricId-       ( encodeHeader-       , encodeMetricId-       , encodeLabels-       , encodeName-       , textValue-       , encodeDouble-       , encodeInt-       , escape-       , newline-       , space-       ) where+module System.Metrics.Prometheus.Encode.Text.MetricId (+    encodeHeader,+    encodeMetricId,+    encodeLabels,+    encodeName,+    textValue,+    encodeDouble,+    encodeInt,+    escape,+    newline,+    space,+) where -import           Data.ByteString.Builder            (Builder, byteString, char8,-                                                     intDec)-import           Data.List                          (intersperse)-import           Data.Monoid                        ((<>))-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           Prelude                            hiding (null)+import Data.ByteString.Builder (+    Builder,+    byteString,+    char8,+    intDec,+ )+import Data.List (intersperse)+import Data.Monoid ((<>))+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 Prelude hiding (null) -import           System.Metrics.Prometheus.Metric   (MetricSample (..),-                                                     metricSample)-import           System.Metrics.Prometheus.MetricId (Labels (..), MetricId (..),-                                                     Name (..), null, toList)+import System.Metrics.Prometheus.Metric (+    MetricSample (..),+    metricSample,+ )+import System.Metrics.Prometheus.MetricId (+    Labels (..),+    MetricId (..),+    Name (..),+    null,+    toList,+ )   encodeHeader :: MetricId -> MetricSample -> Builder-encodeHeader mid sample-    = "# TYPE " <> nm <> space <> encodeSampleType sample+encodeHeader mid sample =+    "# TYPE " <> nm <> space <> encodeSampleType sample+  where     -- <> "# HELP " <> nm <> space <> escape "help" <> newline <>-  where nm = encodeName (name mid)+    nm = encodeName (name mid)   encodeSampleType :: MetricSample -> Builder-encodeSampleType = byteString . metricSample (const "counter")-    (const "gauge") (const "histogram") (const "summary")+encodeSampleType =+    byteString+        . metricSample+            (const "counter")+            (const "gauge")+            (const "histogram")+            (const "summary")   encodeMetricId :: MetricId -> Builder@@ -55,9 +74,9 @@ encodeLabels ls     | null ls = space     | otherwise =-             openBracket-          <> (mconcat . intersperse comma . map encodeLabel $ toList ls)-          <> closeBracket+        openBracket+            <> (mconcat . intersperse comma . map encodeLabel $ toList ls)+            <> closeBracket   encodeLabel :: (Text, Text) -> Builder@@ -65,10 +84,11 @@   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+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
src/System/Metrics/Prometheus/Http/Push.hs view
@@ -1,33 +1,38 @@ {-# LANGUAGE OverloadedStrings #-} -module System.Metrics.Prometheus.Http.Push-       ( pushMetrics-       , parseURI-       )-       where+module System.Metrics.Prometheus.Http.Push (+    pushMetrics,+    parseURI,+) where -import           Control.Concurrent                    (threadDelay)-import           Control.Monad                         (forever)-import           Data.ByteString.Builder               (toLazyByteString)-import           Data.Map                              (foldMapWithKey)-import           Data.Text                             (Text, unpack)-import           Network.HTTP.Client                   (Request (..),-                                                        RequestBody (..),-                                                        getUri,-                                                        httpNoBody,-                                                        parseRequest,-                                                        requestBody,-                                                        requestFromURI,-                                                        requestHeaders)-import           Network.HTTP.Types                    (hContentType, methodPut)-import           Network.HTTP.Client.TLS               (newTlsManager)-import           Network.URI                           (URI (..), URIAuth,-                                                        nullURI)+import Control.Concurrent (threadDelay)+import Control.Monad (forever)+import Data.ByteString.Builder (toLazyByteString)+import Data.Map (foldMapWithKey)+import Data.Text (Text, unpack)+import Network.HTTP.Client (+    Request (..),+    RequestBody (..),+    getUri,+    httpNoBody,+    parseRequest,+    requestBody,+    requestFromURI,+    requestHeaders,+ )+import Network.HTTP.Client.TLS (newTlsManager)+import Network.HTTP.Types (hContentType, methodPut)+import Network.URI (+    URI (..),+    URIAuth,+    nullURI,+ ) -import           System.Metrics.Prometheus.Encode.Text (encodeMetrics)-import           System.Metrics.Prometheus.MetricId    (Labels (..))-import           System.Metrics.Prometheus.Registry    (RegistrySample)+import System.Metrics.Prometheus.Encode.Text (encodeMetrics)+import System.Metrics.Prometheus.MetricId (Labels (..))+import System.Metrics.Prometheus.Registry (RegistrySample) + -- | Parses a uri such that -- @ --   parseURI "https://example.com"@@ -37,29 +42,40 @@ parseURI :: String -> Maybe URI parseURI = fmap getUri . parseRequest -pushMetrics :: URI               -- ^ PushGateway URI name, including port number (ex: @parseUri https://myGateway.com:8080@)-            -> Text              -- ^ Job name-            -> Labels            -- ^ Label set to use as a grouping key for metrics-            -> Int               -- ^ Microsecond push frequency-            -> IO RegistrySample -- ^ Action to get latest metrics-            -> IO ()++pushMetrics ::+    -- | PushGateway URI name, including port number (ex: @parseUri https://myGateway.com:8080@)+    URI ->+    -- | Job name+    Text ->+    -- | Label set to use as a grouping key for metrics+    Labels ->+    -- | Microsecond push frequency+    Int ->+    -- | Action to get latest metrics+    IO RegistrySample ->+    IO () pushMetrics gatewayURI jobName labels frequencyMicros getSample = do-    manager    <- newTlsManager-    gn         <- maybe (error "Invalid URI Authority") pure gatewayName+    manager <- newTlsManager+    gn <- maybe (error "Invalid URI Authority") pure gatewayName     requestUri <- requestFromURI $ buildUri scheme gn jobName labels     forever $ getSample >>= flip httpNoBody manager . request requestUri >> threadDelay frequencyMicros   where     URI scheme gatewayName _ _ _ = gatewayURI-    request req sample = req-        { method         = methodPut-        , requestBody    = RequestBodyLBS . toLazyByteString $ encodeMetrics sample-        , requestHeaders = [(hContentType, "text/plain; version=0.0.4")]-        }+    request req sample =+        req+            { method = methodPut+            , requestBody = RequestBodyLBS . toLazyByteString $ encodeMetrics sample+            , requestHeaders = [(hContentType, "text/plain; version=0.0.4")]+            } + buildUri :: String -> URIAuth -> Text -> Labels -> URI-buildUri scheme gatewayName jobName (Labels ls) = nullURI-    { uriScheme    = scheme-    , uriAuthority = Just gatewayName-    , uriPath      = "/metrics/job/" ++ unpack jobName ++ foldMapWithKey labelPath ls-    }-  where labelPath k v = "/" ++ unpack k ++ "/" ++ unpack v+buildUri scheme gatewayName jobName (Labels ls) =+    nullURI+        { uriScheme = scheme+        , uriAuthority = Just gatewayName+        , uriPath = "/metrics/job/" ++ unpack jobName ++ foldMapWithKey labelPath ls+        }+  where+    labelPath k v = "/" ++ unpack k ++ "/" ++ unpack v
src/System/Metrics/Prometheus/Http/Scrape.hs view
@@ -1,34 +1,41 @@ {-# LANGUAGE OverloadedStrings #-} -module System.Metrics.Prometheus.Http.Scrape-       ( Path-       , serveMetrics-       , serveMetricsT-       , prometheusApp-       )-       where+module System.Metrics.Prometheus.Http.Scrape (+    Path,+    serveMetrics,+    serveMetricsT,+    prometheusApp,+) where -import           Control.Applicative                            ((<$>))-import           Control.Monad.IO.Class                         (MonadIO,-                                                                 liftIO)-import           Data.Text                                      (Text)-import           Network.HTTP.Types                             (hContentType,-                                                                 methodGet,-                                                                 status200,-                                                                 status404)-import           Network.Wai                                    (Application,-                                                                 Request,-                                                                 Response,-                                                                 pathInfo,-                                                                 requestMethod,-                                                                 responseBuilder,-                                                                 responseLBS)-import           Network.Wai.Handler.Warp                       (Port, run)+import Control.Applicative ((<$>))+import Control.Monad.IO.Class (+    MonadIO,+    liftIO,+ )+import Data.Text (Text)+import Network.HTTP.Types (+    hContentType,+    methodGet,+    status200,+    status404,+ )+import Network.Wai (+    Application,+    Request,+    Response,+    pathInfo,+    requestMethod,+    responseBuilder,+    responseLBS,+ )+import Network.Wai.Handler.Warp (Port, run) -import           System.Metrics.Prometheus.Concurrent.RegistryT (RegistryT,-                                                                 sample)-import           System.Metrics.Prometheus.Encode.Text          (encodeMetrics)-import           System.Metrics.Prometheus.Registry             (RegistrySample)+import System.Metrics.Prometheus.Concurrent.RegistryT (+    RegistryT,+    sample,+ )+import System.Metrics.Prometheus.Encode.Text (encodeMetrics)+import System.Metrics.Prometheus.Registry (RegistrySample)   -- | The HTTP web route on which to serve data
src/System/Metrics/Prometheus/Metric.hs view
@@ -1,18 +1,22 @@ module System.Metrics.Prometheus.Metric where -import           System.Metrics.Prometheus.Metric.Counter   (Counter,-                                                             CounterSample)-import           System.Metrics.Prometheus.Metric.Gauge     (Gauge, GaugeSample)-import           System.Metrics.Prometheus.Metric.Histogram (Histogram,-                                                             HistogramSample)-import           System.Metrics.Prometheus.Metric.Summary   (SummarySample)+import System.Metrics.Prometheus.Metric.Counter (+    Counter,+    CounterSample,+ )+import System.Metrics.Prometheus.Metric.Gauge (Gauge, GaugeSample)+import System.Metrics.Prometheus.Metric.Histogram (+    Histogram,+    HistogramSample,+ )+import System.Metrics.Prometheus.Metric.Summary (SummarySample)   data Metric     = CounterMetric Counter     | GaugeMetric Gauge-    -- | Summary S.Summary-    | HistogramMetric Histogram+    | -- | Summary S.Summary+      HistogramMetric Histogram   data MetricSample@@ -22,10 +26,14 @@     | SummaryMetricSample SummarySample  -metricSample :: (CounterSample -> a) -> (GaugeSample -> a)-             -> (HistogramSample -> a) -> (SummarySample -> a)-             -> MetricSample -> a-metricSample f _ _ _ (CounterMetricSample s)   = f s-metricSample _ f _ _ (GaugeMetricSample s)     = f s+metricSample ::+    (CounterSample -> a) ->+    (GaugeSample -> a) ->+    (HistogramSample -> a) ->+    (SummarySample -> a) ->+    MetricSample ->+    a+metricSample f _ _ _ (CounterMetricSample s) = f s+metricSample _ f _ _ (GaugeMetricSample s) = f s metricSample _ _ f _ (HistogramMetricSample s) = f s-metricSample _ _ _ f (SummaryMetricSample s)   = f s+metricSample _ _ _ f (SummaryMetricSample s) = f s
src/System/Metrics/Prometheus/Metric/Counter.hs view
@@ -1,20 +1,21 @@-module System.Metrics.Prometheus.Metric.Counter-       ( Counter-       , CounterSample (..)-       , new-       , add-       , inc-       , sample-       , addAndSample-       ) where-+module System.Metrics.Prometheus.Metric.Counter (+    Counter,+    CounterSample (..),+    new,+    add,+    inc,+    sample,+    addAndSample,+    set,+) where -import           Control.Applicative  ((<$>))-import           Data.Atomics.Counter (AtomicCounter, incrCounter, newCounter)+import Control.Applicative ((<$>))+import Control.Monad (when)+import Data.Atomics.Counter (AtomicCounter, incrCounter, newCounter, writeCounter)  -newtype Counter = Counter { unCounter :: AtomicCounter }-newtype CounterSample = CounterSample { unCounterSample :: Int }+newtype Counter = Counter {unCounter :: AtomicCounter}+newtype CounterSample = CounterSample {unCounterSample :: Int}   new :: IO Counter@@ -22,8 +23,9 @@   addAndSample :: Int -> Counter -> IO CounterSample-addAndSample by | by >= 0   = fmap CounterSample . incrCounter by . unCounter-                | otherwise = error "must be >= 0"+addAndSample by+    | by >= 0 = fmap CounterSample . incrCounter by . unCounter+    | otherwise = error "must be >= 0"   add :: Int -> Counter -> IO ()@@ -36,3 +38,15 @@  sample :: Counter -> IO CounterSample sample = addAndSample 0+++-- | Write @i@ to the counter, if @i@ is more than the current value. This is+-- useful for when the count is maintained by a separate system (e.g. GHC's GC+-- counter).+--+-- WARNING: For multiple writers, the most recent one wins, which may not+-- preserve the increasing property. If you have stronger requirements than this,+-- please check with the maintainers. +-- See <https://github.com/bitnomial/prometheus/pull/44> for discussion.+set :: Int -> Counter -> IO ()+set i (Counter c) = writeCounter c i
src/System/Metrics/Prometheus/Metric/Gauge.hs view
@@ -1,22 +1,22 @@-module System.Metrics.Prometheus.Metric.Gauge-       ( Gauge-       , GaugeSample (..)-       , new-       , add-       , sub-       , inc-       , dec-       , set-       , sample-       , modifyAndSample-       ) where+module System.Metrics.Prometheus.Metric.Gauge (+    Gauge,+    GaugeSample (..),+    new,+    add,+    sub,+    inc,+    dec,+    set,+    sample,+    modifyAndSample,+) where -import           Control.Applicative ((<$>))-import           Data.IORef          (IORef, atomicModifyIORef', newIORef)+import Control.Applicative ((<$>))+import Data.IORef (IORef, atomicModifyIORef', newIORef)  -newtype Gauge = Gauge { unGauge :: IORef Double }-newtype GaugeSample = GaugeSample { unGaugeSample :: Double }+newtype Gauge = Gauge {unGauge :: IORef Double}+newtype GaugeSample = GaugeSample {unGaugeSample :: Double}   new :: IO Gauge@@ -25,7 +25,8 @@  modifyAndSample :: (Double -> Double) -> Gauge -> IO GaugeSample modifyAndSample f = flip atomicModifyIORef' g . unGauge-  where g v = (f v, GaugeSample $ f v)+  where+    g v = (f v, GaugeSample $ f v)   add :: Double -> Gauge -> IO ()
src/System/Metrics/Prometheus/Metric/Histogram.hs view
@@ -1,45 +1,47 @@ {-# LANGUAGE TupleSections #-} -module System.Metrics.Prometheus.Metric.Histogram-       ( Histogram-       , HistogramSample (..)-       , Buckets-       , UpperBound-       , new-       , observe-       , sample-       , observeAndSample-       ) where-+module System.Metrics.Prometheus.Metric.Histogram (+    Histogram,+    HistogramSample (..),+    Buckets,+    UpperBound,+    new,+    observe,+    sample,+    observeAndSample,+) where -import           Control.Applicative ((<$>))-import           Control.Monad       (void)-import           Data.Bool           (bool)-import           Data.IORef          (IORef, atomicModifyIORef', newIORef,-                                      readIORef)-import           Data.Map.Strict     (Map)-import qualified Data.Map.Strict     as Map+import Control.Applicative ((<$>))+import Control.Monad (void)+import Data.Bool (bool)+import Data.IORef (+    IORef,+    atomicModifyIORef',+    newIORef,+    readIORef,+ )+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map  -newtype Histogram = Histogram { unHistogram :: IORef HistogramSample }+newtype Histogram = Histogram {unHistogram :: IORef HistogramSample}   type UpperBound = Double -- Inclusive upper bounds type Buckets = Map UpperBound Double  -data HistogramSample =-    HistogramSample+data HistogramSample = HistogramSample     { histBuckets :: !Buckets-    , histSum     :: !Double-    , histCount   :: !Int+    , histSum :: !Double+    , histCount :: !Int     }   new :: [UpperBound] -> IO Histogram new buckets = Histogram <$> newIORef empty   where-    empty = HistogramSample (Map.fromList $ map (, 0) (read "Infinity" : buckets)) zeroSum zeroCount+    empty = HistogramSample (Map.fromList $ map (,0) (read "Infinity" : buckets)) zeroSum zeroCount     zeroSum = 0.0     zeroCount = 0 @@ -49,10 +51,11 @@   where     update histData = (hist' histData, histData)     hist' histData =-        histData { histBuckets = updateBuckets x $ histBuckets histData-                 , histSum = histSum histData + x-                 , histCount = histCount histData + 1-                 }+        histData+            { histBuckets = updateBuckets x $ histBuckets histData+            , histSum = histSum histData + x+            , histCount = histCount histData + 1+            }   observe :: Double -> Histogram -> IO ()@@ -61,7 +64,8 @@  updateBuckets :: Double -> Buckets -> Buckets updateBuckets x = Map.mapWithKey updateBucket-  where updateBucket key val = bool val (val + 1) (x <= key)+  where+    updateBucket key val = bool val (val + 1) (x <= key)   sample :: Histogram -> IO HistogramSample
src/System/Metrics/Prometheus/Metric/Summary.hs view
@@ -1,10 +1,10 @@ module System.Metrics.Prometheus.Metric.Summary where -import           Data.Map.Strict (Map)+import Data.Map.Strict (Map) -data SummarySample =-    SummarySample++data SummarySample = SummarySample     { sumQuantiles :: !(Map Double Int)-    , sumSum       :: !Int-    , sumCount     :: !Int+    , sumSum :: !Int+    , sumCount :: !Int     }
src/System/Metrics/Prometheus/MetricId.hs view
@@ -1,33 +1,36 @@-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}  module System.Metrics.Prometheus.MetricId where -import           Data.Char (isDigit)-import           Data.Bifunctor (first)-import           Data.Map       (Map)-import qualified Data.Map       as Map-import           Data.Monoid    (Monoid)-import           Data.Semigroup (Semigroup)-import           Data.String    (IsString(..))-import           Data.Text      (Text)+import Data.Bifunctor (first)+import Data.Char (isDigit)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Monoid (Monoid)+import Data.Semigroup (Semigroup)+import Data.String (IsString (..))+import Data.Text (Text) import qualified Data.Text as Text-import           Prelude        hiding (null)+import Prelude hiding (null) + -- | Construct with 'makeName' to ensure that names use only valid characters-newtype Name = Name { unName :: Text } deriving (Show, Eq, Ord, Monoid, Semigroup)+newtype Name = Name {unName :: Text} deriving (Show, Eq, Ord, Monoid, Semigroup) + instance IsString Name where-  fromString = makeName . Text.pack+    fromString = makeName . Text.pack -newtype Labels = Labels { unLabels :: Map Text Text } deriving (Show, Eq, Ord, Monoid, Semigroup) +newtype Labels = Labels {unLabels :: Map Text Text} deriving (Show, Eq, Ord, Monoid, Semigroup) -data MetricId =-    MetricId-    { name   :: Name++data MetricId = MetricId+    { name :: Name     , labels :: Labels-    } deriving (Eq, Ord, Show)+    }+    deriving (Eq, Ord, Show)   addLabel :: Text -> Text -> Labels -> Labels@@ -53,7 +56,7 @@ -- first character is only valid as a later character. makeValid :: Text -> Text makeValid "" = "_"-makeValid txt = prefix_ <> Text.map (\c -> if allowedChar c then c else '_' ) txt+makeValid txt = prefix_ <> Text.map (\c -> if allowedChar c then c else '_') txt   where     prefix_ = if isDigit (Text.head txt) then "_" else ""     allowedChar :: Char -> Bool
src/System/Metrics/Prometheus/Registry.hs view
@@ -1,37 +1,47 @@ {-# LANGUAGE DeriveDataTypeable #-} -module System.Metrics.Prometheus.Registry-       ( Registry-       , RegistrySample (..)-       , new-       , registerCounter-       , registerGauge-       , registerHistogram-       , sample-       ) where+module System.Metrics.Prometheus.Registry (+    Registry,+    RegistrySample (..),+    new,+    registerCounter,+    registerGauge,+    registerHistogram,+    listMetricIds,+    removeMetric,+    sample,+) where -import           Control.Applicative                        ((<$>))-import           Control.Exception                          (Exception, throw)-import           Data.Map                                   (Map)-import qualified Data.Map                                   as Map-import           Data.Typeable                              (Typeable)+import Control.Applicative ((<$>))+import Control.Exception (Exception, throw)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Typeable (Typeable) -import           System.Metrics.Prometheus.Metric           (Metric (..),-                                                             MetricSample (..))-import           System.Metrics.Prometheus.Metric.Counter   (Counter)-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,-                                                             UpperBound)+import System.Metrics.Prometheus.Metric (+    Metric (..),+    MetricSample (..),+ )+import System.Metrics.Prometheus.Metric.Counter (Counter)+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,+    UpperBound,+ ) import qualified System.Metrics.Prometheus.Metric.Histogram as Histogram-import           System.Metrics.Prometheus.MetricId         (Labels (..),-                                                             MetricId (MetricId),-                                                             Name (..))+import System.Metrics.Prometheus.MetricId (+    Labels (..),+    MetricId (MetricId),+    Name (..),+ ) -newtype Registry = Registry { unRegistry :: Map MetricId Metric }-newtype RegistrySample = RegistrySample { unRegistrySample :: Map MetricId MetricSample } +newtype Registry = Registry {unRegistry :: Map MetricId Metric}+newtype RegistrySample = RegistrySample {unRegistrySample :: Map MetricId MetricSample}++ newtype KeyError = KeyError MetricId deriving (Show, Typeable) instance Exception KeyError @@ -45,8 +55,8 @@     counter <- Counter.new     return (counter, Registry $ Map.insertWithKey collision mid (CounterMetric counter) (unRegistry registry))   where-      mid = MetricId name labels-      collision k _ _ = throw (KeyError k)+    mid = MetricId name labels+    collision k _ _ = throw (KeyError k)   registerGauge :: Name -> Labels -> Registry -> IO (Gauge, Registry)@@ -54,8 +64,8 @@     gauge <- Gauge.new     return (gauge, Registry $ Map.insertWithKey collision mid (GaugeMetric gauge) (unRegistry registry))   where-      mid = MetricId name labels-      collision k _ _ = throw (KeyError k)+    mid = MetricId name labels+    collision k _ _ = throw (KeyError k)   registerHistogram :: Name -> Labels -> [UpperBound] -> Registry -> IO (Histogram, Registry)@@ -63,8 +73,16 @@     histogram <- Histogram.new buckets     return (histogram, Registry $ Map.insertWithKey collision mid (HistogramMetric histogram) (unRegistry registry))   where-      mid = MetricId name labels-      collision k _ _ = throw (KeyError k)+    mid = MetricId name labels+    collision k _ _ = throw (KeyError k)+++removeMetric :: MetricId -> Registry -> Registry+removeMetric i (Registry m) = Registry . Map.delete i $ m+++listMetricIds :: Registry -> [MetricId]+listMetricIds = Map.keys . unRegistry   sample :: Registry -> IO RegistrySample
src/System/Metrics/Prometheus/RegistryT.hs view
@@ -2,26 +2,34 @@  module System.Metrics.Prometheus.RegistryT where -import           Control.Applicative                        ((<$>))-import           Control.Monad.IO.Class                     (MonadIO, liftIO)-import           Control.Monad.Trans.Class                  (MonadTrans)-import           Control.Monad.Trans.State.Strict           (StateT (..),-                                                             evalStateT,-                                                             execStateT, get)+import Control.Applicative ((<$>))+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Trans.Class (MonadTrans)+import Control.Monad.Trans.State.Strict (+    StateT (..),+    evalStateT,+    execStateT,+    get,+ ) -import           System.Metrics.Prometheus.Metric.Counter   (Counter)-import           System.Metrics.Prometheus.Metric.Gauge     (Gauge)-import           System.Metrics.Prometheus.Metric.Histogram (Histogram)+import System.Metrics.Prometheus.Metric.Counter (Counter)+import System.Metrics.Prometheus.Metric.Gauge (Gauge)+import System.Metrics.Prometheus.Metric.Histogram (Histogram) import qualified System.Metrics.Prometheus.Metric.Histogram as Histogram-import           System.Metrics.Prometheus.MetricId         (Labels, Name)-import           System.Metrics.Prometheus.Registry         (Registry,-                                                             RegistrySample,-                                                             new)-import qualified System.Metrics.Prometheus.Registry         as R+import System.Metrics.Prometheus.MetricId (+    Labels,+    MetricId,+    Name,+ )+import System.Metrics.Prometheus.Registry (+    Registry,+    RegistrySample,+    new,+ )+import qualified System.Metrics.Prometheus.Registry as R  -newtype RegistryT m a =-    RegistryT { unRegistryT :: StateT Registry m a }+newtype RegistryT m a = RegistryT {unRegistryT :: StateT Registry m a}     deriving (Monad, MonadTrans, Applicative, Functor, MonadIO)  @@ -51,6 +59,14 @@  registerHistogram :: MonadIO m => Name -> Labels -> [Histogram.UpperBound] -> RegistryT m Histogram registerHistogram n l u = withRegistry (liftIO . R.registerHistogram n l u)+++removeMetric :: MonadIO m => MetricId -> RegistryT m ()+removeMetric i = withRegistry (pure . (,) () . R.removeMetric i)+++listMetricIds :: MonadIO m => RegistryT m [MetricId]+listMetricIds = R.listMetricIds <$> RegistryT get   sample :: Monad m => RegistryT m (IO RegistrySample)