diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,17 @@ +# 1.1.0 + +- `Prometheus.GHC.ghcStats` now has the type `m (Maybe (IO ThreadId))`. + + This was changed to clarify what happens if GC stats aren't enabled, in which case you'll just get `Nothing` back. + + Don't forget to actually run the stats collector thread though! For example, + + ```haskell + (startGhcStats, registry) <- buildRegistry ghcStats + for_ startGhcStats id + ``` + + # 1.0.0 Initial release. diff --git a/Prometheus/GHC.hs b/Prometheus/GHC.hs --- a/Prometheus/GHC.hs +++ b/Prometheus/GHC.hs @@ -7,6 +7,7 @@ import Control.Monad (forever) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.State (MonadState) +import Control.Retry import Data.Monoid (mempty) import qualified GHC.Stats as GHC import Prometheus @@ -48,8 +49,18 @@ * @ghc_prometheus_collection_time_seconds@: Amount of time spent by the Prometheus library collecting GHC statistics * @ghc_prometheus_record_time_seconds@: Amount of time spent by the Prometheus library recording GHC statistics -} -ghcStats :: (MonadState Registry m, MonadIO m) => m (IO ThreadId) +ghcStats :: (MonadState Registry m, MonadIO m) => m (Maybe (IO ThreadId)) ghcStats = do + enabled <- liftIO GHC.getGCStatsEnabled + case enabled of + False -> do + liftIO $ putStrLn "GHC Statisics are not enabled." + return Nothing + True -> + fmap Just mkGhcStats + +mkGhcStats :: (MonadState Registry m, MonadIO m) => m (IO ThreadId) +mkGhcStats = do bytesAllocated <- newUnlabelledMetric "ghc_bytes_allocated_total" @@ -151,45 +162,40 @@ "Amount of time spent by the Prometheus library recording GHC statistics" (histogram (exponentialBuckets 1e-12 10 10)) return $ - liftIO $ - forkIO $ do - enabled <- GHC.getGCStatsEnabled - case enabled of - False -> putStrLn "GHC Statisics are not enabled." - True -> - forever $ do - stats <- time ghcStatsTime GHC.getGCStats - time ghcRecordTime $ do - setGauge bytesAllocated (fromIntegral $ GHC.bytesAllocated stats) - setGauge numGcs (fromIntegral $ GHC.numGcs stats) - setGauge maxBytesUsed (fromIntegral $ GHC.maxBytesUsed stats) - setGauge - numByteUsageSamples - (fromIntegral $ GHC.numByteUsageSamples stats) - setGauge - cumulativeBytesUsed - (fromIntegral $ GHC.cumulativeBytesUsed stats) - setGauge bytesCopied (fromIntegral $ GHC.bytesCopied stats) - setGauge - currentBytesUsed - (fromIntegral $ GHC.currentBytesUsed stats) - setGauge - currentBytesSlop - (fromIntegral $ GHC.currentBytesSlop stats) - setGauge maxBytesSlop (fromIntegral $ GHC.maxBytesSlop stats) - setGauge - peakBytesAllocated - (fromIntegral $ GHC.peakMegabytesAllocated stats * 1000000) - setGauge mutatorCpuSeconds (GHC.mutatorCpuSeconds stats) - setGauge mutatorWallSeconds (GHC.mutatorWallSeconds stats) - setGauge gcCpuSeconds (GHC.gcCpuSeconds stats) - setGauge gcWallSeconds (GHC.gcWallSeconds stats) - setGauge cpuSeconds (GHC.cpuSeconds stats) - setGauge wallSeconds (GHC.wallSeconds stats) - setGauge - parTotBytesCopied - (fromIntegral $ GHC.parTotBytesCopied stats) - setGauge - parMaxBytesCopied - (fromIntegral $ GHC.parMaxBytesCopied stats) - threadDelay 1000000 + forkIO $ + recoverAll (capDelay 60000000 (exponentialBackoff 100)) $ const $ forever $ do + stats <- time ghcStatsTime GHC.getGCStats + time ghcRecordTime $ do + setGauge bytesAllocated (fromIntegral $ GHC.bytesAllocated stats) + setGauge numGcs (fromIntegral $ GHC.numGcs stats) + setGauge maxBytesUsed (fromIntegral $ GHC.maxBytesUsed stats) + setGauge + numByteUsageSamples + (fromIntegral $ GHC.numByteUsageSamples stats) + setGauge + cumulativeBytesUsed + (fromIntegral $ GHC.cumulativeBytesUsed stats) + setGauge bytesCopied (fromIntegral $ GHC.bytesCopied stats) + setGauge + currentBytesUsed + (fromIntegral $ GHC.currentBytesUsed stats) + setGauge + currentBytesSlop + (fromIntegral $ GHC.currentBytesSlop stats) + setGauge maxBytesSlop (fromIntegral $ GHC.maxBytesSlop stats) + setGauge + peakBytesAllocated + (fromIntegral $ GHC.peakMegabytesAllocated stats * 1000000) + setGauge mutatorCpuSeconds (GHC.mutatorCpuSeconds stats) + setGauge mutatorWallSeconds (GHC.mutatorWallSeconds stats) + setGauge gcCpuSeconds (GHC.gcCpuSeconds stats) + setGauge gcWallSeconds (GHC.gcWallSeconds stats) + setGauge cpuSeconds (GHC.cpuSeconds stats) + setGauge wallSeconds (GHC.wallSeconds stats) + setGauge + parTotBytesCopied + (fromIntegral $ GHC.parTotBytesCopied stats) + setGauge + parMaxBytesCopied + (fromIntegral $ GHC.parMaxBytesCopied stats) + threadDelay 1000000 diff --git a/bench/Bench.hs b/bench/Bench.hs new file mode 100644 --- /dev/null +++ b/bench/Bench.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE RecordWildCards, OverloadedStrings #-} +module Main where + +import Control.Monad +import Control.Concurrent +import Criterion +import Criterion.Main +import Prometheus +import System.Mem + +data Metrics = Metrics + { aCounter :: Counter + , aGauge :: Gauge + , aHistogram :: Histogram + } + +main :: IO () +main = do + (noopMetrics, _) <- + buildRegistry $ do + aCounter <- register "noop_counter" "" mempty counter + aGauge <- register "noop_gauge" "" mempty gauge + aHistogram <- register "noop_histo" "" mempty (histogram (linearBuckets 1 1 10)) + return Metrics {..} + (metrics, retainedRegistry) <- + buildRegistry $ do + aCounter <- register "counter" "" mempty counter + aGauge <- register "gauge" "" mempty gauge + aHistogram <- register "histo" "" mempty (histogram (linearBuckets 1 1 10)) + return Metrics {..} + performGC + threadDelay 10000 + putStrLn "Running benchmarks:" + defaultMainWith defaultConfig $ + [ makeBenchmarks "noop" noopMetrics + , makeBenchmarks "registered" metrics + ] + seq retainedRegistry (return ()) + +makeBenchmarks groupLabel Metrics {..} = + bgroup + groupLabel + [ bench "incCounter" (nfIO (replicateM_ n $ incCounter aCounter)) + , bench "incGauge" (nfIO (replicateM_ n $ incGauge aGauge)) + , bench "observe" (nfIO (replicateM_ n $ observe 9 aHistogram)) + ] + where + n = 10000 diff --git a/prometheus-effect.cabal b/prometheus-effect.cabal --- a/prometheus-effect.cabal +++ b/prometheus-effect.cabal @@ -1,5 +1,5 @@ name: prometheus-effect -version: 1.0.0 +version: 1.1.0 synopsis: Instrument applications with metrics and publish/push to Prometheus description: [Prometheus](https://prometheus.io) is an open-source systems monitoring and @@ -24,6 +24,7 @@ build-type: Simple extra-source-files: ChangeLog.md cabal-version: >=1.10 +homepage: https://github.com/ocharles/prometheus-effect library exposed-modules: Prometheus @@ -33,9 +34,7 @@ , bytestring , clock , hashable >= 1.2.4.0 - , http-streams , http-types >= 0.9.1 - , io-streams , mtl , retry , safe-exceptions @@ -52,3 +51,31 @@ default-language: Haskell2010 -- Use -O2 for a 50% performance increase in observe ghc-options: -Wall -O2 + +executable test + hs-source-dirs: test + build-depends: base, warp, prometheus-effect, http-types, wai, random, text + default-language: Haskell2010 + main-is: Test.hs + +test-suite weight + hs-source-dirs: weight + build-depends: base + , weigh + , prometheus-effect + , text + default-language: Haskell2010 + ghc-options: -Wall + main-is: Weight.hs + type: exitcode-stdio-1.0 + +benchmark benchmarks + hs-source-dirs: bench + build-depends: base + , criterion + , prometheus-effect + , text + default-language: Haskell2010 + ghc-options: -Wall + main-is: Bench.hs + type: exitcode-stdio-1.0 diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE ApplicativeDo, RecordWildCards, OverloadedStrings #-} +module Main where + +import Control.Applicative +import Control.Concurrent +import Data.Foldable +import Data.Monoid +import Data.Text +import Network.HTTP.Types +import Network.Wai +import Network.Wai.Handler.Warp +import Prometheus +import Prometheus.GHC +import System.Random + +data Metrics = Metrics + { testcounter :: Text -> IO Counter + , testhistogram :: Histogram + , testcounterTimer :: Histogram + , testhistogramTimer :: Histogram + } + +main :: IO () +main = do + (launchStatsCollection, ghcStatsRegistry) <- buildRegistry ghcStats + for_ launchStatsCollection id + (launchPusher, pushRegistry) <- + buildRegistry (pushMetrics "http://localhost:9091/metrics/job/j/instance/i") + (Metrics {..}, myRegistry) <- + buildRegistry $ do + testcounter <- + register + "prom_test_counter" + "Testing" + mempty + (addLabel "test_label" counter) + testhistogram <- + register + "prom_test_histo" + "" + mempty + (histogram (exponentialBuckets 1e-12 10 10)) + testcounterTimer <- + register + "prom_incCounter" + "" + mempty + (histogram (exponentialBuckets 1e-12 10 10)) + testhistogramTimer <- + register + "prom_observe" + "" + mempty + (histogram (exponentialBuckets 1e-12 10 10)) + return Metrics {..} + let registry = myRegistry <> ghcStatsRegistry <> pushRegistry + launchPusher registry + run 5811 $ + publishRegistryMiddleware ["metrics"] registry $ \req respond -> do + time testcounterTimer $ do + incCounter =<< testcounter "foo" + incCounter =<< testcounter "bar" + time testhistogramTimer $ observe 1 testhistogram + respond $ responseLBS status200 [] "Hello World" diff --git a/weight/Weight.hs b/weight/Weight.hs new file mode 100644 --- /dev/null +++ b/weight/Weight.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE OverloadedStrings, RecordWildCards #-} + +module Main where + +import Data.Monoid +import Weigh +import Prometheus +import Data.Text +import System.Mem +import Control.Concurrent + +data Metrics = Metrics + { testCounter :: Counter + , testGauge :: Gauge + , testHistogram :: Histogram + , testDyns :: Text -> IO Counter + } + +main :: IO () +main = do + (Metrics {..}, registry) <- + buildRegistry $ + Metrics <$> register "counter" "" mempty counter <*> + register "gauge" "" mempty gauge <*> + register "histogram" "" mempty (histogram (linearBuckets 0 1 10)) + <*> register "dyn" "" mempty (addLabel "k" counter) + performGC + threadDelay 10000 + incCounter testCounter + -- putStrLn "Going" + mainWith $ do + action "incCounter" (incCounter testCounter) + action "addCounter" (incCounterBy testCounter 10) + action "incGauge" (incGauge testGauge) + action "decGauge" (decGauge testGauge) + action "resetGauge" (setGauge testGauge 10) + action "observe" (observe 1 testHistogram) + action "incDynNew" (testDyns "hello" >>= incCounter) + action "incDynExisting" (testDyns "hello" >>= incCounter) + seq registry (return ()) +-- action "incCounter" (incCounter c) +-- action "addCounter" (addCounter 10 c) +-- action "incGauge" (incGaugeBy 1 g) +-- action "decGauge" (decGaugeBy 1 g) +-- action "resetGauge" (resetGauge 10 g) +-- action "observe" (observe 1 h)