Merge pull request #31 from iconnect/adinapoli/issue-30

Allow Ridley to survive exceptions thrown by handlers

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

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

ridley/example/Main.hs

@@ -9,19 +9,18 @@ import           Lens.Micro
 import           Web.Spock
 import           Web.Spock.Config
 import           Network.Wai.Metrics
+import           Control.Exception
 import           Control.Monad.Trans
-import           Data.Monoid
 import           Data.Time.Clock.POSIX
-import           Data.IORef
 import           Katip
 import           System.IO
-import qualified Data.Text as T
 
 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 ()
@@ -36,25 +35,34 @@ customExpensiveMetric =
     get_metric :: MonadIO m => RidleyOptions -> P.RegistryT m RidleyMetricHandler
     get_metric opts = do
         m <- P.registerGauge "current_time" (opts ^. prometheusOptions . labels)
-        return RidleyMetricHandler { metric = m, updateMetric = update, flush = False }
+        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.ErrorS
+    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.ErrorS Katip.V2
+      Katip.mkHandleScribe Katip.ColorIfTerminal stdout Katip.DebugS Katip.V2
 #endif
-    let opts = newOptions [("service", "ridley-test")] (customExpensiveMetric : defaultMetrics)
+    let opts = newOptions [("service", "ridley-test")] (customExpensiveMetric : customCrashfulMetric : defaultMetrics)
              & prometheusOptions . samplingFrequency .~ 5
              & dataRetentionPeriod .~ Just 60
              & katipScribes .~ ("RidleyTest", [("stdout", ridleyScribe)])

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,
@@ -47,6 +48,7 @@ library
                        text >= 1.2.4.0,
                        mtl,
                        shelly,
+                       safe-exceptions < 1.8,
                        transformers,
                        prometheus > 0.5.0 && < 2.3.0,
                        raw-strings-qq,

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

@@ -3,6 +3,7 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE CPP #-}
 module System.Metrics.Prometheus.Ridley (
     startRidley
@@ -27,19 +28,20 @@ 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)
 import           Control.Monad.Trans.Class (lift)
 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)
@@ -57,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
 
 --------------------------------------------------------------------------------
@@ -76,17 +79,18 @@ 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 <- lift (custom opts)
+          RidleyMetricHandler mtr upd flsh lbl cs <- lift (custom opts)
           doUpdate <- liftIO $ Auto.mkAutoUpdate Auto.defaultUpdateSettings
-                        { updateAction = upd mtr flsh
+                        { updateAction = upd mtr flsh `Ex.catch` logFailedUpdate le lbl cs
                         , updateFreq   = microseconds
                         }
-          pure $ RidleyMetricHandler mtr (\_ _ -> doUpdate) flsh
+          pure $ RidleyMetricHandler mtr (\_ _ -> doUpdate) flsh lbl cs
       $(logTM) sev $ "Registering CustomMetric '" <> fromString (T.unpack metricName) <> "'..."
       (customMetric :) <$> (registerMetrics xs)
     ProcessMemory -> do
@@ -162,7 +166,7 @@ startRidleyWithStore opts path port store = do
 
         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
@@ -175,8 +179,8 @@ startRidleyWithStore opts path port store = do
           $(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
@@ -190,8 +194,8 @@ startRidleyWithStore opts path port store = do
               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))
@@ -201,5 +205,16 @@ serveMetrics = P.serveHttpTextMetrics
 #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

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

@@ -1,11 +1,11 @@
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE TemplateHaskell #-}
 module System.Metrics.Prometheus.Ridley.Metrics.CPU.Darwin
   ( getLoadAvg
   , 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 @@ 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/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,11 +84,7 @@ updateDiskUsageMetrics dmetrics flush = do
 
 --------------------------------------------------------------------------------
 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

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

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

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

@@ -12,7 +12,6 @@ module System.Metrics.Prometheus.Ridley.Metrics.Network.Darwin
 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 @@ updateNetworkMetrics nmetrics flush = 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/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,12 @@ module System.Metrics.Prometheus.Ridley.Types (
   , PrometheusOptions
   , RidleyMetric(..)
   , RidleyOptions
-  , RidleyMetricHandler(..)
+  , RidleyMetricHandler
+  , metric
+  , updateMetric
+  , flush
+  , label
+  , mkRidleyMetricHandler
   , defaultMetrics
   , newOptions
   , prometheusOptions
@@ -32,27 +37,31 @@ import           Control.Monad.IO.Class
 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
   }
 
 --------------------------------------------------------------------------------
@@ -170,10 +179,10 @@ 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 }
+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))

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