ridley 0.3.3.1 → 0.3.4.0

raw patch · 6 files changed

+195/−95 lines, 6 filesdep +exceptionsdep +unliftio-corePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: exceptions, unliftio-core

API changes (from Hackage documentation)

Files

• ridley.cabal +4/−2
• src/System/Metrics/Prometheus/Ridley.hs +105/−59
• src/System/Metrics/Prometheus/Ridley/Metrics/DiskUsage.hs +32/−20
• src/System/Metrics/Prometheus/Ridley/Metrics/Memory.hs +19/−9
• src/System/Metrics/Prometheus/Ridley/Types.hs +32/−5
• src/System/Metrics/Prometheus/Ridley/Types/Internal.hs +3/−0

@@ -1,5 +1,5 @@ name:                ridley-version:             0.3.3.1+version:             0.3.4.0 synopsis:            Quick metrics to grow your app strong. description:         A collection of Prometheus metrics to monitor your app. Please see README.md homepage:            https://github.com/iconnect/ridley#README@@ -44,6 +44,7 @@                        wai-middleware-metrics < 0.3.0.0,                        template-haskell,                        ekg-core,+                       exceptions < 0.11,                        time,                        text >= 1.2.4.0,                        mtl,@@ -59,7 +60,8 @@                        ekg-prometheus-adapter >= 0.1.0.3,                        inline-c,                        vector,-                       unix+                       unix,+                       unliftio-core   c-sources:           cbits/helpers.c   cc-options:          -Wall -std=c99   default-language:    Haskell2010

@@ -3,6 +3,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE CPP #-} module System.Metrics.Prometheus.Ridley (@@ -31,7 +32,7 @@ import qualified Control.Exception.Safe as Ex import           Control.Monad (foldM) import           Control.Monad.IO.Class (liftIO, MonadIO)-import           Control.Monad.Reader (ask)+import           Control.Monad.Reader (asks) import           Control.Monad.Trans.Class (lift) import           Data.IORef import qualified Data.List as List@@ -44,6 +45,7 @@ import           GHC.Stack import           Katip import           Lens.Micro+import           Lens.Micro.Extras (view) import           Network.Wai.Metrics (registerWaiMetrics) import           System.Metrics as EKG #if (MIN_VERSION_prometheus(0,5,0))@@ -73,66 +75,110 @@   startRidleyWithStore opts path port store  ---------------------------------------------------------------------------------registerMetrics :: [RidleyMetric] -> Ridley [RidleyMetricHandler]-registerMetrics [] = return []-registerMetrics (x:xs) = do-  opts <- ask-  let popts = opts ^. prometheusOptions-  let sev   = opts ^. katipSeverity-  le <- getLogEnv-  case x of-    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-      processReservedMemory <- lift $ P.registerGauge "process_memory_kb" (popts ^. labels)-      let !m = processMemory processReservedMemory-      $(logTM) sev "Registering ProcessMemory metric..."-      (m :) <$> (registerMetrics xs)-    CPULoad -> do-      cpu1m  <- lift $ P.registerGauge "cpu_load1"  (popts ^. labels)-      cpu5m  <- lift $ P.registerGauge "cpu_load5"  (popts ^. labels)-      cpu15m <- lift $ P.registerGauge "cpu_load15" (popts ^. labels)-      let !cpu = processCPULoad (cpu1m, cpu5m, cpu15m)-      $(logTM) sev "Registering CPULoad metric..."-      (cpu :) <$> (registerMetrics xs)-    GHCConc -> do-      -- We don't want to keep updating this as it's a one-shot measure.-      numCaps  <- lift $ P.registerCounter "ghc_conc_num_capabilities"  (popts ^. labels)-      numPros  <- lift $ P.registerCounter "ghc_conc_num_processors"    (popts ^. labels)-      liftIO (getNumCapabilities >>= \cap -> add (fromIntegral cap) numCaps)-      liftIO (getNumProcessors >>= \cap -> add (fromIntegral cap) numPros)-      $(logTM) sev "Registering GHCConc metric..."-      registerMetrics xs-    -- Ignore `Wai` as we will use an external library for that.-    Wai     -> registerMetrics xs-    DiskUsage -> do-      diskStats <- liftIO getDiskStats-      dmap   <- lift $ foldM (mkDiskGauge (popts ^. labels)) M.empty diskStats-      let !diskUsage = diskUsageMetrics dmap-      $(logTM) sev "Registering DiskUsage metric..."-      (diskUsage :) <$> registerMetrics xs-    Network -> do+registerMetrics :: Set.Set RidleyMetric -> Ridley [RidleyMetricHandler]+registerMetrics = foldM registerSingleMetric []+  where+    registerSingleMetric :: [RidleyMetricHandler] -> RidleyMetric -> Ridley [RidleyMetricHandler]+    registerSingleMetric !acc x = case x of+        CustomMetric metricName mb_timeout custom+          -> tryRegister x acc $ registerCustomMetric metricName mb_timeout custom+        ProcessMemory+          -> tryRegister x acc registerProcessMemory+        CPULoad+          -> tryRegister x acc registerCPULoad+        GHCConc+          -> tryRegister x acc registerGHCConc+        Wai+          -> pure acc -- Ignore `Wai` as we will use an external library for that.+        DiskUsage+          -> tryRegister x acc registerDiskUsage+        Network+          -> tryRegister x acc registerNetworkMetric++tryRegister :: RidleyMetric -> [RidleyMetricHandler] -> Ridley RidleyMetricHandler -> Ridley [RidleyMetricHandler]+tryRegister metric !acc doRegister = do+  registrationResult <- Ex.tryAny doRegister+  case registrationResult of+    Left ex -> do+      $(logTM) ErrorS $ ls $ T.pack $ "Registration of metric '" <> show metric <> "' failed due to: " <> show ex+      pure acc+    Right metricHandler -> pure $! metricHandler : acc++registerProcessMemory :: Ridley RidleyMetricHandler+registerProcessMemory = do+  sev   <- asks (view katipSeverity)+  popts <- asks (view prometheusOptions)+  logger <- ioLogger+  processReservedMemory <- lift $ P.registerGauge "process_memory_kb" (popts ^. labels)+  let !m = processMemory logger processReservedMemory+  $(logTM) sev "Registering ProcessMemory metric..."+  pure m++registerCPULoad :: Ridley RidleyMetricHandler+registerCPULoad = do+  sev   <- asks (view katipSeverity)+  popts <- asks (view prometheusOptions)+  cpu1m  <- lift $ P.registerGauge "cpu_load1"  (popts ^. labels)+  cpu5m  <- lift $ P.registerGauge "cpu_load5"  (popts ^. labels)+  cpu15m <- lift $ P.registerGauge "cpu_load15" (popts ^. labels)+  let !cpu = processCPULoad (cpu1m, cpu5m, cpu15m)+  $(logTM) sev "Registering CPULoad metric..."+  pure cpu++registerGHCConc :: Ridley RidleyMetricHandler+registerGHCConc = do+  sev   <- asks (view katipSeverity)+  popts <- asks (view prometheusOptions)+  -- We don't want to keep updating this as it's a one-shot measure.+  numCaps  <- lift $ P.registerCounter "ghc_conc_num_capabilities"  (popts ^. labels)+  numPros  <- lift $ P.registerCounter "ghc_conc_num_processors"    (popts ^. labels)+  liftIO (getNumCapabilities >>= \cap -> add (fromIntegral cap) numCaps)+  liftIO (getNumProcessors >>= \cap -> add (fromIntegral cap) numPros)+  $(logTM) sev "Registering GHCConc metric..."+  pure $ mkRidleyMetricHandler "ridley-ghc-conc" (numCaps, numPros) noUpdate False++registerDiskUsage :: Ridley RidleyMetricHandler+registerDiskUsage = do+  sev   <- asks (view katipSeverity)+  diskUsage <- newDiskUsageMetrics+  $(logTM) sev "Registering DiskUsage metric..."+  pure diskUsage++registerCustomMetric :: T.Text+                     -> Maybe Int+                     -> (forall m. MonadIO m => RidleyOptions -> P.RegistryT m RidleyMetricHandler)+                     -> Ridley RidleyMetricHandler+registerCustomMetric metricName mb_timeout custom = do+  opts    <- getRidleyOptions+  let sev = opts ^. katipSeverity+  le      <- getLogEnv+  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) <> "'..."+  pure customMetric++registerNetworkMetric :: Ridley RidleyMetricHandler+registerNetworkMetric = do+  sev   <- asks (view katipSeverity)+  popts <- asks (view prometheusOptions) #if defined darwin_HOST_OS-      (ifaces, dtor) <- liftIO getNetworkMetrics-      imap   <- lift $ foldM (mkInterfaceGauge (popts ^. labels)) M.empty ifaces-      liftIO dtor+  (ifaces, dtor) <- liftIO getNetworkMetrics+  imap   <- lift $ foldM (mkInterfaceGauge (popts ^. labels)) M.empty ifaces+  liftIO dtor #else-      ifaces <- liftIO getNetworkMetrics-      imap   <- lift $ foldM (mkInterfaceGauge (popts ^. labels)) M.empty ifaces+  ifaces <- liftIO getNetworkMetrics+  imap   <- lift $ foldM (mkInterfaceGauge (popts ^. labels)) M.empty ifaces #endif-      let !network = networkMetrics imap-      $(logTM) sev "Registering Network metric..."-      (network :) <$> registerMetrics xs+  let !network = networkMetrics imap+  $(logTM) sev "Registering Network metric..."+  pure network  -------------------------------------------------------------------------------- startRidleyWithStore :: RidleyOptions@@ -162,7 +208,7 @@       -- Start the server       serverLoop <- async $ runRidley opts le' $ do         lift $ registerEKGStore store (opts ^. prometheusOptions)-        handlers <- registerMetrics (Set.toList $ opts ^. ridleyMetrics)+        handlers <- registerMetrics (opts ^. ridleyMetrics)          liftIO $ do           lastUpdate <- newIORef =<< getCurrentTime

@@ -3,24 +3,27 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} module System.Metrics.Prometheus.Ridley.Metrics.DiskUsage (-    getDiskStats-  , mkDiskGauge-  , diskUsageMetrics+  newDiskUsageMetrics   ) where  import           Control.Monad import           Control.Monad.IO.Class-import qualified Data.Map.Strict as M+import           Control.Monad.Trans.Class import           Data.Maybe-import qualified Data.Text as T+import           Katip import           Lens.Micro import           Lens.Micro.TH+import           System.Exit+import           System.Metrics.Prometheus.Ridley.Types+import           System.Metrics.Prometheus.Ridley.Types.Internal+import           System.Process+import           System.Remote.Monitoring.Prometheus (labels)+import           Text.Read hiding (lift)+import qualified Data.Map.Strict as M+import qualified Data.Text as T import qualified System.Metrics.Prometheus.Metric.Gauge as P import qualified System.Metrics.Prometheus.MetricId as P import qualified System.Metrics.Prometheus.RegistryT as P-import           System.Metrics.Prometheus.Ridley.Types-import           System.Process-import           Text.Read   --------------------------------------------------------------------------------@@ -42,12 +45,16 @@ type DiskUsageMetrics = M.Map T.Text DiskMetric  ---------------------------------------------------------------------------------getDiskStats :: IO [DiskStats]-getDiskStats = do+getDiskStats :: Logger -> IO [DiskStats]+getDiskStats logger = do   let diskOnly = (\d -> "/dev" `T.isInfixOf` (d ^. diskFilesystem))-  let dropHeader = drop 1-  rawLines <- dropHeader . T.lines . T.strip . T.pack <$> readProcess "df" [] []-  return $ filter diskOnly . mapMaybe mkDiskStats $ rawLines+  let dropHeader = drop 1 . T.lines . T.strip . T.pack+  (exitCode, rawLines, errors) <- readProcessWithExitCode "df" [] []+  case exitCode of+    ExitSuccess    -> return $ filter diskOnly . mapMaybe mkDiskStats $ dropHeader rawLines+    ExitFailure ec -> do+      logger ErrorS $ "getDiskStats exited with error code " <> T.pack (show ec) <> ": " <> T.pack errors+      pure mempty   where     mkDiskStats :: T.Text -> Maybe DiskStats     mkDiskStats rawLine = case T.words rawLine of@@ -73,9 +80,9 @@   P.set (d ^. diskFree) _dskMetricFree  ---------------------------------------------------------------------------------updateDiskUsageMetrics :: DiskUsageMetrics -> Bool -> IO ()-updateDiskUsageMetrics dmetrics flush = do-  diskStats <- getDiskStats+updateDiskUsageMetrics :: Logger -> DiskUsageMetrics -> Bool -> IO ()+updateDiskUsageMetrics logger dmetrics flush = do+  diskStats <- getDiskStats logger   forM_ diskStats $ \d -> do     let key = d ^. diskFilesystem     case M.lookup key dmetrics of@@ -83,10 +90,6 @@       Just m  -> updateDiskUsageMetric m d flush  ---------------------------------------------------------------------------------diskUsageMetrics :: DiskUsageMetrics -> RidleyMetricHandler-diskUsageMetrics g = mkRidleyMetricHandler "ridley-disk-usage" g updateDiskUsageMetrics False---------------------------------------------------------------------------------- mkDiskGauge :: MonadIO m => P.Labels -> DiskUsageMetrics -> DiskStats -> P.RegistryT m DiskUsageMetrics mkDiskGauge currentLabels dmap d = do   let fs = d ^. diskFilesystem@@ -95,3 +98,12 @@                        <*> P.registerGauge "disk_free_bytes_blocks" finalLabels   liftIO $ updateDiskUsageMetric metric d False   return $! M.insert fs metric $! dmap++-- | Creates a new 'RidleyMetricHandler' to monitor disk usage.+newDiskUsageMetrics :: Ridley RidleyMetricHandler+newDiskUsageMetrics = do+  logger <- ioLogger+  opts <- getRidleyOptions+  diskStats <- liftIO (getDiskStats logger)+  metrics   <- lift $ foldM (mkDiskGauge (opts ^. prometheusOptions . labels)) M.empty diskStats+  pure $ mkRidleyMetricHandler "ridley-disk-usage" metrics (updateDiskUsageMetrics logger) False

@@ -3,11 +3,15 @@     processMemory   ) where -import qualified System.Metrics.Prometheus.Metric.Gauge as P+import           Katip+import           System.Exit import           System.Metrics.Prometheus.Ridley.Types+import           System.Metrics.Prometheus.Ridley.Types.Internal import           System.Posix.Process import           System.Process import           Text.Read+import qualified Data.Text as T+import qualified System.Metrics.Prometheus.Metric.Gauge as P  -------------------------------------------------------------------------------- -- | Return the amount of occupied memory for this@@ -16,20 +20,26 @@ -- accurate, at least works on Darwin and Linux -- without using any CPP processor. -- Returns the memory in Kb.-getProcessMemory :: IO (Maybe Integer)-getProcessMemory = do+getProcessMemory :: Logger -> IO (Maybe Integer)+getProcessMemory logger = do   myPid <- getProcessID-  readMaybe <$> readProcess "ps" ["-o", "rss=", "-p", show myPid] []+  (exitCode, rawOutput, errors) <- readProcessWithExitCode "ps" ["-o", "rss=", "-p", show myPid] []+  case exitCode of+    ExitSuccess    -> pure $ readMaybe rawOutput+    ExitFailure ec -> do+      logger ErrorS $ "getProcessMemory exited with error code " <> T.pack (show ec) <> ": " <> T.pack errors+      pure Nothing  -------------------------------------------------------------------------------- -- | As this is a gauge, it makes no sense flushing it.-updateProcessMemory :: P.Gauge -> Bool -> IO ()-updateProcessMemory g _ = do-  mbMem <- getProcessMemory+updateProcessMemory :: Logger -> P.Gauge -> Bool -> IO ()+updateProcessMemory logger g _ = do+  mbMem <- getProcessMemory logger   case mbMem of     Nothing -> return ()     Just m  -> P.set (fromIntegral m) g  ---------------------------------------------------------------------------------processMemory :: P.Gauge -> RidleyMetricHandler-processMemory g = mkRidleyMetricHandler "ridley-process-memory" g updateProcessMemory False+processMemory :: Logger -> P.Gauge -> RidleyMetricHandler+processMemory logger g = do+  mkRidleyMetricHandler "ridley-process-memory" g (updateProcessMemory logger) False

@@ -30,24 +30,28 @@   , katipSeverity   , dataRetentionPeriod   , runHandler+  , ioLogger+  , getRidleyOptions+  , noUpdate   ) where  import           Control.Concurrent (ThreadId)+import           Control.Monad.Catch import           Control.Monad.IO.Class import           Control.Monad.Reader (MonadReader)-import           Control.Monad.Trans.Class+import           Control.Monad.State.Strict import           Control.Monad.Trans.Reader-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           System.Metrics.Prometheus.Ridley.Types.Internal+import           System.Remote.Monitoring.Prometheus+import qualified Data.Set as Set+import qualified Data.Text as T 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@@ -194,6 +198,14 @@  makeLenses ''RidleyCtx +instance MonadThrow Ridley where+  throwM e = Ridley $ ReaderT $ \_ -> P.RegistryT $ StateT $ \_ -> throwM e++instance MonadCatch Ridley where+  catch r handler =+    let unwrap opts = P.unRegistryT . flip runReaderT opts . _unRidley+    in Ridley $ ReaderT $ \opts -> P.RegistryT $ catch (unwrap opts r) (unwrap opts . handler)+ instance Katip Ridley where   getLogEnv = Ridley $ lift (lift getLogEnv)   localLogEnv f (Ridley (ReaderT m)) =@@ -211,3 +223,18 @@ runRidley :: RidleyOptions -> LogEnv -> Ridley a -> IO a runRidley opts le (Ridley ridley) =   (runKatipContextT le (mempty :: SimpleLogPayload) mempty $ P.evalRegistryT $ (runReaderT ridley) opts)++-- | Returns an IO logger which uses context defined in the 'Ridley' monad. Useful when we want to use+-- an IO logger in the update functions for the handlers, which run in plain 'IO'.+ioLogger :: Ridley Logger+ioLogger = do+  le  <- getLogEnv+  ctx <- getKatipContext+  ns  <- getKatipNamespace+  pure $ \sev txt -> runKatipContextT le ctx ns $ logLocM sev (ls txt)++getRidleyOptions :: Ridley RidleyOptions+getRidleyOptions = Ridley ask++noUpdate :: c -> Bool -> IO ()+noUpdate _ _ = pure ()

@@ -2,8 +2,10 @@ {-# LANGUAGE ExistentialQuantification #-} module System.Metrics.Prometheus.Ridley.Types.Internal   ( RidleyMetricHandler(..)+  , Logger   ) where +import           Katip import           GHC.Stack import qualified Data.Text as T @@ -21,3 +23,4 @@   , _cs          :: CallStack   } +type Logger = Severity -> T.Text -> IO ()