├── .dir-locals.el ├── .github └── workflows │ └── ci.yml ├── .gitignore ├── .hgignore ├── .travis.yml ├── CHANGELOG.md ├── Example.hs ├── LICENSE ├── README.md ├── Setup.hs ├── fourmolu.yaml ├── hie.yaml ├── prometheus.cabal ├── src └── System │ └── Metrics │ └── Prometheus │ ├── Concurrent │ ├── Registry.hs │ └── RegistryT.hs │ ├── Encode │ ├── Text.hs │ └── Text │ │ ├── Histogram.hs │ │ └── MetricId.hs │ ├── Http │ ├── Push.hs │ └── Scrape.hs │ ├── Metric.hs │ ├── Metric │ ├── Counter.hs │ ├── Gauge.hs │ ├── Histogram.hs │ └── Summary.hs │ ├── MetricId.hs │ ├── Registry.hs │ └── RegistryT.hs ├── stack-8.10.yaml ├── stack-9.0.yaml ├── stack-9.2.yaml ├── stack-9.4.yaml ├── stack-9.6.yaml ├── stack.yaml └── stack.yaml.lock /.dir-locals.el: -------------------------------------------------------------------------------- 1 | ;;; Directory Local Variables 2 | ;;; For more information see (info "(emacs) Directory Variables") 3 | 4 | ((nil 5 | (fill-column . 100) 6 | (tab-width . 4) 7 | (indent-tabs-mode . nil) 8 | ) 9 | (haskell-mode 10 | (haskell-indentation-layout-offset . 4) 11 | (haskell-indentation-left-offset . 4) 12 | (haskell-indentation-starter-offset . 4) 13 | (haskell-process-type . stack-ghci) 14 | (haskell-stylish-on-save . nil) 15 | (lsp-haskell-formatting-provider . "fourmolu") 16 | (ormolu-process-path . "fourmolu") 17 | ) 18 | (haskell-cabal-mode 19 | (haskell-process-type . stack-ghci) 20 | ) 21 | (yaml-mode 22 | (tab-width . 2) 23 | ) 24 | ) 25 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: 4 | pull_request: 5 | push: 6 | branches: [master] 7 | 8 | jobs: 9 | cabal: 10 | name: cabal / ghc-${{ matrix.ghc }} / ${{ matrix.os }} 11 | runs-on: ${{ matrix.os }} 12 | strategy: 13 | matrix: 14 | os: 15 | - ubuntu-latest 16 | # - macOS-latest 17 | cabal: 18 | - "latest" 19 | ghc: 20 | - "8.10.7" 21 | - "9.0.2" 22 | - "9.2.8" 23 | - "9.4.8" 24 | - "9.6.6" 25 | - "9.8.2" 26 | - "9.10.1" 27 | 28 | steps: 29 | - uses: actions/checkout@v4 30 | 31 | - uses: haskell-actions/setup@v2 32 | id: setup-haskell-cabal 33 | name: Setup Haskell 34 | with: 35 | ghc-version: ${{ matrix.ghc }} 36 | cabal-version: ${{ matrix.cabal }} 37 | 38 | - uses: actions/cache@v3 39 | name: Cache cabal-store 40 | with: 41 | path: ${{ steps.setup-haskell-cabal.outputs.cabal-store }} 42 | key: ${{ matrix.os }}-${{ matrix.ghc }}-cabal 43 | 44 | - name: Build 45 | run: | 46 | cabal update 47 | cabal build package:prometheus --enable-tests --enable-benchmarks --write-ghc-environment-files=always --flags="buildexamples" 48 | 49 | # TODO: Actually add tests 50 | # - name: Test 51 | # run: | 52 | # cabal test package:prometheus --enable-tests 53 | 54 | stack: 55 | name: stack ${{ matrix.resolver }} / ${{ matrix.os }} 56 | runs-on: ${{ matrix.os }} 57 | strategy: 58 | matrix: 59 | os: 60 | - ubuntu-latest 61 | # - macOS-latest 62 | stack: ["latest"] 63 | resolver: 64 | - "--stack-yaml ./stack-8.10.yaml" 65 | - "--stack-yaml ./stack-9.0.yaml" 66 | - "--stack-yaml ./stack-9.2.yaml" 67 | - "--stack-yaml ./stack-9.4.yaml" 68 | - "--stack-yaml ./stack-9.6.yaml" 69 | 70 | steps: 71 | - uses: actions/checkout@v4 72 | 73 | - uses: haskell-actions/setup@v2 74 | name: Setup Haskell Stack 75 | with: 76 | stack-version: ${{ matrix.stack }} 77 | enable-stack: true 78 | 79 | - uses: actions/cache@v3 80 | name: Cache ~/.stack 81 | with: 82 | path: ~/.stack 83 | key: ${{ matrix.os }}-stack-${{ matrix.resolver }} 84 | 85 | - name: Build 86 | run: | 87 | stack build --test --bench --no-run-tests --no-run-benchmarks --flag prometheus:buildexamples 88 | 89 | # TODO: Actually add tests 90 | # - name: Test 91 | # run: | 92 | # stack test 93 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | #*# 2 | .#* 3 | .DS_Store 4 | .cabal-sandbox/ 5 | .hpc/ 6 | .tix 7 | cabal.sandbox.config 8 | dist/ 9 | **/.stack-work/ 10 | -------------------------------------------------------------------------------- /.hgignore: -------------------------------------------------------------------------------- 1 | syntax: regexp 2 | ~$ 3 | \#.*\#$ 4 | \.\# 5 | \.DS_Store$ 6 | \.cabal-sandbox/ 7 | \.hpc/ 8 | \.tix$ 9 | cabal\.sandbox\.config$ 10 | dist/ 11 | \.stack-work/ 12 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | sudo: required 2 | 3 | os: linux 4 | dist: xenial 5 | 6 | env: 7 | - GHCVER=8.0.2 8 | - GHCVER=8.2.2 9 | - GHCVER=8.4.4 10 | - GHCVER=8.6.5 11 | 12 | cache: 13 | directories: 14 | - $HOME/.ghc 15 | - $HOME/.cabal 16 | 17 | before_install: 18 | - sudo add-apt-repository -y ppa:hvr/ghc 19 | - sudo apt-get update 20 | - sudo apt-get install alex-3.1.7 happy-1.19.5 cabal-install-3.0 ghc-$GHCVER 21 | - export PATH=/opt/cabal/bin:/opt/ghc/$GHCVER/bin:/opt/alex/3.1.7/bin:/opt/happy/1.19.5/bin:$PATH 22 | 23 | install: 24 | - cabal-3.0 update 25 | 26 | script: 27 | - cabal-3.0 configure --enable-tests 28 | - cabal-3.0 build 29 | - cabal-3.0 test --test-show-details=streaming 30 | - cabal-3.0 check 31 | - cabal-3.0 haddock 32 | - cabal-3.0 sdist 33 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | 2 | ## 2.3.0 3 | 4 | * Change the `observeAndSample` function from the 5 | `System.Metrics.Prometheus.Metric.Histogram` module to return the value of 6 | the sample that was just added, instead of the previous sample. 7 | This change matches similar functions for `Counter`s and `Gauge`s. 8 | [#51](https://github.com/bitnomial/prometheus/pull/51) 9 | -------------------------------------------------------------------------------- /Example.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Main where 4 | 5 | import Control.Monad.IO.Class (liftIO) 6 | import System.Metrics.Prometheus.Concurrent.RegistryT 7 | import System.Metrics.Prometheus.Http.Scrape (serveMetricsT) 8 | import System.Metrics.Prometheus.Metric.Counter (inc) 9 | import System.Metrics.Prometheus.MetricId 10 | 11 | 12 | main :: IO () 13 | main = runRegistryT $ do 14 | -- Labels can be defined as lists or added to an empty label set 15 | connectSuccessGauge <- registerGauge "example_connections" (fromList [("login", "success")]) 16 | connectFailureGauge <- registerGauge "example_connections" (addLabel "login" "failure" mempty) 17 | connectCounter <- registerCounter "example_connection_total" mempty 18 | latencyHistogram <- registerHistogram "example_round_trip_latency_ms" mempty [10, 20 .. 100] 19 | 20 | liftIO $ inc connectCounter -- increment a counter 21 | 22 | -- [...] pass metric handles to the rest of the app 23 | 24 | serveMetricsT 8080 ["metrics"] -- http://localhost:8080/metric server 25 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | BSD 3-Clause License 2 | 3 | Copyright (c) 2016-present, Bitnomial, Inc. 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | 9 | * Redistributions of source code must retain the above copyright notice, this 10 | list of conditions and the following disclaimer. 11 | 12 | * Redistributions in binary form must reproduce the above copyright notice, 13 | this list of conditions and the following disclaimer in the documentation 14 | and/or other materials provided with the distribution. 15 | 16 | * Neither the name of the copyright holder nor the names of its 17 | contributors may be used to endorse or promote products derived from 18 | this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 21 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 22 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 23 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 24 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 25 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 26 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 27 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 28 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Prometheus Haskell Client 2 | 3 | [![Build Status](https://travis-ci.com/bitnomial/prometheus.svg?branch=master)](https://travis-ci.com/bitnomial/prometheus) 4 | [![Hackage](https://img.shields.io/hackage/v/prometheus.svg)](https://hackage.haskell.org/package/prometheus) 5 | 6 | A simple and modern, type safe, performance focused, idiomatic Haskell client 7 | for [Prometheus](http://prometheus.io) monitoring. Specifically there is 8 | no use of unsafe IO or manual ByteString construction from lists of 9 | bytes. Batteries-included web server. 10 | 11 | A key design element of this library is that the RegistryT monad transformer 12 | is only required for registering new time series. Once the time series is 13 | registered, new data samples may just be added in the IO monad. 14 | 15 | Note: Version 0.* supports Prometheus v1.0 and version 2.* supports Prometheus v2.0. 16 | 17 | - [Hackage Package](https://hackage.haskell.org/package/prometheus) 18 | - [Github Repo](http://github.com/bitnomial/prometheus) 19 | 20 | ## Usage Example 21 | 22 | ```haskell 23 | {-# LANGUAGE OverloadedStrings #-} 24 | 25 | module Example where 26 | 27 | import Control.Monad.IO.Class (liftIO) 28 | import System.Metrics.Prometheus.Http.Scrape (serveMetricsT) 29 | import System.Metrics.Prometheus.Concurrent.RegistryT 30 | import System.Metrics.Prometheus.Metric.Counter (inc) 31 | import System.Metrics.Prometheus.MetricId 32 | 33 | main :: IO () 34 | main = runRegistryT $ do 35 | -- Labels can be defined as lists or added to an empty label set 36 | connectSuccessGauge <- registerGauge "example_connections" (fromList [("login", "success")]) 37 | connectFailureGauge <- registerGauge "example_connections" (addLabel "login" "failure" mempty) 38 | connectCounter <- registerCounter "example_connection_total" mempty 39 | latencyHistogram <- registerHistogram "example_round_trip_latency_ms" mempty [10, 20..100] 40 | 41 | liftIO $ inc connectCounter -- increment a counter 42 | 43 | -- [...] pass metric handles to the rest of the app 44 | 45 | serveMetricsT 8080 ["metrics"] -- http://localhost:8080/metrics server 46 | ``` 47 | 48 | ## Advanced Usage 49 | 50 | A `Registry` and `StateT`-based `RegistryT` are available for unit 51 | testing or generating lists of `[IO a]` actions that can be 52 | `sequenced` and returned from pure code to be applied. 53 | 54 | ## Concurrency Model 55 | 56 | Metrics are "values" and the Registry is the map of "name_labels" to metric "keys". 57 | 58 | Metrics may be created/registered at any point, not just at start up, in the `RegistryT` monad transformer. Thread the `RegistryT` through your transformer stack to tell the type system you intend to register new metrics in that call stack. The `RegistryT` has a thread safe version in the `Concurrent` module. 59 | 60 | The metrics are thread safe on their own and do not require locking the entire registry to update them. They use high performance check-and-set atomic primitives. This is because metrics may be updated many times in between scrapes where the Reigstry needs to be lock. You do NOT want to lock all the metrics just to update one. 61 | 62 | The scraping operation of the server to collect all the metrics locks the registry to ensure no new metrics are being created/keyed in a race with the scrape. 63 | 64 | ## Tasks 65 | 66 | - [ ] Implement help docstrings. 67 | - [ ] Implement GHC-specific metrics. 68 | - [ ] Implement [summary metric](https://github.com/prometheus/client_golang/blob/master/prometheus/summary.go). 69 | - [ ] Encode name and labels on register. 70 | - [x] Implement ReaderT for Concurrent Registry. 71 | - [x] Library documentation and example. 72 | - [x] [Name and label validation](http://prometheus.io/docs/concepts/data_model/#metric-names-and-labels) 73 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /fourmolu.yaml: -------------------------------------------------------------------------------- 1 | indentation: 4 2 | comma-style: leading # for lists, tuples etc. - can also be 'trailing' 3 | record-brace-space: false # rec {x = 1} vs. rec{x = 1} 4 | indent-wheres: false # 'false' means save space by only half-indenting the 'where' keyword 5 | diff-friendly-import-export: true # 'false' uses Ormolu-style lists 6 | respectful: true # don't be too opinionated about newlines etc. 7 | haddock-style: single-line # '--' vs. '{-' 8 | newlines-between-decls: 2 9 | -------------------------------------------------------------------------------- /hie.yaml: -------------------------------------------------------------------------------- 1 | --- 2 | 3 | cradle: 4 | stack: 5 | - component: "prometheus:lib" 6 | path: "./src/" 7 | -------------------------------------------------------------------------------- /prometheus.cabal: -------------------------------------------------------------------------------- 1 | name: prometheus 2 | version: 2.3.0 3 | synopsis: Prometheus Haskell Client 4 | homepage: http://github.com/bitnomial/prometheus 5 | bug-reports: http://github.com/bitnomial/prometheus/issues 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Luke Hoersten 9 | maintainer: luke@bitnomial.com, opensource@bitnomial.com 10 | copyright: Bitnomial, Inc. (c) 2016-2023 11 | category: Metrics, Monitoring, Web, System 12 | build-type: Simple 13 | cabal-version: >=1.10 14 | 15 | description: 16 | [Prometheus Haskell Client] 17 | . 18 | A simple and modern, type safe, performance focused, idiomatic Haskell client 19 | for monitoring. Specifically there is no 20 | use of unsafe IO or manual ByteString construction from lists of 21 | bytes. Batteries-included web server. 22 | . 23 | A key design element of this library is that the RegistryT monad transformer 24 | is only required for registering new time series. Once the time series is 25 | registered, new data samples may just be added in the IO monad. 26 | . 27 | Note: Version 0.* supports Prometheus v1.0 and version 2.* supports Prometheus v2.0. 28 | . 29 | [Usage Example] 30 | . 31 | > module Example where 32 | > 33 | > import Control.Monad.IO.Class (liftIO) 34 | > import System.Metrics.Prometheus.Http.Scrape (serveMetricsT) 35 | > import System.Metrics.Prometheus.Concurrent.RegistryT 36 | > import System.Metrics.Prometheus.Metric.Counter (inc) 37 | > import System.Metrics.Prometheus.MetricId 38 | > 39 | > main :: IO () 40 | > main = runRegistryT $ do 41 | > -- Labels can be defined as lists or added to an empty label set 42 | > connectSuccessGauge <- registerGauge "example_connections" (fromList [("login", "success")]) 43 | > connectFailureGauge <- registerGauge "example_connections" (addLabel "login" "failure" mempty) 44 | > connectCounter <- registerCounter "example_connection_total" mempty 45 | > latencyHistogram <- registerHistogram "example_round_trip_latency_ms" mempty [10, 20..100] 46 | > 47 | > liftIO $ inc connectCounter -- increment a counter 48 | > 49 | > -- [...] pass metric handles to the rest of the app 50 | > 51 | > serveMetricsT 8080 ["metrics"] -- http://localhost:8080/metric server 52 | > 53 | . 54 | [Advanced Usage] 55 | . 56 | A `Registry` and `StateT`-based `RegistryT` are available for unit testing or generating lists 57 | of `[IO a]` actions that can be `sequenced` and returned from pure code to be applied. 58 | 59 | 60 | extra-source-files: Example.hs 61 | , README.md 62 | 63 | -- This flag builds the Example.hs file. It is only used for testing. It 64 | -- is enabled in CI. 65 | flag buildexamples 66 | description: Build the Example.hs file. This is normally only used for testing. 67 | default: False 68 | 69 | library 70 | hs-source-dirs: src 71 | default-language: Haskell2010 72 | 73 | ghc-options: -Wall -fwarn-tabs -fno-warn-unused-do-bind 74 | 75 | exposed-modules: System.Metrics.Prometheus.Concurrent.Registry 76 | , System.Metrics.Prometheus.Concurrent.RegistryT 77 | , System.Metrics.Prometheus.Encode.Text 78 | , System.Metrics.Prometheus.Encode.Text.Histogram 79 | , System.Metrics.Prometheus.Encode.Text.MetricId 80 | , System.Metrics.Prometheus.Http.Push 81 | , System.Metrics.Prometheus.Http.Scrape 82 | , System.Metrics.Prometheus.Metric 83 | , System.Metrics.Prometheus.Metric.Counter 84 | , System.Metrics.Prometheus.Metric.Gauge 85 | , System.Metrics.Prometheus.Metric.Histogram 86 | , System.Metrics.Prometheus.Metric.Summary 87 | , System.Metrics.Prometheus.MetricId 88 | , System.Metrics.Prometheus.Registry 89 | , System.Metrics.Prometheus.RegistryT 90 | 91 | build-depends: base >= 4.9 && < 5 92 | , atomic-primops >= 0.8 && < 0.9 93 | , bytestring >= 0.10 && < 0.13 94 | , containers >= 0.5 && < 0.8 95 | , http-client >= 0.4 && < 0.8 96 | , http-client-tls >= 0.3 && < 0.4 97 | , http-types >= 0.8 && < 0.13 98 | , network-uri >= 2.5 && < 2.7 99 | , text >= 1.2 && < 2.2 100 | , transformers >= 0.4 && < 0.7 101 | , wai >= 3.2 && < 3.3 102 | , warp >= 3.2 && < 3.5 103 | 104 | executable prometheus-example 105 | main-is: Example.hs 106 | default-language: Haskell2010 107 | 108 | ghc-options: -Wall -fwarn-tabs -fno-warn-unused-do-bind 109 | 110 | build-depends: base 111 | , prometheus 112 | 113 | if flag(buildexamples) 114 | buildable: True 115 | else 116 | buildable: False 117 | 118 | source-repository head 119 | type: git 120 | location: https://github.com/bitnomial/prometheus 121 | -------------------------------------------------------------------------------- /src/System/Metrics/Prometheus/Concurrent/Registry.hs: -------------------------------------------------------------------------------- 1 | module System.Metrics.Prometheus.Concurrent.Registry ( 2 | Registry, 3 | new, 4 | registerCounter, 5 | registerGauge, 6 | registerHistogram, 7 | listMetricIds, 8 | removeMetric, 9 | sample, 10 | ) where 11 | 12 | import Control.Applicative ((<$>)) 13 | import Control.Concurrent.MVar ( 14 | MVar, 15 | modifyMVarMasked, 16 | newMVar, 17 | readMVar, 18 | withMVar, 19 | ) 20 | import Data.Tuple (swap) 21 | 22 | import System.Metrics.Prometheus.Metric.Counter (Counter) 23 | import System.Metrics.Prometheus.Metric.Gauge (Gauge) 24 | import System.Metrics.Prometheus.Metric.Histogram ( 25 | Histogram, 26 | UpperBound, 27 | ) 28 | import System.Metrics.Prometheus.MetricId ( 29 | Labels, 30 | MetricId, 31 | Name, 32 | ) 33 | import qualified System.Metrics.Prometheus.Registry as R 34 | 35 | 36 | newtype Registry = Registry {unRegistry :: MVar R.Registry} 37 | 38 | 39 | new :: IO Registry 40 | new = Registry <$> newMVar R.new 41 | 42 | 43 | registerCounter :: Name -> Labels -> Registry -> IO Counter 44 | registerCounter name labels = flip modifyMVarMasked register . unRegistry 45 | where 46 | register = fmap swap . R.registerCounter name labels 47 | 48 | 49 | registerGauge :: Name -> Labels -> Registry -> IO Gauge 50 | registerGauge name labels = flip modifyMVarMasked register . unRegistry 51 | where 52 | register = fmap swap . R.registerGauge name labels 53 | 54 | 55 | registerHistogram :: Name -> Labels -> [UpperBound] -> Registry -> IO Histogram 56 | registerHistogram name labels buckets = flip modifyMVarMasked register . unRegistry 57 | where 58 | register = fmap swap . R.registerHistogram name labels buckets 59 | 60 | 61 | removeMetric :: MetricId -> Registry -> IO () 62 | removeMetric i = flip modifyMVarMasked remove . unRegistry 63 | where 64 | remove reg = pure (R.removeMetric i reg, ()) 65 | 66 | 67 | listMetricIds :: Registry -> IO [MetricId] 68 | listMetricIds = fmap R.listMetricIds . readMVar . unRegistry 69 | 70 | 71 | sample :: Registry -> IO R.RegistrySample 72 | sample = flip withMVar R.sample . unRegistry 73 | -------------------------------------------------------------------------------- /src/System/Metrics/Prometheus/Concurrent/RegistryT.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | 3 | module System.Metrics.Prometheus.Concurrent.RegistryT where 4 | 5 | import Control.Applicative ((<$>)) 6 | import Control.Monad.IO.Class (MonadIO, liftIO) 7 | import Control.Monad.Trans.Class (MonadTrans) 8 | import Control.Monad.Trans.Reader ( 9 | ReaderT (..), 10 | ask, 11 | ) 12 | 13 | import System.Metrics.Prometheus.Concurrent.Registry (Registry, new) 14 | import qualified System.Metrics.Prometheus.Concurrent.Registry as R 15 | import System.Metrics.Prometheus.Metric.Counter (Counter) 16 | import System.Metrics.Prometheus.Metric.Gauge (Gauge) 17 | import System.Metrics.Prometheus.Metric.Histogram (Histogram) 18 | import qualified System.Metrics.Prometheus.Metric.Histogram as Histogram 19 | import System.Metrics.Prometheus.MetricId ( 20 | Labels, 21 | MetricId, 22 | Name, 23 | ) 24 | import System.Metrics.Prometheus.Registry ( 25 | RegistrySample, 26 | listMetricIds, 27 | ) 28 | 29 | 30 | newtype RegistryT m a = RegistryT {unRegistryT :: ReaderT Registry m a} 31 | deriving (Monad, MonadTrans, Applicative, Functor, MonadIO) 32 | 33 | 34 | runRegistryT :: MonadIO m => RegistryT m a -> m a 35 | runRegistryT registry = liftIO new >>= runReaderT (unRegistryT registry) 36 | 37 | 38 | registerCounter :: MonadIO m => Name -> Labels -> RegistryT m Counter 39 | registerCounter n l = RegistryT ask >>= liftIO . R.registerCounter n l 40 | 41 | 42 | registerGauge :: MonadIO m => Name -> Labels -> RegistryT m Gauge 43 | registerGauge n l = RegistryT ask >>= liftIO . R.registerGauge n l 44 | 45 | 46 | registerHistogram :: MonadIO m => Name -> Labels -> [Histogram.UpperBound] -> RegistryT m Histogram 47 | registerHistogram n l b = RegistryT ask >>= liftIO . R.registerHistogram n l b 48 | 49 | 50 | removeMetric :: MonadIO m => MetricId -> RegistryT m () 51 | removeMetric i = RegistryT ask >>= liftIO . R.removeMetric i 52 | 53 | 54 | listMetricIds :: MonadIO m => RegistryT m [MetricId] 55 | listMetricIds = RegistryT ask >>= liftIO . R.listMetricIds 56 | 57 | 58 | sample :: Monad m => RegistryT m (IO RegistrySample) 59 | sample = R.sample <$> RegistryT ask 60 | -------------------------------------------------------------------------------- /src/System/Metrics/Prometheus/Encode/Text.hs: -------------------------------------------------------------------------------- 1 | module System.Metrics.Prometheus.Encode.Text ( 2 | encodeMetrics, 3 | ) where 4 | 5 | import Data.ByteString.Builder (Builder) 6 | import Data.Function (on) 7 | import Data.List ( 8 | groupBy, 9 | intersperse, 10 | ) 11 | import qualified Data.Map as Map 12 | import Data.Monoid ((<>)) 13 | 14 | import System.Metrics.Prometheus.Encode.Text.Histogram (encodeHistogram) 15 | import System.Metrics.Prometheus.Encode.Text.MetricId ( 16 | encodeDouble, 17 | encodeHeader, 18 | encodeInt, 19 | encodeMetricId, 20 | newline, 21 | space, 22 | ) 23 | import System.Metrics.Prometheus.Metric ( 24 | MetricSample (..), 25 | metricSample, 26 | ) 27 | import System.Metrics.Prometheus.Metric.Counter (CounterSample (..)) 28 | import System.Metrics.Prometheus.Metric.Gauge (GaugeSample (..)) 29 | import System.Metrics.Prometheus.MetricId (MetricId (..)) 30 | import System.Metrics.Prometheus.Registry (RegistrySample (..)) 31 | 32 | 33 | encodeMetrics :: RegistrySample -> Builder 34 | encodeMetrics = 35 | (<> newline) . mconcat . intersperse newline . map encodeMetricGroup 36 | . groupByName 37 | . Map.toList 38 | . unRegistrySample 39 | where 40 | groupByName = groupBy ((==) `on` (name . fst)) 41 | 42 | 43 | encodeMetricGroup :: [(MetricId, MetricSample)] -> Builder 44 | encodeMetricGroup group = 45 | encodeHeader mid sample <> newline 46 | <> mconcat (intersperse newline $ map encodeMetric group) 47 | where 48 | (mid, sample) = head group 49 | 50 | 51 | encodeMetric :: (MetricId, MetricSample) -> Builder 52 | encodeMetric (mid, sample) = 53 | metricSample 54 | (encodeCounter mid) 55 | (encodeGauge mid) 56 | (encodeHistogram mid) 57 | (encodeSummary mid) 58 | sample 59 | where 60 | encodeSummary = undefined 61 | 62 | 63 | encodeCounter :: MetricId -> CounterSample -> Builder 64 | encodeCounter mid counter = encodeMetricId mid <> space <> encodeInt (unCounterSample counter) 65 | 66 | 67 | encodeGauge :: MetricId -> GaugeSample -> Builder 68 | encodeGauge mid gauge = encodeMetricId mid <> space <> encodeDouble (unGaugeSample gauge) 69 | -------------------------------------------------------------------------------- /src/System/Metrics/Prometheus/Encode/Text/Histogram.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module System.Metrics.Prometheus.Encode.Text.Histogram ( 4 | encodeHistogram, 5 | ) where 6 | 7 | import Data.ByteString.Builder (Builder) 8 | import Data.List (intersperse) 9 | import qualified Data.Map as Map 10 | import Data.Monoid ((<>)) 11 | 12 | import System.Metrics.Prometheus.Encode.Text.MetricId ( 13 | encodeDouble, 14 | encodeInt, 15 | encodeLabels, 16 | encodeName, 17 | newline, 18 | space, 19 | textValue, 20 | ) 21 | import System.Metrics.Prometheus.Metric.Histogram ( 22 | HistogramSample (..), 23 | UpperBound, 24 | ) 25 | import System.Metrics.Prometheus.MetricId ( 26 | MetricId (..), 27 | addLabel, 28 | ) 29 | 30 | 31 | encodeHistogram :: MetricId -> HistogramSample -> Builder 32 | encodeHistogram mid histogram = 33 | encodeHistogramBuckets mid histogram <> newline 34 | <> n 35 | <> "_sum" 36 | <> ls 37 | <> space 38 | <> encodeDouble (histSum histogram) 39 | <> newline 40 | <> n 41 | <> "_count" 42 | <> ls 43 | <> space 44 | <> encodeInt (histCount histogram) 45 | where 46 | n = encodeName $ name mid 47 | ls = encodeLabels $ labels mid 48 | 49 | 50 | encodeHistogramBuckets :: MetricId -> HistogramSample -> Builder 51 | encodeHistogramBuckets mid = 52 | mconcat . intersperse newline . map snd . Map.toList 53 | . Map.mapWithKey (encodeHistogramBucket mid) 54 | . histBuckets 55 | 56 | 57 | encodeHistogramBucket :: MetricId -> UpperBound -> Double -> Builder 58 | encodeHistogramBucket mid upperBound count = 59 | encodeName (name mid) <> "_bucket" <> encodeLabels labels' <> space <> encodeDouble count 60 | where 61 | labels' = addLabel "le" (textValue upperBound) (labels mid) 62 | -------------------------------------------------------------------------------- /src/System/Metrics/Prometheus/Encode/Text/MetricId.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module System.Metrics.Prometheus.Encode.Text.MetricId ( 4 | encodeHeader, 5 | encodeMetricId, 6 | encodeLabels, 7 | encodeName, 8 | textValue, 9 | encodeDouble, 10 | encodeInt, 11 | escape, 12 | newline, 13 | space, 14 | ) where 15 | 16 | import Data.ByteString.Builder ( 17 | Builder, 18 | byteString, 19 | char8, 20 | intDec, 21 | ) 22 | import Data.List (intersperse) 23 | import Data.Monoid ((<>)) 24 | import Data.Text (Text, replace) 25 | import Data.Text.Encoding (encodeUtf8) 26 | import Data.Text.Lazy (toStrict) 27 | import Data.Text.Lazy.Builder (toLazyText) 28 | import Data.Text.Lazy.Builder.RealFloat ( 29 | FPFormat (Generic), 30 | formatRealFloat, 31 | ) 32 | import Prelude hiding (null) 33 | 34 | import System.Metrics.Prometheus.Metric ( 35 | MetricSample (..), 36 | metricSample, 37 | ) 38 | import System.Metrics.Prometheus.MetricId ( 39 | Labels (..), 40 | MetricId (..), 41 | Name (..), 42 | null, 43 | toList, 44 | ) 45 | 46 | 47 | encodeHeader :: MetricId -> MetricSample -> Builder 48 | encodeHeader mid sample = 49 | "# TYPE " <> nm <> space <> encodeSampleType sample 50 | where 51 | -- <> "# HELP " <> nm <> space <> escape "help" <> newline <> 52 | nm = encodeName (name mid) 53 | 54 | 55 | encodeSampleType :: MetricSample -> Builder 56 | encodeSampleType = 57 | byteString 58 | . metricSample 59 | (const "counter") 60 | (const "gauge") 61 | (const "histogram") 62 | (const "summary") 63 | 64 | 65 | encodeMetricId :: MetricId -> Builder 66 | encodeMetricId mid = encodeName (name mid) <> encodeLabels (labels mid) 67 | 68 | 69 | encodeName :: Name -> Builder 70 | encodeName = text . unName 71 | 72 | 73 | encodeLabels :: Labels -> Builder 74 | encodeLabels ls 75 | | null ls = space 76 | | otherwise = 77 | openBracket 78 | <> (mconcat . intersperse comma . map encodeLabel $ toList ls) 79 | <> closeBracket 80 | 81 | 82 | encodeLabel :: (Text, Text) -> Builder 83 | encodeLabel (key, val) = text key <> equals <> quote <> text (escape val) <> quote 84 | 85 | 86 | textValue :: RealFloat f => f -> Text 87 | textValue x 88 | | isInfinite x && x > 0 = "+Inf" 89 | | isInfinite x && x < 0 = "-Inf" 90 | | isNaN x = "NaN" 91 | | otherwise = toStrict . toLazyText $ formatRealFloat Generic Nothing x 92 | 93 | 94 | encodeDouble :: RealFloat f => f -> Builder 95 | encodeDouble = text . textValue 96 | 97 | 98 | encodeInt :: Int -> Builder 99 | encodeInt = intDec 100 | 101 | 102 | text :: Text -> Builder 103 | text = byteString . encodeUtf8 104 | 105 | 106 | escape :: Text -> Text 107 | escape = replace "\n" "\\n" . replace "\"" "\\\"" . replace "\\" "\\\\" 108 | 109 | 110 | space :: Builder 111 | space = char8 ' ' 112 | 113 | 114 | newline :: Builder 115 | newline = char8 '\n' 116 | 117 | 118 | openBracket :: Builder 119 | openBracket = char8 '{' 120 | 121 | 122 | closeBracket :: Builder 123 | closeBracket = char8 '}' 124 | 125 | 126 | comma :: Builder 127 | comma = char8 ',' 128 | 129 | 130 | equals :: Builder 131 | equals = char8 '=' 132 | 133 | 134 | quote :: Builder 135 | quote = char8 '"' 136 | -------------------------------------------------------------------------------- /src/System/Metrics/Prometheus/Http/Push.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module System.Metrics.Prometheus.Http.Push ( 4 | pushMetrics, 5 | parseURI, 6 | ) where 7 | 8 | import Control.Concurrent (threadDelay) 9 | import Control.Monad (forever) 10 | import Data.ByteString.Builder (toLazyByteString) 11 | import Data.Map (foldMapWithKey) 12 | import Data.Text (Text, unpack) 13 | import Network.HTTP.Client ( 14 | Request (..), 15 | RequestBody (..), 16 | getUri, 17 | httpNoBody, 18 | parseRequest, 19 | requestBody, 20 | requestFromURI, 21 | requestHeaders, 22 | ) 23 | import Network.HTTP.Client.TLS (newTlsManager) 24 | import Network.HTTP.Types (hContentType, methodPut) 25 | import Network.URI ( 26 | URI (..), 27 | URIAuth, 28 | nullURI, 29 | ) 30 | 31 | import System.Metrics.Prometheus.Encode.Text (encodeMetrics) 32 | import System.Metrics.Prometheus.MetricId (Labels (..)) 33 | import System.Metrics.Prometheus.Registry (RegistrySample) 34 | 35 | 36 | -- | Parses a uri such that 37 | -- @ 38 | -- parseURI "https://example.com" 39 | -- === 40 | -- Just (URI "https:" "//example.com" 41 | -- @ 42 | parseURI :: String -> Maybe URI 43 | parseURI = fmap getUri . parseRequest 44 | 45 | 46 | pushMetrics :: 47 | -- | PushGateway URI name, including port number (ex: @parseUri https://myGateway.com:8080@) 48 | URI -> 49 | -- | Job name 50 | Text -> 51 | -- | Label set to use as a grouping key for metrics 52 | Labels -> 53 | -- | Microsecond push frequency 54 | Int -> 55 | -- | Action to get latest metrics 56 | IO RegistrySample -> 57 | IO () 58 | pushMetrics gatewayURI jobName labels frequencyMicros getSample = do 59 | manager <- newTlsManager 60 | gn <- maybe (error "Invalid URI Authority") pure gatewayName 61 | requestUri <- requestFromURI $ buildUri scheme gn jobName labels 62 | forever $ getSample >>= flip httpNoBody manager . request requestUri >> threadDelay frequencyMicros 63 | where 64 | URI scheme gatewayName _ _ _ = gatewayURI 65 | request req sample = 66 | req 67 | { method = methodPut 68 | , requestBody = RequestBodyLBS . toLazyByteString $ encodeMetrics sample 69 | , requestHeaders = [(hContentType, "text/plain; version=0.0.4")] 70 | } 71 | 72 | 73 | buildUri :: String -> URIAuth -> Text -> Labels -> URI 74 | buildUri scheme gatewayName jobName (Labels ls) = 75 | nullURI 76 | { uriScheme = scheme 77 | , uriAuthority = Just gatewayName 78 | , uriPath = "/metrics/job/" ++ unpack jobName ++ foldMapWithKey labelPath ls 79 | } 80 | where 81 | labelPath k v = "/" ++ unpack k ++ "/" ++ unpack v 82 | -------------------------------------------------------------------------------- /src/System/Metrics/Prometheus/Http/Scrape.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module System.Metrics.Prometheus.Http.Scrape ( 4 | Path, 5 | serveMetrics, 6 | serveMetricsT, 7 | prometheusApp, 8 | ) where 9 | 10 | import Control.Applicative ((<$>)) 11 | import Control.Monad.IO.Class ( 12 | MonadIO, 13 | liftIO, 14 | ) 15 | import Data.Text (Text) 16 | import Network.HTTP.Types ( 17 | hContentType, 18 | methodGet, 19 | status200, 20 | status404, 21 | ) 22 | import Network.Wai ( 23 | Application, 24 | Request, 25 | Response, 26 | pathInfo, 27 | requestMethod, 28 | responseBuilder, 29 | responseLBS, 30 | ) 31 | import Network.Wai.Handler.Warp (Port, run) 32 | 33 | import System.Metrics.Prometheus.Concurrent.RegistryT ( 34 | RegistryT, 35 | sample, 36 | ) 37 | import System.Metrics.Prometheus.Encode.Text (encodeMetrics) 38 | import System.Metrics.Prometheus.Registry (RegistrySample) 39 | 40 | 41 | -- | The HTTP web route on which to serve data 42 | -- 43 | -- For example: 44 | -- 45 | -- * @http://localhost:9090/metrics@ should use a path of @["metrics"]@. 46 | -- * @http://localhost/@ should use a path of @[]@. 47 | type Path = [Text] 48 | 49 | 50 | serveMetrics :: MonadIO m => Port -> Path -> IO RegistrySample -> m () 51 | serveMetrics port path = liftIO . run port . prometheusApp path 52 | 53 | 54 | serveMetricsT :: MonadIO m => Port -> Path -> RegistryT m () 55 | serveMetricsT port path = liftIO . serveMetrics port path =<< sample 56 | 57 | 58 | prometheusApp :: Path -> IO RegistrySample -> Application 59 | prometheusApp path runSample request respond 60 | | isPrometheusRequest path request = respond =<< prometheusResponse <$> runSample 61 | | otherwise = respond response404 62 | where 63 | prometheusResponse = responseBuilder status200 headers . encodeMetrics 64 | headers = [(hContentType, "text/plain; version=0.0.4")] 65 | 66 | 67 | response404 :: Response 68 | response404 = responseLBS status404 header404 body404 69 | where 70 | header404 = [(hContentType, "text/plain")] 71 | body404 = "404" 72 | 73 | 74 | isPrometheusRequest :: Path -> Request -> Bool 75 | isPrometheusRequest path request = isGet && matchesPath 76 | where 77 | matchesPath = pathInfo request == path 78 | isGet = requestMethod request == methodGet 79 | -------------------------------------------------------------------------------- /src/System/Metrics/Prometheus/Metric.hs: -------------------------------------------------------------------------------- 1 | module System.Metrics.Prometheus.Metric where 2 | 3 | import System.Metrics.Prometheus.Metric.Counter ( 4 | Counter, 5 | CounterSample, 6 | ) 7 | import System.Metrics.Prometheus.Metric.Gauge (Gauge, GaugeSample) 8 | import System.Metrics.Prometheus.Metric.Histogram ( 9 | Histogram, 10 | HistogramSample, 11 | ) 12 | import System.Metrics.Prometheus.Metric.Summary (SummarySample) 13 | 14 | 15 | data Metric 16 | = CounterMetric Counter 17 | | GaugeMetric Gauge 18 | | -- | Summary S.Summary 19 | HistogramMetric Histogram 20 | 21 | 22 | data MetricSample 23 | = CounterMetricSample CounterSample 24 | | GaugeMetricSample GaugeSample 25 | | HistogramMetricSample HistogramSample 26 | | SummaryMetricSample SummarySample 27 | 28 | 29 | metricSample :: 30 | (CounterSample -> a) -> 31 | (GaugeSample -> a) -> 32 | (HistogramSample -> a) -> 33 | (SummarySample -> a) -> 34 | MetricSample -> 35 | a 36 | metricSample f _ _ _ (CounterMetricSample s) = f s 37 | metricSample _ f _ _ (GaugeMetricSample s) = f s 38 | metricSample _ _ f _ (HistogramMetricSample s) = f s 39 | metricSample _ _ _ f (SummaryMetricSample s) = f s 40 | -------------------------------------------------------------------------------- /src/System/Metrics/Prometheus/Metric/Counter.hs: -------------------------------------------------------------------------------- 1 | module System.Metrics.Prometheus.Metric.Counter ( 2 | Counter, 3 | CounterSample (..), 4 | new, 5 | add, 6 | inc, 7 | sample, 8 | addAndSample, 9 | set, 10 | ) where 11 | 12 | import Control.Applicative ((<$>)) 13 | import Control.Monad (when) 14 | import Data.Atomics.Counter (AtomicCounter, incrCounter, newCounter, writeCounter) 15 | 16 | 17 | newtype Counter = Counter {unCounter :: AtomicCounter} 18 | newtype CounterSample = CounterSample {unCounterSample :: Int} deriving Show 19 | 20 | 21 | new :: IO Counter 22 | new = Counter <$> newCounter 0 23 | 24 | 25 | addAndSample :: Int -> Counter -> IO CounterSample 26 | addAndSample by 27 | | by >= 0 = fmap CounterSample . incrCounter by . unCounter 28 | | otherwise = error "must be >= 0" 29 | 30 | 31 | add :: Int -> Counter -> IO () 32 | add by c = addAndSample by c >> pure () 33 | 34 | 35 | inc :: Counter -> IO () 36 | inc = add 1 37 | 38 | 39 | sample :: Counter -> IO CounterSample 40 | sample = addAndSample 0 41 | 42 | 43 | -- | Write @i@ to the counter, if @i@ is more than the current value. This is 44 | -- useful for when the count is maintained by a separate system (e.g. GHC's GC 45 | -- counter). 46 | -- 47 | -- WARNING: For multiple writers, the most recent one wins, which may not 48 | -- preserve the increasing property. If you have stronger requirements than this, 49 | -- please check with the maintainers. 50 | -- See for discussion. 51 | set :: Int -> Counter -> IO () 52 | set i (Counter c) = writeCounter c i 53 | -------------------------------------------------------------------------------- /src/System/Metrics/Prometheus/Metric/Gauge.hs: -------------------------------------------------------------------------------- 1 | module System.Metrics.Prometheus.Metric.Gauge ( 2 | Gauge, 3 | GaugeSample (..), 4 | new, 5 | add, 6 | sub, 7 | inc, 8 | dec, 9 | set, 10 | sample, 11 | modifyAndSample, 12 | ) where 13 | 14 | import Control.Applicative ((<$>)) 15 | import Data.IORef (IORef, atomicModifyIORef', newIORef) 16 | 17 | 18 | newtype Gauge = Gauge {unGauge :: IORef Double} 19 | newtype GaugeSample = GaugeSample {unGaugeSample :: Double} deriving Show 20 | 21 | 22 | new :: IO Gauge 23 | new = Gauge <$> newIORef 0 24 | 25 | 26 | modifyAndSample :: (Double -> Double) -> Gauge -> IO GaugeSample 27 | modifyAndSample f = flip atomicModifyIORef' g . unGauge 28 | where 29 | g v = (f v, GaugeSample $ f v) 30 | 31 | 32 | add :: Double -> Gauge -> IO () 33 | add x g = modifyAndSample (+ x) g >> pure () 34 | 35 | 36 | sub :: Double -> Gauge -> IO () 37 | sub x g = modifyAndSample (subtract x) g >> pure () 38 | 39 | 40 | inc :: Gauge -> IO () 41 | inc = add 1 42 | 43 | 44 | dec :: Gauge -> IO () 45 | dec = sub 1 46 | 47 | 48 | set :: Double -> Gauge -> IO () 49 | set x g = modifyAndSample (const x) g >> pure () 50 | 51 | 52 | sample :: Gauge -> IO GaugeSample 53 | sample = modifyAndSample id 54 | -------------------------------------------------------------------------------- /src/System/Metrics/Prometheus/Metric/Histogram.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TupleSections #-} 2 | 3 | module System.Metrics.Prometheus.Metric.Histogram ( 4 | Histogram, 5 | HistogramSample (..), 6 | Buckets, 7 | UpperBound, 8 | new, 9 | observe, 10 | sample, 11 | observeAndSample, 12 | ) where 13 | 14 | import Control.Applicative ((<$>)) 15 | import Control.Monad (void) 16 | import Data.Bool (bool) 17 | import Data.IORef ( 18 | IORef, 19 | atomicModifyIORef', 20 | newIORef, 21 | readIORef, 22 | ) 23 | import Data.Map.Strict (Map) 24 | import qualified Data.Map.Strict as Map 25 | 26 | 27 | newtype Histogram = Histogram {unHistogram :: IORef HistogramSample} 28 | 29 | 30 | type UpperBound = Double -- Inclusive upper bounds 31 | type Buckets = Map UpperBound Double 32 | 33 | 34 | data HistogramSample = HistogramSample 35 | { histBuckets :: !Buckets 36 | , histSum :: !Double 37 | , histCount :: !Int 38 | } 39 | deriving Show 40 | 41 | 42 | new :: [UpperBound] -> IO Histogram 43 | new buckets = Histogram <$> newIORef empty 44 | where 45 | empty = HistogramSample (Map.fromList $ map (,0) (read "Infinity" : buckets)) zeroSum zeroCount 46 | zeroSum = 0.0 47 | zeroCount = 0 48 | 49 | 50 | observeAndSample :: Double -> Histogram -> IO HistogramSample 51 | observeAndSample x = flip atomicModifyIORef' update . unHistogram 52 | where 53 | update histData = (hist' histData, hist' histData) 54 | hist' histData = 55 | histData 56 | { histBuckets = updateBuckets x $ histBuckets histData 57 | , histSum = histSum histData + x 58 | , histCount = histCount histData + 1 59 | } 60 | 61 | 62 | observe :: Double -> Histogram -> IO () 63 | observe x = void . observeAndSample x 64 | 65 | 66 | updateBuckets :: Double -> Buckets -> Buckets 67 | updateBuckets x = Map.mapWithKey updateBucket 68 | where 69 | updateBucket key val = bool val (val + 1) (x <= key) 70 | 71 | 72 | sample :: Histogram -> IO HistogramSample 73 | sample = readIORef . unHistogram 74 | -------------------------------------------------------------------------------- /src/System/Metrics/Prometheus/Metric/Summary.hs: -------------------------------------------------------------------------------- 1 | module System.Metrics.Prometheus.Metric.Summary where 2 | 3 | import Data.Map.Strict (Map) 4 | 5 | 6 | data SummarySample = SummarySample 7 | { sumQuantiles :: !(Map Double Int) 8 | , sumSum :: !Int 9 | , sumCount :: !Int 10 | } 11 | deriving Show 12 | -------------------------------------------------------------------------------- /src/System/Metrics/Prometheus/MetricId.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module System.Metrics.Prometheus.MetricId where 5 | 6 | import Data.Bifunctor (first) 7 | import Data.Char (isDigit) 8 | import Data.Map (Map) 9 | import qualified Data.Map as Map 10 | import Data.Monoid (Monoid) 11 | import Data.Semigroup (Semigroup) 12 | import Data.String (IsString (..)) 13 | import Data.Text (Text) 14 | import qualified Data.Text as Text 15 | import Prelude hiding (null) 16 | 17 | 18 | -- | Construct with 'makeName' to ensure that names use only valid characters 19 | newtype Name = Name {unName :: Text} deriving (Show, Eq, Ord, Monoid, Semigroup) 20 | 21 | 22 | instance IsString Name where 23 | fromString = makeName . Text.pack 24 | 25 | 26 | newtype Labels = Labels {unLabels :: Map Text Text} deriving (Show, Eq, Ord, Monoid, Semigroup) 27 | 28 | 29 | data MetricId = MetricId 30 | { name :: Name 31 | , labels :: Labels 32 | } 33 | deriving (Eq, Ord, Show) 34 | 35 | 36 | addLabel :: Text -> Text -> Labels -> Labels 37 | addLabel key val = Labels . Map.insert (makeValid key) val . unLabels 38 | 39 | 40 | fromList :: [(Text, Text)] -> Labels 41 | fromList = Labels . Map.fromList . map (first makeValid) 42 | 43 | 44 | toList :: Labels -> [(Text, Text)] 45 | toList = Map.toList . unLabels 46 | 47 | 48 | null :: Labels -> Bool 49 | null = Map.null . unLabels 50 | 51 | 52 | -- | Make the input match the regex @[a-zA-Z_][a-zA-Z0-9_]@ which 53 | -- defines valid metric and label names, according to 54 | -- 55 | -- Replace invalid characters with @_@ and add a leading @_@ if the 56 | -- first character is only valid as a later character. 57 | makeValid :: Text -> Text 58 | makeValid "" = "_" 59 | makeValid txt = prefix_ <> Text.map (\c -> if allowedChar c then c else '_') txt 60 | where 61 | prefix_ = if isDigit (Text.head txt) then "_" else "" 62 | allowedChar :: Char -> Bool 63 | allowedChar c = (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') || isDigit c || c == '_' 64 | 65 | 66 | -- | Construct a 'Name', replacing disallowed characters. 67 | makeName :: Text -> Name 68 | makeName = Name . makeValid 69 | -------------------------------------------------------------------------------- /src/System/Metrics/Prometheus/Registry.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | 3 | module System.Metrics.Prometheus.Registry ( 4 | Registry, 5 | RegistrySample (..), 6 | new, 7 | registerCounter, 8 | registerGauge, 9 | registerHistogram, 10 | listMetricIds, 11 | removeMetric, 12 | sample, 13 | ) where 14 | 15 | import Control.Applicative ((<$>)) 16 | import Control.Exception (Exception, throw) 17 | import Data.Map (Map) 18 | import qualified Data.Map as Map 19 | import Data.Typeable (Typeable) 20 | 21 | import System.Metrics.Prometheus.Metric ( 22 | Metric (..), 23 | MetricSample (..), 24 | ) 25 | import System.Metrics.Prometheus.Metric.Counter (Counter) 26 | import qualified System.Metrics.Prometheus.Metric.Counter as Counter 27 | import System.Metrics.Prometheus.Metric.Gauge (Gauge) 28 | import qualified System.Metrics.Prometheus.Metric.Gauge as Gauge 29 | import System.Metrics.Prometheus.Metric.Histogram ( 30 | Histogram, 31 | UpperBound, 32 | ) 33 | import qualified System.Metrics.Prometheus.Metric.Histogram as Histogram 34 | import System.Metrics.Prometheus.MetricId ( 35 | Labels (..), 36 | MetricId (MetricId), 37 | Name (..), 38 | ) 39 | 40 | 41 | newtype Registry = Registry {unRegistry :: Map MetricId Metric} 42 | newtype RegistrySample = RegistrySample {unRegistrySample :: Map MetricId MetricSample} 43 | 44 | 45 | newtype KeyError = KeyError MetricId deriving (Show, Typeable) 46 | instance Exception KeyError 47 | 48 | 49 | new :: Registry 50 | new = Registry Map.empty 51 | 52 | 53 | registerCounter :: Name -> Labels -> Registry -> IO (Counter, Registry) 54 | registerCounter name labels registry = do 55 | counter <- Counter.new 56 | return (counter, Registry $ Map.insertWithKey collision mid (CounterMetric counter) (unRegistry registry)) 57 | where 58 | mid = MetricId name labels 59 | collision k _ _ = throw (KeyError k) 60 | 61 | 62 | registerGauge :: Name -> Labels -> Registry -> IO (Gauge, Registry) 63 | registerGauge name labels registry = do 64 | gauge <- Gauge.new 65 | return (gauge, Registry $ Map.insertWithKey collision mid (GaugeMetric gauge) (unRegistry registry)) 66 | where 67 | mid = MetricId name labels 68 | collision k _ _ = throw (KeyError k) 69 | 70 | 71 | registerHistogram :: Name -> Labels -> [UpperBound] -> Registry -> IO (Histogram, Registry) 72 | registerHistogram name labels buckets registry = do 73 | histogram <- Histogram.new buckets 74 | return (histogram, Registry $ Map.insertWithKey collision mid (HistogramMetric histogram) (unRegistry registry)) 75 | where 76 | mid = MetricId name labels 77 | collision k _ _ = throw (KeyError k) 78 | 79 | 80 | removeMetric :: MetricId -> Registry -> Registry 81 | removeMetric i (Registry m) = Registry . Map.delete i $ m 82 | 83 | 84 | listMetricIds :: Registry -> [MetricId] 85 | listMetricIds = Map.keys . unRegistry 86 | 87 | 88 | sample :: Registry -> IO RegistrySample 89 | sample = fmap RegistrySample . mapM sampleMetric . unRegistry 90 | where 91 | sampleMetric :: Metric -> IO MetricSample 92 | sampleMetric (CounterMetric count) = CounterMetricSample <$> Counter.sample count 93 | sampleMetric (GaugeMetric gauge) = GaugeMetricSample <$> Gauge.sample gauge 94 | sampleMetric (HistogramMetric histogram) = HistogramMetricSample <$> Histogram.sample histogram 95 | -------------------------------------------------------------------------------- /src/System/Metrics/Prometheus/RegistryT.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | 3 | module System.Metrics.Prometheus.RegistryT where 4 | 5 | import Control.Applicative ((<$>)) 6 | import Control.Monad.IO.Class (MonadIO, liftIO) 7 | import Control.Monad.Trans.Class (MonadTrans) 8 | import Control.Monad.Trans.State.Strict ( 9 | StateT (..), 10 | evalStateT, 11 | execStateT, 12 | get, 13 | ) 14 | 15 | import System.Metrics.Prometheus.Metric.Counter (Counter) 16 | import System.Metrics.Prometheus.Metric.Gauge (Gauge) 17 | import System.Metrics.Prometheus.Metric.Histogram (Histogram) 18 | import qualified System.Metrics.Prometheus.Metric.Histogram as Histogram 19 | import System.Metrics.Prometheus.MetricId ( 20 | Labels, 21 | MetricId, 22 | Name, 23 | ) 24 | import System.Metrics.Prometheus.Registry ( 25 | Registry, 26 | RegistrySample, 27 | new, 28 | ) 29 | import qualified System.Metrics.Prometheus.Registry as R 30 | 31 | 32 | newtype RegistryT m a = RegistryT {unRegistryT :: StateT Registry m a} 33 | deriving (Monad, MonadTrans, Applicative, Functor, MonadIO) 34 | 35 | 36 | evalRegistryT :: Monad m => RegistryT m a -> m a 37 | evalRegistryT = flip evalStateT new . unRegistryT 38 | 39 | 40 | execRegistryT :: Monad m => RegistryT m a -> m Registry 41 | execRegistryT = flip execStateT new . unRegistryT 42 | 43 | 44 | runRegistryT :: Monad m => RegistryT m a -> m (a, Registry) 45 | runRegistryT = flip runStateT new . unRegistryT 46 | 47 | 48 | withRegistry :: MonadIO m => (Registry -> m (a, Registry)) -> RegistryT m a 49 | withRegistry = RegistryT . StateT 50 | 51 | 52 | registerCounter :: MonadIO m => Name -> Labels -> RegistryT m Counter 53 | registerCounter n l = withRegistry (liftIO . R.registerCounter n l) 54 | 55 | 56 | registerGauge :: MonadIO m => Name -> Labels -> RegistryT m Gauge 57 | registerGauge n l = withRegistry (liftIO . R.registerGauge n l) 58 | 59 | 60 | registerHistogram :: MonadIO m => Name -> Labels -> [Histogram.UpperBound] -> RegistryT m Histogram 61 | registerHistogram n l u = withRegistry (liftIO . R.registerHistogram n l u) 62 | 63 | 64 | removeMetric :: MonadIO m => MetricId -> RegistryT m () 65 | removeMetric i = withRegistry (pure . (,) () . R.removeMetric i) 66 | 67 | 68 | listMetricIds :: MonadIO m => RegistryT m [MetricId] 69 | listMetricIds = R.listMetricIds <$> RegistryT get 70 | 71 | 72 | sample :: Monad m => RegistryT m (IO RegistrySample) 73 | sample = R.sample <$> RegistryT get 74 | -------------------------------------------------------------------------------- /stack-8.10.yaml: -------------------------------------------------------------------------------- 1 | --- 2 | resolver: lts-18.28 3 | flags: {} 4 | packages: 5 | - '.' 6 | extra-deps: [] 7 | -------------------------------------------------------------------------------- /stack-9.0.yaml: -------------------------------------------------------------------------------- 1 | --- 2 | resolver: lts-19.33 3 | flags: {} 4 | packages: 5 | - "." 6 | extra-deps: [] 7 | -------------------------------------------------------------------------------- /stack-9.2.yaml: -------------------------------------------------------------------------------- 1 | --- 2 | resolver: lts-20.26 3 | flags: {} 4 | packages: 5 | - "." 6 | extra-deps: [] 7 | -------------------------------------------------------------------------------- /stack-9.4.yaml: -------------------------------------------------------------------------------- 1 | --- 2 | resolver: lts-21.25 3 | flags: {} 4 | packages: 5 | - "." 6 | extra-deps: [] 7 | -------------------------------------------------------------------------------- /stack-9.6.yaml: -------------------------------------------------------------------------------- 1 | --- 2 | resolver: lts-22.32 3 | flags: {} 4 | packages: 5 | - "." 6 | extra-deps: [] 7 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | ./stack-9.6.yaml -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | sha256: 417fa04a2ed8916cdae74c475ff97ac80857fed5000f19dce4f9564b5e635294 10 | size: 720000 11 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/32.yaml 12 | original: lts-22.32 13 | --------------------------------------------------------------------------------