ridley 0.3.2.1 → 0.3.3.0

raw patch · 11 files changed

+201/−65 lines, 11 filesdep +Spockdep +auto-updatedep +safe-exceptionsdep ~basedep ~katipdep ~prometheusnew-component:exe:ridley-examplePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: Spock, auto-update, safe-exceptions

Dependency ranges changed: base, katip, prometheus, text, wai-middleware-metrics

API changes (from Hackage documentation)

Files

• example/Main.hs +69/−0
• ridley.cabal +29/−4
• src/System/Metrics/Prometheus/Ridley.hs +35/−10
• src/System/Metrics/Prometheus/Ridley/Metrics/CPU/Darwin.hs +2/−6
• src/System/Metrics/Prometheus/Ridley/Metrics/CPU/Unix.hs +1/−5
• src/System/Metrics/Prometheus/Ridley/Metrics/DiskUsage.hs +1/−5
• src/System/Metrics/Prometheus/Ridley/Metrics/Memory.hs +1/−5
• src/System/Metrics/Prometheus/Ridley/Metrics/Network/Darwin.hs +1/−6
• src/System/Metrics/Prometheus/Ridley/Metrics/Network/Unix.hs +1/−5
• src/System/Metrics/Prometheus/Ridley/Types.hs +38/−19
• src/System/Metrics/Prometheus/Ridley/Types/Internal.hs +23/−0

@@ -0,0 +1,69 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE CPP #-}+import           System.Metrics.Prometheus.Ridley+import qualified System.Metrics.Prometheus.Metric.Gauge as P+import qualified System.Metrics.Prometheus.RegistryT as P+import           System.Metrics.Prometheus.Ridley.Types+import           Lens.Micro+import           Web.Spock+import           Web.Spock.Config+import           Network.Wai.Metrics+import           Control.Exception+import           Control.Monad.Trans+import           Data.Time.Clock.POSIX+import           Katip+import           System.IO++spockWeb :: RidleyCtx -> IO ()+spockWeb ctx = do+  spockCfg <- defaultSpockCfg () PCNoDatabase ()+  runSpock 8080 (spock spockCfg (app ctx))++app :: RidleyCtx -> SpockCtxM ctx conn sess st ()+app ctx = do+  case ctx ^. ridleyWaiMetrics of+    Nothing -> return ()+    Just m  -> middleware (metrics m)+  get root $ text "Hello World!"+  get "ping" $ text "pong"++customExpensiveMetric :: RidleyMetric+customExpensiveMetric =+  CustomMetric "my-expensive" (Just $ 60 * 1_000_000) get_metric+  where+    get_metric :: MonadIO m => RidleyOptions -> P.RegistryT m RidleyMetricHandler+    get_metric opts = do+        m <- P.registerGauge "current_time" (opts ^. prometheusOptions . labels)+        return $ mkRidleyMetricHandler "current_time" m update False++    update :: P.Gauge -> Bool -> IO ()+    update gauge _ = do n  <- getPOSIXTime+                        tn <- getCurrentTime+                        putStrLn $ "Updating time, at " <> show tn+                        P.set (realToFrac n) gauge++customCrashfulMetric :: RidleyMetric+customCrashfulMetric =+  CustomMetric "my-crashful" (Just $ 60 * 1_000_000) get_metric+  where+    get_metric :: MonadIO m => RidleyOptions -> P.RegistryT m RidleyMetricHandler+    get_metric opts = do+        m <- P.registerGauge "crashful" (opts ^. prometheusOptions . labels)+        return $ mkRidleyMetricHandler "crashful" m (\_ _ -> throwIO $ userError "CRASH!!") False++main :: IO ()+main = do+#if MIN_VERSION_katip(0,8,0)+    let onlyErrors i = pure $ Katip._itemSeverity i >= Katip.DebugS+    ridleyScribe <-+      Katip.mkHandleScribe Katip.ColorIfTerminal stdout onlyErrors Katip.V2+#else+    ridleyScribe <-+      Katip.mkHandleScribe Katip.ColorIfTerminal stdout Katip.DebugS Katip.V2+#endif+    let opts = newOptions [("service", "ridley-test")] (customExpensiveMetric : customCrashfulMetric : defaultMetrics)+             & prometheusOptions . samplingFrequency .~ 5+             & dataRetentionPeriod .~ Just 60+             & katipScribes .~ ("RidleyTest", [("stdout", ridleyScribe)])+    startRidley opts ["metrics"] 8729 >>= spockWeb

@@ -1,13 +1,13 @@ name:                ridley-version:             0.3.2.1+version:             0.3.3.0 synopsis:            Quick metrics to grow your app strong.-description:         Please see README.md+description:         A collection of Prometheus metrics to monitor your app. Please see README.md homepage:            https://github.com/iconnect/ridley#README license:             BSD3 license-file:        LICENSE author:              Alfredo Di Napoli & the IRIS Connect Engineering Team maintainer:          chrisd@irisconnect.co.uk-copyright:           2017 IRIS Connect Ltd.+copyright:           2022 IRIS Connect Ltd. category:            Web build-type:          Simple data-files:@@ -19,6 +19,11 @@      default: False      description: Enable -Werror +flag library-only+  description: Build without the executable, for downstream packages+  manual: True+  default: True+ library   hs-source-dirs:      src   include-dirs:        include@@ -29,8 +34,10 @@                        System.Metrics.Prometheus.Ridley.Metrics.CPU                        System.Metrics.Prometheus.Ridley.Metrics.Network                        System.Metrics.Prometheus.Ridley.Metrics.Network.Types+  other-modules:       System.Metrics.Prometheus.Ridley.Types.Internal    build-depends:       async < 3.0.0,+                       auto-update >= 0.1,                        base >= 4.7 && < 5,                        containers < 0.7.0.0,                        katip < 0.9.0.0,@@ -38,9 +45,10 @@                        template-haskell,                        ekg-core,                        time,-                       text,+                       text >= 1.2.4.0,                        mtl,                        shelly,+                       safe-exceptions < 1.8,                        transformers,                        prometheus > 0.5.0 && < 2.3.0,                        raw-strings-qq,@@ -85,6 +93,23 @@                      , http-client >= 0.4.30   ghc-options:         -threaded -rtsopts -with-rtsopts=-N   default-language:    Haskell2010++executable ridley-example+    main-is: example/Main.hs+    if !flag(library-only)+      build-depends: base+                   , time+                   , ridley+                   , katip+                   , text+                   , wai-middleware-metrics+                   , Spock+                   , microlens+                   , mtl+                   , prometheus+    if flag(library-only)+      buildable: False+    default-language:    Haskell2010  source-repository head   type:     git

@@ -2,6 +2,8 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE CPP #-} module System.Metrics.Prometheus.Ridley (     startRidley@@ -22,9 +24,11 @@   , defaultMetrics   ) where +import           Control.AutoUpdate as Auto import           Control.Concurrent (threadDelay, forkIO) import           Control.Concurrent.Async import           Control.Concurrent.MVar+import qualified Control.Exception.Safe as Ex import           Control.Monad (foldM) import           Control.Monad.IO.Class (liftIO, MonadIO) import           Control.Monad.Reader (ask)@@ -32,12 +36,12 @@ import           Data.IORef import qualified Data.List as List import           Data.Map.Strict as M-import           Data.Monoid ((<>)) import qualified Data.Set as Set import           Data.String import qualified Data.Text as T import           Data.Time import           GHC.Conc (getNumCapabilities, getNumProcessors)+import           GHC.Stack import           Katip import           Lens.Micro import           Network.Wai.Metrics (registerWaiMetrics)@@ -55,6 +59,7 @@ import           System.Metrics.Prometheus.Ridley.Metrics.Memory import           System.Metrics.Prometheus.Ridley.Metrics.Network import           System.Metrics.Prometheus.Ridley.Types+import           System.Metrics.Prometheus.Ridley.Types.Internal import           System.Remote.Monitoring.Prometheus  --------------------------------------------------------------------------------@@ -74,9 +79,18 @@   opts <- ask   let popts = opts ^. prometheusOptions   let sev   = opts ^. katipSeverity+  le <- getLogEnv   case x of-    CustomMetric metricName custom -> do-      customMetric <- lift (custom opts)+    CustomMetric metricName mb_timeout custom -> do+      customMetric <- case mb_timeout of+        Nothing   -> lift (custom opts)+        Just microseconds -> do+          RidleyMetricHandler mtr upd flsh lbl cs <- lift (custom opts)+          doUpdate <- liftIO $ Auto.mkAutoUpdate Auto.defaultUpdateSettings+                        { updateAction = upd mtr flsh `Ex.catch` logFailedUpdate le lbl cs+                        , updateFreq   = microseconds+                        }+          pure $ RidleyMetricHandler mtr (\_ _ -> doUpdate) flsh lbl cs       $(logTM) sev $ "Registering CustomMetric '" <> fromString (T.unpack metricName) <> "'..."       (customMetric :) <$> (registerMetrics xs)     ProcessMemory -> do@@ -152,7 +166,7 @@          liftIO $ do           lastUpdate <- newIORef =<< getCurrentTime-          updateLoop <- async $ handlersLoop lastUpdate handlers+          updateLoop <- async $ handlersLoop le' lastUpdate handlers           putMVar x updateLoop          lift $ P.sample >>= serveMetrics port path@@ -165,8 +179,8 @@           $(logTM) ErrorS (fromString $ show e)         Right _ -> return () -    handlersLoop :: IORef UTCTime -> [RidleyMetricHandler] -> IO a-    handlersLoop lastUpdateRef handlers = do+    handlersLoop :: LogEnv -> IORef UTCTime -> [RidleyMetricHandler] -> IO a+    handlersLoop le lastUpdateRef handlers = do       let freq = opts ^. prometheusOptions . samplingFrequency       let flushPeriod = opts ^. dataRetentionPeriod       mustFlush <- case flushPeriod of@@ -180,8 +194,8 @@               return True             False -> return False       threadDelay (freq * 10^6)-      updateHandlers (List.map (\x -> x { flush = mustFlush }) handlers)-      handlersLoop lastUpdateRef handlers+      updateHandlers le (List.map (\x -> x { flush = mustFlush }) handlers)+      handlersLoop le lastUpdateRef handlers  serveMetrics :: MonadIO m => Int -> P.Path -> IO RegistrySample -> m () #if (MIN_VERSION_prometheus(2,2,2))@@ -191,5 +205,16 @@ #endif  ---------------------------------------------------------------------------------updateHandlers :: [RidleyMetricHandler] -> IO ()-updateHandlers = mapM_ runHandler+updateHandlers :: LogEnv -> [RidleyMetricHandler] -> IO ()+updateHandlers le hs = mapM_ (\h@RidleyMetricHandler{..} -> runHandler h `Ex.catchAny` (logFailedUpdate le label _cs)) hs++logFailedUpdate :: LogEnv -> T.Text -> CallStack -> Ex.SomeException -> IO ()+logFailedUpdate le lbl cs ex =+  runKatipContextT le () "errors" $ do+      $(logTM) ErrorS $+        fromString $ "Couldn't update handler for "+                  <> "\"" <> T.unpack lbl <> "\""+                  <> " due to "+                  <> Ex.displayException ex+                  <> " originally defined at "+                  <> prettyCallStack cs

@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} module System.Metrics.Prometheus.Ridley.Metrics.CPU.Darwin@@ -5,7 +6,6 @@   , processCPULoad   ) where -import           Data.Monoid ((<>)) import qualified Data.Vector.Storable as V import qualified Data.Vector.Storable.Mutable as VM import           Foreign.C.Types@@ -37,8 +37,4 @@  -------------------------------------------------------------------------------- processCPULoad :: (P.Gauge, P.Gauge, P.Gauge) -> RidleyMetricHandler-processCPULoad g = RidleyMetricHandler {-    metric = g-  , updateMetric = updateCPULoad-  , flush = False-  }+processCPULoad g = mkRidleyMetricHandler "ridley-process-cpu-load" g updateCPULoad False

@@ -43,8 +43,4 @@  -------------------------------------------------------------------------------- processCPULoad :: (P.Gauge, P.Gauge, P.Gauge) -> RidleyMetricHandler-processCPULoad g = RidleyMetricHandler {-    metric = g-  , updateMetric = updateCPULoad-  , flush = False-  }+processCPULoad g = mkRidleyMetricHandler "ridley-process-cpu-load" g updateCPULoad False

@@ -84,11 +84,7 @@  -------------------------------------------------------------------------------- diskUsageMetrics :: DiskUsageMetrics -> RidleyMetricHandler-diskUsageMetrics g = RidleyMetricHandler {-    metric = g-  , updateMetric = updateDiskUsageMetrics-  , flush = False-  }+diskUsageMetrics g = mkRidleyMetricHandler "ridley-disk-usage" g updateDiskUsageMetrics False  -------------------------------------------------------------------------------- mkDiskGauge :: MonadIO m => P.Labels -> DiskUsageMetrics -> DiskStats -> P.RegistryT m DiskUsageMetrics

@@ -32,8 +32,4 @@  -------------------------------------------------------------------------------- processMemory :: P.Gauge -> RidleyMetricHandler-processMemory g = RidleyMetricHandler {-    metric = g-  , updateMetric = updateProcessMemory-  , flush = False-  }+processMemory g = mkRidleyMetricHandler "ridley-process-memory" g updateProcessMemory False

@@ -12,7 +12,6 @@ import           Control.Monad import           Control.Monad.IO.Class import qualified Data.Map.Strict as M-import           Data.Monoid ((<>)) import qualified Data.Text as T import           Foreign.C.String import           Foreign.C.Types@@ -167,11 +166,7 @@  -------------------------------------------------------------------------------- networkMetrics :: NetworkMetrics -> RidleyMetricHandler-networkMetrics g = RidleyMetricHandler {-    metric = g-  , updateMetric = updateNetworkMetrics-  , flush = False-  }+networkMetrics g = mkRidleyMetricHandler "ridley-network-metrics" g updateNetworkMetrics False  -------------------------------------------------------------------------------- mkInterfaceGauge :: MonadIO m => P.Labels -> NetworkMetrics -> IfData -> P.RegistryT m NetworkMetrics

@@ -70,11 +70,7 @@  -------------------------------------------------------------------------------- networkMetrics :: NetworkMetrics -> RidleyMetricHandler-networkMetrics g = RidleyMetricHandler {-    metric = g-  , updateMetric = updateNetworkMetrics-  , flush = False-  }+networkMetrics g = mkRidleyMetricHandler "ridley-network-metrics" g updateNetworkMetrics False  -------------------------------------------------------------------------------- mkInterfaceGauge :: MonadIO m => P.Labels -> NetworkMetrics -> IfData -> P.RegistryT m NetworkMetrics

@@ -1,10 +1,10 @@-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeSynonymInstances #-} module System.Metrics.Prometheus.Ridley.Types (     RidleyT(Ridley)   , Ridley@@ -16,7 +16,12 @@   , PrometheusOptions   , RidleyMetric(..)   , RidleyOptions-  , RidleyMetricHandler(..)+  , RidleyMetricHandler+  , metric+  , updateMetric+  , flush+  , label+  , mkRidleyMetricHandler   , defaultMetrics   , newOptions   , prometheusOptions@@ -32,27 +37,31 @@ import           Control.Monad.Reader (MonadReader) import           Control.Monad.Trans.Class import           Control.Monad.Trans.Reader-import           Data.Monoid import qualified Data.Set as Set import qualified Data.Text as T import           Data.Time+import           GHC.Stack import           Katip import           Lens.Micro.TH import           Network.Wai.Metrics (WaiMetrics) import qualified System.Metrics.Prometheus.MetricId as P import qualified System.Metrics.Prometheus.RegistryT as P import           System.Remote.Monitoring.Prometheus+import           System.Metrics.Prometheus.Ridley.Types.Internal  -------------------------------------------------------------------------------- type Port = Int type PrometheusOptions = AdapterOptions ----------------------------------------------------------------------------------data RidleyMetricHandler = forall c. RidleyMetricHandler {-    metric       :: c-  , updateMetric :: c -> Bool -> IO ()-  , flush        :: !Bool-  -- ^Whether or net to flush this Metric+mkRidleyMetricHandler :: forall c. HasCallStack+                      => T.Text+                      -> c -> (c -> Bool -> IO ()) -> Bool -> RidleyMetricHandler+mkRidleyMetricHandler lbl c runC flsh = withFrozenCallStack $ RidleyMetricHandler {+    metric       = c+  , updateMetric = runC+  , flush        = flsh+  , label        = lbl+  , _cs          = popCallStack callStack   }  --------------------------------------------------------------------------------@@ -64,7 +73,17 @@                   | Wai                   | DiskUsage                   -- ^ Gets stats about Disk usage (free space, etc)-                  | CustomMetric T.Text (forall m. MonadIO m => RidleyOptions -> P.RegistryT m RidleyMetricHandler)+                  | CustomMetric !T.Text+                                 -- ^ The name of the metric+                                 !(Maybe Int)+                                 -- ^ An optional timeout, in microseconds,+                                 -- that regulates how often the metric is+                                 -- actually updated. If Nothing, the metric+                                 -- will be updated using Ridley top-level setting,+                                 -- if 'Just' the underlying 'IO' action will be run+                                 -- only every @n@ seconds, or cached otherwise.+                                 (forall m. MonadIO m => RidleyOptions -> P.RegistryT m RidleyMetricHandler)+                                 -- ^ An action to generate the handler.                   -- ^ A user-defined metric, identified by a name.  instance Show RidleyMetric where@@ -74,7 +93,7 @@   show Network               = "Network"   show Wai                   = "Wai"   show DiskUsage             = "DiskUsage"-  show (CustomMetric name _) = "Custom@" <> T.unpack name+  show (CustomMetric name _ _) = "Custom@" <> T.unpack name  instance Eq RidleyMetric where   (==) ProcessMemory ProcessMemory             = True@@ -83,7 +102,7 @@   (==) Network Network                         = True   (==) Wai     Wai                             = True   (==) DiskUsage DiskUsage                     = True-  (==) (CustomMetric n1 _) (CustomMetric n2 _) = (==) n1 n2+  (==) (CustomMetric n1 _ _) (CustomMetric n2 _ _) = (==) n1 n2   (==) _ _                                     = False  instance Ord RidleyMetric where@@ -120,14 +139,14 @@     Wai                    -> LT     DiskUsage              -> EQ     _                      -> GT-  compare (CustomMetric n1 _) xs = case xs of+  compare (CustomMetric n1 _ _) xs = case xs of     ProcessMemory          -> LT     CPULoad                -> LT     GHCConc                -> LT     Network                -> LT     Wai                    -> LT     DiskUsage              -> LT-    (CustomMetric n2 _)    -> compare n1 n2+    (CustomMetric n2 _ _)    -> compare n1 n2  -------------------------------------------------------------------------------- data RidleyOptions = RidleyOptions {@@ -160,10 +179,10 @@  -------------------------------------------------------------------------------- runHandler :: RidleyMetricHandler -> IO ()-runHandler (RidleyMetricHandler m u f) = u m f+runHandler (RidleyMetricHandler m u f _ _) = u m f  ---------------------------------------------------------------------------------newtype RidleyT t a = Ridley { unRidley :: ReaderT RidleyOptions t a }+newtype RidleyT t a = Ridley { _unRidley :: ReaderT RidleyOptions t a }   deriving (Functor, Applicative, Monad, MonadReader RidleyOptions, MonadIO, MonadTrans)  type Ridley = RidleyT (P.RegistryT (KatipContextT IO))

@@ -0,0 +1,23 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ExistentialQuantification #-}+module System.Metrics.Prometheus.Ridley.Types.Internal+  ( RidleyMetricHandler(..)+  ) where++import           GHC.Stack+import qualified Data.Text as T++--------------------------------------------------------------------------------+data RidleyMetricHandler = forall c. RidleyMetricHandler {+  -- | An opaque metric+    metric       :: c+  -- | An IO action used to update the metric+  , updateMetric :: c -> Bool -> IO ()+  -- | Whether or not to flush this Metric+  , flush        :: !Bool+  -- | A user-friendly label, used to report errors+  , label        :: !T.Text+  -- | A CallStack, for precise error reporting+  , _cs          :: CallStack+  }+