Code review changes

ridley-extras/src/System/Metrics/Prometheus/Ridley/Metrics/FD.hs

@@ -52,4 +52,4 @@ processOpenFD :: MonadIO m
 processOpenFD pid opts = do
   let popts = opts ^. prometheusOptions
   openFD <- P.registerGauge "process_open_fd" (popts ^. labels)
-  return $ mkRidleyMetricHandler openFD (updateOpenFD pid) False
+  return $ mkRidleyMetricHandler "ridley-process-open-file-descriptors" openFD (updateOpenFD pid) False

ridley/example/Main.hs

@@ -35,7 +35,7 @@ customExpensiveMetric =
     get_metric :: MonadIO m => RidleyOptions -> P.RegistryT m RidleyMetricHandler
     get_metric opts = do
         m <- P.registerGauge "current_time" (opts ^. prometheusOptions . labels)
-        return $ mkRidleyMetricHandler m update False
+        return $ mkRidleyMetricHandler "current_time" m update False
 
     update :: P.Gauge -> Bool -> IO ()
     update gauge _ = do n  <- getPOSIXTime
@@ -50,7 +50,7 @@ customCrashfulMetric =
     get_metric :: MonadIO m => RidleyOptions -> P.RegistryT m RidleyMetricHandler
     get_metric opts = do
         m <- P.registerGauge "crashful" (opts ^. prometheusOptions . labels)
-        return $ mkRidleyMetricHandler m (\_ _ -> throwIO $ userError "CRASH!!") False
+        return $ mkRidleyMetricHandler "crashful" m (\_ _ -> throwIO $ userError "CRASH!!") False
 
 main :: IO ()
 main = do

ridley/ridley.cabal

@@ -34,6 +34,7 @@ library
                        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,

ridley/src/System/Metrics/Prometheus/Ridley.hs

@@ -41,6 +41,7 @@ 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)
@@ -58,6 +59,7 @@ import           System.Metrics.Prometheus.Ridley.Metrics.DiskUsage
 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
 
 --------------------------------------------------------------------------------
@@ -83,12 +85,12 @@ registerMetrics (x:xs) = do
       customMetric <- case mb_timeout of
         Nothing   -> lift (custom opts)
         Just microseconds -> do
-          RidleyMetricHandler mtr upd flsh lbl <- lift (custom opts)
+          RidleyMetricHandler mtr upd flsh lbl cs <- lift (custom opts)
           doUpdate <- liftIO $ Auto.mkAutoUpdate Auto.defaultUpdateSettings
-                        { updateAction = upd mtr flsh `Ex.catch` logFailedUpdate le lbl
+                        { updateAction = upd mtr flsh `Ex.catch` logFailedUpdate le lbl cs
                         , updateFreq   = microseconds
                         }
-          pure $ RidleyMetricHandler mtr (\_ _ -> doUpdate) flsh lbl
+          pure $ RidleyMetricHandler mtr (\_ _ -> doUpdate) flsh lbl cs
       $(logTM) sev $ "Registering CustomMetric '" <> fromString (T.unpack metricName) <> "'..."
       (customMetric :) <$> (registerMetrics xs)
     ProcessMemory -> do
@@ -204,13 +206,15 @@ serveMetrics = P.serveHttpTextMetrics
 
 --------------------------------------------------------------------------------
 updateHandlers :: LogEnv -> [RidleyMetricHandler] -> IO ()
-updateHandlers le hs = mapM_ (\h@RidleyMetricHandler{..} -> runHandler h `Ex.catch` (logFailedUpdate le label)) hs
+updateHandlers le hs = mapM_ (\h@RidleyMetricHandler{..} -> runHandler h `Ex.catchAny` (logFailedUpdate le label _cs)) hs
 
-logFailedUpdate :: LogEnv -> T.Text -> Ex.SomeException -> IO ()
-logFailedUpdate le lbl ex =
+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
+                  <> "\"" <> T.unpack lbl <> "\""
+                  <> " originally defined at "
+                  <> prettyCallStack cs
                   <> " due to "
                   <> Ex.displayException ex

ridley/src/System/Metrics/Prometheus/Ridley/Metrics/CPU/Darwin.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE TemplateHaskell #-}
 module System.Metrics.Prometheus.Ridley.Metrics.CPU.Darwin
@@ -36,4 +37,4 @@ updateCPULoad (cpu1m, cpu5m, cpu15m) _ = do
 
 --------------------------------------------------------------------------------
 processCPULoad :: (P.Gauge, P.Gauge, P.Gauge) -> RidleyMetricHandler
-processCPULoad g = mkRidleyMetricHandler g updateCPULoad False
+processCPULoad g = mkRidleyMetricHandler "ridley-process-cpu-load" g updateCPULoad False

ridley/src/System/Metrics/Prometheus/Ridley/Metrics/CPU/Unix.hs

@@ -43,8 +43,4 @@ updateCPULoad (cpu1m, cpu5m, cpu15m) _ = do
 
 --------------------------------------------------------------------------------
 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

ridley/src/System/Metrics/Prometheus/Ridley/Metrics/DiskUsage.hs

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

ridley/src/System/Metrics/Prometheus/Ridley/Metrics/Memory.hs

@@ -32,4 +32,4 @@ updateProcessMemory g _ = do
 
 --------------------------------------------------------------------------------
 processMemory :: P.Gauge -> RidleyMetricHandler
-processMemory g = mkRidleyMetricHandler g updateProcessMemory False
+processMemory g = mkRidleyMetricHandler "ridley-process-memory" g updateProcessMemory False

ridley/src/System/Metrics/Prometheus/Ridley/Metrics/Network/Darwin.hs

@@ -166,7 +166,7 @@ updateNetworkMetrics nmetrics flush = do
 
 --------------------------------------------------------------------------------
 networkMetrics :: NetworkMetrics -> RidleyMetricHandler
-networkMetrics g = mkRidleyMetricHandler g updateNetworkMetrics False
+networkMetrics g = mkRidleyMetricHandler "ridley-network-metrics" g updateNetworkMetrics False
 
 --------------------------------------------------------------------------------
 mkInterfaceGauge :: MonadIO m => P.Labels -> NetworkMetrics -> IfData -> P.RegistryT m NetworkMetrics

ridley/src/System/Metrics/Prometheus/Ridley/Metrics/Network/Unix.hs

@@ -70,11 +70,7 @@ updateNetworkMetrics nmetrics mustFlush = do
 
 --------------------------------------------------------------------------------
 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

ridley/src/System/Metrics/Prometheus/Ridley/Types.hs

@@ -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,11 @@ module System.Metrics.Prometheus.Ridley.Types (
   , PrometheusOptions
   , RidleyMetric(..)
   , RidleyOptions
-  , RidleyMetricHandler(..)
+  , RidleyMetricHandler
+  , metric
+  , updateMetric
+  , flush
+  , label
   , mkRidleyMetricHandler
   , defaultMetrics
   , newOptions
@@ -43,27 +47,21 @@ 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
-  , label        :: T.Text
-  }
-
 mkRidleyMetricHandler :: forall c. HasCallStack
-                      => c -> (c -> Bool -> IO ()) -> Bool -> RidleyMetricHandler
-mkRidleyMetricHandler c runC flsh = withFrozenCallStack $ RidleyMetricHandler {
+                      => T.Text
+                      -> c -> (c -> Bool -> IO ()) -> Bool -> RidleyMetricHandler
+mkRidleyMetricHandler lbl c runC flsh = withFrozenCallStack $ RidleyMetricHandler {
     metric       = c
   , updateMetric = runC
   , flush        = flsh
-  , label        = T.pack $ prettyCallStack $ popCallStack callStack
+  , label        = lbl
+  , _cs          = popCallStack callStack
   }
 
 --------------------------------------------------------------------------------
@@ -181,7 +179,7 @@ newOptions appLabels metrics = RidleyOptions {
 
 --------------------------------------------------------------------------------
 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 }

ridley/src/System/Metrics/Prometheus/Ridley/Types/Internal.hs

@@ -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
+  }
+