diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright IRIS Connect (c) 2017 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cbits/helpers.c b/cbits/helpers.c new file mode 100644 --- /dev/null +++ b/cbits/helpers.c @@ -0,0 +1,15 @@ +#include "helpers.h" + +#ifdef __APPLE__ + +// Free our ridley_if_data data structure +void free_ridley_if_data(ridley_if_data_t* interfaces, int interfacesNum) { + for (int i = 0; i < interfacesNum; i++) { + free(interfaces[i].ridley_ifi_name); + } + + // Finally, deallocate the outermost array + free(interfaces); +} + +#endif diff --git a/include/helpers.h b/include/helpers.h new file mode 100644 --- /dev/null +++ b/include/helpers.h @@ -0,0 +1,34 @@ + +#ifndef RIDLEY_HELPERS__ +#define RIDLEY_HELPERS__ + +#ifdef __APPLE__ + +// Apple/Darwin specific code + +#include + +// A subset of if_data, as defined in +struct ridley_if_data { + u_int32_t ridley_ifi_ipackets; /* packets received on interface */ + u_int32_t ridley_ifi_opackets; /* packets sent on interface */ + u_int32_t ridley_ifi_ierrors; /* input errors on interface */ + u_int32_t ridley_ifi_oerrors; /* output errors on interface */ + u_int32_t ridley_ifi_ibytes; /* total number of octets received */ + u_int32_t ridley_ifi_obytes; /* total number of octets sent */ + u_int32_t ridley_ifi_imcasts; /* packets received via multicast */ + u_int32_t ridley_ifi_omcasts; /* packets sent via multicast */ + u_int32_t ridley_ifi_iqdrops; /* dropped on input, this interface */ + char* ridley_ifi_name; /* The interface name */ + int ridley_ifi_error; /* If there was an error */ +}; + +typedef struct ridley_if_data ridley_if_data_t; + +void free_ridley_if_data(ridley_if_data_t*, int); + +// End of Apple/Darwin specific code + +#endif + +#endif diff --git a/ridley.cabal b/ridley.cabal new file mode 100644 --- /dev/null +++ b/ridley.cabal @@ -0,0 +1,91 @@ +name: ridley +version: 0.3.0.0 +synopsis: Quick metrics to grow you app strong. +description: 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: alfredo@irisconnect.co.uk +copyright: 2017 IRIS Connect Ltd. +category: Web +build-type: Simple +data-files: + include/helpers.h +cabal-version: >=1.10 + +flag lib-Werror + default: False + description: Enable -Werror + +library + hs-source-dirs: src + include-dirs: include + exposed-modules: System.Metrics.Prometheus.Ridley + System.Metrics.Prometheus.Ridley.Types + System.Metrics.Prometheus.Ridley.Metrics.Memory + System.Metrics.Prometheus.Ridley.Metrics.DiskUsage + System.Metrics.Prometheus.Ridley.Metrics.CPU + System.Metrics.Prometheus.Ridley.Metrics.Network + System.Metrics.Prometheus.Ridley.Metrics.Network.Types + + build-depends: async < 3.0.0, + base >= 4.7 && < 5, + containers < 0.6.0.0, + katip < 0.4.0.0, + wai-middleware-metrics < 0.3.0.0, + template-haskell, + ekg-core, + time, + text, + mtl, + shelly, + transformers, + prometheus, + raw-strings-qq, + microlens, + microlens-th, + process, + ekg-prometheus-adapter >= 0.1.0.3, + inline-c, + vector, + unix + c-sources: cbits/helpers.c + cc-options: -Wall -std=c99 + default-language: Haskell2010 + ghc-options: -Wall + if flag(lib-Werror) + ghc-options: -Wall + if os(darwin) + c-sources: src/System/Metrics/Prometheus/Ridley/Metrics/Network/Darwin.c + src/System/Metrics/Prometheus/Ridley/Metrics/CPU/Darwin.c + other-modules: System.Metrics.Prometheus.Ridley.Metrics.Network.Darwin + System.Metrics.Prometheus.Ridley.Metrics.CPU.Darwin + else + other-modules: System.Metrics.Prometheus.Ridley.Metrics.Network.Unix + System.Metrics.Prometheus.Ridley.Metrics.CPU.Unix + +test-suite ridley-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base + , bytestring + , ridley + , tasty + , tasty-hunit + , tasty-quickcheck + , ekg-core + , prometheus + , containers + , microlens + , ekg-prometheus-adapter + , text + , string-conv + , http-client >= 0.4.30 + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/iconnect/haskell-oss/ridley diff --git a/src/System/Metrics/Prometheus/Ridley.hs b/src/System/Metrics/Prometheus/Ridley.hs new file mode 100644 --- /dev/null +++ b/src/System/Metrics/Prometheus/Ridley.hs @@ -0,0 +1,173 @@ +{-# OPTIONS_GHC -fno-warn-type-defaults #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} +module System.Metrics.Prometheus.Ridley ( + startRidley + , startRidleyWithStore + -- * Handy re-exports + , prometheusOptions + , ridleyMetrics + , AdapterOptions(..) + , RidleyCtx + , ridleyWaiMetrics + , ridleyThreadId + , katipScribes + , dataRetentionPeriod + , samplingFrequency + , namespace + , labels + , newOptions + , defaultMetrics + ) where + +import Control.Concurrent (threadDelay, forkIO) +import Control.Concurrent.Async +import Control.Concurrent.MVar +import Control.Monad (foldM) +import Control.Monad.IO.Class (liftIO) +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 qualified Data.Set as Set +import Data.String +import Data.Time +import GHC.Conc (getNumCapabilities, getNumProcessors) +import Katip +import Lens.Micro +import Network.Wai.Metrics (registerWaiMetrics) +import System.Metrics as EKG +import qualified System.Metrics.Prometheus.Concurrent.Http as P +import System.Metrics.Prometheus.Metric.Counter (add) +import qualified System.Metrics.Prometheus.RegistryT as P +import System.Metrics.Prometheus.Ridley.Metrics.CPU +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.Remote.Monitoring.Prometheus + +-------------------------------------------------------------------------------- +startRidley :: RidleyOptions + -> P.Path + -> Port + -> IO RidleyCtx +startRidley opts path port = do + store <- EKG.newStore + EKG.registerGcMetrics store + 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 + case x of + 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 +#if defined darwin_HOST_OS + (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 +#endif + let !network = networkMetrics imap + $(logTM) sev "Registering Network metric..." + (network :) <$> registerMetrics xs + +-------------------------------------------------------------------------------- +startRidleyWithStore :: RidleyOptions + -> P.Path + -> Port + -> EKG.Store + -> IO RidleyCtx +startRidleyWithStore opts path port store = do + tid <- forkRidley + mbMetr <- case Set.member Wai (opts ^. ridleyMetrics) of + False -> return Nothing + True -> Just <$> registerWaiMetrics store + + return $ RidleyCtx tid mbMetr + where + forkRidley = forkIO $ do + x <- newEmptyMVar + le <- initLogEnv (opts ^. katipScribes . _1) "production" + + -- Register all the externally-passed Katip's Scribe + let le' = List.foldl' (\le0 (n,s) -> registerScribe n s le0) le (opts ^. katipScribes . _2) + + -- Start the server + serverLoop <- async $ runRidley opts le' $ do + lift $ registerEKGStore store (opts ^. prometheusOptions) + handlers <- registerMetrics (Set.toList $ opts ^. ridleyMetrics) + + liftIO $ do + lastUpdate <- newIORef =<< getCurrentTime + updateLoop <- async $ handlersLoop lastUpdate handlers + putMVar x updateLoop + + lift $ P.sample >>= P.serveHttpTextMetrics port path + + ul <- takeMVar x + link2 serverLoop ul + res <- waitCatch ul + case res of + Left e -> runKatipContextT le' () "errors" $ do + $(logTM) ErrorS (fromString $ show e) + Right _ -> return () + + handlersLoop :: IORef UTCTime -> [RidleyMetricHandler] -> IO a + handlersLoop lastUpdateRef handlers = do + let freq = opts ^. prometheusOptions . samplingFrequency + let flushPeriod = opts ^. dataRetentionPeriod + mustFlush <- case flushPeriod of + Nothing -> return False + Just p -> do + now <- getCurrentTime + lastUpdate <- readIORef lastUpdateRef + case diffUTCTime lastUpdate now >= p of + True -> do + modifyIORef' lastUpdateRef (const now) + return True + False -> return False + threadDelay (freq * 10^6) + updateHandlers (List.map (\x -> x { flush = mustFlush }) handlers) + handlersLoop lastUpdateRef handlers + +-------------------------------------------------------------------------------- +updateHandlers :: [RidleyMetricHandler] -> IO () +updateHandlers = mapM_ runHandler diff --git a/src/System/Metrics/Prometheus/Ridley/Metrics/CPU.hs b/src/System/Metrics/Prometheus/Ridley/Metrics/CPU.hs new file mode 100644 --- /dev/null +++ b/src/System/Metrics/Prometheus/Ridley/Metrics/CPU.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE CPP #-} +module System.Metrics.Prometheus.Ridley.Metrics.CPU + ( processCPULoad + ) where + +#ifdef darwin_HOST_OS +import System.Metrics.Prometheus.Ridley.Metrics.CPU.Darwin +#else +import System.Metrics.Prometheus.Ridley.Metrics.CPU.Unix +#endif diff --git a/src/System/Metrics/Prometheus/Ridley/Metrics/CPU/Darwin.c b/src/System/Metrics/Prometheus/Ridley/Metrics/CPU/Darwin.c new file mode 100644 --- /dev/null +++ b/src/System/Metrics/Prometheus/Ridley/Metrics/CPU/Darwin.c @@ -0,0 +1,7 @@ + +#include + +int inline_c_System_Metrics_Prometheus_Ridley_Metrics_CPU_Darwin_0_fe4c7ffe3048a794673ef39573f91525af37ea82(double * v_inline_c_0) { +return ( getloadavg(v_inline_c_0, 3) ); +} + diff --git a/src/System/Metrics/Prometheus/Ridley/Metrics/CPU/Darwin.hs b/src/System/Metrics/Prometheus/Ridley/Metrics/CPU/Darwin.hs new file mode 100644 --- /dev/null +++ b/src/System/Metrics/Prometheus/Ridley/Metrics/CPU/Darwin.hs @@ -0,0 +1,44 @@ +{-# 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 +import qualified Language.C.Inline as C +import qualified System.Metrics.Prometheus.Metric.Gauge as P +import System.Metrics.Prometheus.Ridley.Types + +C.context (C.baseCtx <> C.vecCtx) +C.include "" + +-------------------------------------------------------------------------------- +getLoadAvg :: IO (V.Vector CDouble) +getLoadAvg = do + v <- VM.new 3 + _ <- [C.exp| int { getloadavg($vec-ptr:(double* v), 3) } |] + V.freeze v + +-------------------------------------------------------------------------------- +-- | As we have 3 gauges, it makes no sense flushing them. +updateCPULoad :: (P.Gauge, P.Gauge, P.Gauge) -> Bool -> IO () +updateCPULoad (cpu1m, cpu5m, cpu15m) _ = do + loadVec <- getLoadAvg + P.set (fromCDouble $ loadVec `V.unsafeIndex` 0) cpu1m + P.set (fromCDouble $ loadVec `V.unsafeIndex` 1) cpu5m + P.set (fromCDouble $ loadVec `V.unsafeIndex` 2) cpu15m + where + fromCDouble :: CDouble -> Double + fromCDouble (CDouble d) = d + +-------------------------------------------------------------------------------- +processCPULoad :: (P.Gauge, P.Gauge, P.Gauge) -> RidleyMetricHandler +processCPULoad g = RidleyMetricHandler { + metric = g + , updateMetric = updateCPULoad + , flush = False + } diff --git a/src/System/Metrics/Prometheus/Ridley/Metrics/CPU/Unix.hs b/src/System/Metrics/Prometheus/Ridley/Metrics/CPU/Unix.hs new file mode 100644 --- /dev/null +++ b/src/System/Metrics/Prometheus/Ridley/Metrics/CPU/Unix.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +module System.Metrics.Prometheus.Ridley.Metrics.CPU.Unix + ( getLoadAvg + , processCPULoad + ) where + +import qualified Data.Text as T +import Data.Traversable +import qualified Data.Vector as V +import Shelly +import qualified System.Metrics.Prometheus.Metric.Gauge as P +import System.Metrics.Prometheus.Ridley.Types +import Text.Read (readMaybe) + +-------------------------------------------------------------------------------- +getLoadAvg :: IO (V.Vector Double) +getLoadAvg = do + rawOutput <- shelly $ silently $ take 3 . T.lines . T.strip <$> run "cat" ["/proc/loadavg"] + let loads = case traverse (readMaybe . T.unpack) rawOutput of + Just [a,b,c] -> [a,b,c] + _ -> [-1.0, -1.0, -1.0] + return $ V.fromList loads + +-------------------------------------------------------------------------------- +-- | As we have 3 gauges, it makes no sense flushing them. +updateCPULoad :: (P.Gauge, P.Gauge, P.Gauge) -> Bool -> IO () +updateCPULoad (cpu1m, cpu5m, cpu15m) _ = do + loadVec <- getLoadAvg + P.set (loadVec `V.unsafeIndex` 0) cpu1m + P.set (loadVec `V.unsafeIndex` 1) cpu5m + P.set (loadVec `V.unsafeIndex` 2) cpu15m + +-------------------------------------------------------------------------------- +processCPULoad :: (P.Gauge, P.Gauge, P.Gauge) -> RidleyMetricHandler +processCPULoad g = RidleyMetricHandler { + metric = g + , updateMetric = updateCPULoad + , flush = False + } diff --git a/src/System/Metrics/Prometheus/Ridley/Metrics/DiskUsage.hs b/src/System/Metrics/Prometheus/Ridley/Metrics/DiskUsage.hs new file mode 100644 --- /dev/null +++ b/src/System/Metrics/Prometheus/Ridley/Metrics/DiskUsage.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +module System.Metrics.Prometheus.Ridley.Metrics.DiskUsage ( + getDiskStats + , mkDiskGauge + , diskUsageMetrics + ) where + +import Control.Monad +import Control.Monad.IO.Class +import qualified Data.Map.Strict as M +import Data.Maybe +import qualified Data.Text as T +import Lens.Micro +import Lens.Micro.TH +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 + + +-------------------------------------------------------------------------------- +data DiskStats = DiskStats { + _diskFilesystem :: T.Text + , _diskUsed :: Double + , _diskFree :: Double + } deriving Show + +makeLenses ''DiskStats + +-------------------------------------------------------------------------------- +data DiskMetric = DiskMetric { + _dskMetricUsed :: P.Gauge + , _dskMetricFree :: P.Gauge + } + +-------------------------------------------------------------------------------- +type DiskUsageMetrics = M.Map T.Text DiskMetric + +-------------------------------------------------------------------------------- +getDiskStats :: IO [DiskStats] +getDiskStats = 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 + where + mkDiskStats :: T.Text -> Maybe DiskStats + mkDiskStats rawLine = case T.words rawLine of +#ifdef darwin_HOST_OS + [fs,_, used,free,_,_,_,_,_] -> DiskStats <$> pure fs + <*> readMaybe (T.unpack used) + <*> readMaybe (T.unpack free) +#else + -- On Linux, `df` shows less things by default, example + -- Filesystem 1K-blocks Used Available Use% Mounted on + -- /dev/xvda1 52416860 27408532 25008328 53% / + [fs,_, used,free,_,_] -> DiskStats <$> pure fs + <*> readMaybe (T.unpack used) + <*> readMaybe (T.unpack free) +#endif + _ -> Nothing + +-------------------------------------------------------------------------------- +-- | As this is a gauge, it makes no sense flushing it. +updateDiskUsageMetric :: DiskMetric -> DiskStats -> Bool -> IO () +updateDiskUsageMetric DiskMetric{..} d _ = do + P.set (d ^. diskUsed) _dskMetricUsed + P.set (d ^. diskFree) _dskMetricFree + +-------------------------------------------------------------------------------- +updateDiskUsageMetrics :: DiskUsageMetrics -> Bool -> IO () +updateDiskUsageMetrics dmetrics flush = do + diskStats <- getDiskStats + forM_ diskStats $ \d -> do + let key = d ^. diskFilesystem + case M.lookup key dmetrics of + Nothing -> return () + Just m -> updateDiskUsageMetric m d flush + +-------------------------------------------------------------------------------- +diskUsageMetrics :: DiskUsageMetrics -> RidleyMetricHandler +diskUsageMetrics g = RidleyMetricHandler { + metric = g + , updateMetric = updateDiskUsageMetrics + , flush = False + } + +-------------------------------------------------------------------------------- +mkDiskGauge :: MonadIO m => P.Labels -> DiskUsageMetrics -> DiskStats -> P.RegistryT m DiskUsageMetrics +mkDiskGauge currentLabels dmap d = do + let fs = d ^. diskFilesystem + let finalLabels = P.addLabel "filesystem" fs currentLabels + metric <- DiskMetric <$> P.registerGauge "disk_used_bytes_blocks" finalLabels + <*> P.registerGauge "disk_free_bytes_blocks" finalLabels + liftIO $ updateDiskUsageMetric metric d False + return $! M.insert fs metric $! dmap diff --git a/src/System/Metrics/Prometheus/Ridley/Metrics/Memory.hs b/src/System/Metrics/Prometheus/Ridley/Metrics/Memory.hs new file mode 100644 --- /dev/null +++ b/src/System/Metrics/Prometheus/Ridley/Metrics/Memory.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE OverloadedStrings #-} +module System.Metrics.Prometheus.Ridley.Metrics.Memory ( + processMemory + ) where + +import qualified System.Metrics.Prometheus.Metric.Gauge as P +import System.Metrics.Prometheus.Ridley.Types +import System.Posix.Process +import System.Process +import Text.Read + +-------------------------------------------------------------------------------- +-- | Return the amount of occupied memory for this +-- process. We use unix's `ps` command that, +-- although has the reputation of not being 100% +-- accurate, at least works on Darwin and Linux +-- without using any CPP processor. +-- Returns the memory in Kb. +getProcessMemory :: IO (Maybe Integer) +getProcessMemory = do + myPid <- getProcessID + readMaybe <$> readProcess "ps" ["-o", "rss=", "-p", show myPid] [] + +-------------------------------------------------------------------------------- +-- | As this is a gauge, it makes no sense flushing it. +updateProcessMemory :: P.Gauge -> Bool -> IO () +updateProcessMemory g _ = do + mbMem <- getProcessMemory + case mbMem of + Nothing -> return () + Just m -> P.set (fromIntegral m) g + +-------------------------------------------------------------------------------- +processMemory :: P.Gauge -> RidleyMetricHandler +processMemory g = RidleyMetricHandler { + metric = g + , updateMetric = updateProcessMemory + , flush = False + } diff --git a/src/System/Metrics/Prometheus/Ridley/Metrics/Network.hs b/src/System/Metrics/Prometheus/Ridley/Metrics/Network.hs new file mode 100644 --- /dev/null +++ b/src/System/Metrics/Prometheus/Ridley/Metrics/Network.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE CPP #-} +module System.Metrics.Prometheus.Ridley.Metrics.Network + ( networkMetrics + , getNetworkMetrics + , mkInterfaceGauge + , NetworkMetrics + , NetworkMetric + , IfData(..) + ) where + +#ifdef darwin_HOST_OS +import System.Metrics.Prometheus.Ridley.Metrics.Network.Darwin +#else +import System.Metrics.Prometheus.Ridley.Metrics.Network.Unix +#endif + +import System.Metrics.Prometheus.Ridley.Metrics.Network.Types diff --git a/src/System/Metrics/Prometheus/Ridley/Metrics/Network/Darwin.c b/src/System/Metrics/Prometheus/Ridley/Metrics/Network/Darwin.c new file mode 100644 --- /dev/null +++ b/src/System/Metrics/Prometheus/Ridley/Metrics/Network/Darwin.c @@ -0,0 +1,104 @@ + +#include + +#include + +#include + +#include + +#include + +#include "helpers.h" + +#include + +#include + +#include + + +void set_ridley_ifi_data(struct if_data* netData, ridley_if_data_t* devStats) { + + //devStats["receive_packets"] = convertFreeBSDCPUTime(uint64(netData.ifi_ipackets)); + devStats->ridley_ifi_ipackets = (long)(netData->ifi_ipackets); + + //devStats["transmit_packets"] = convertFreeBSDCPUTime(uint64(netData.ifi_opackets)); + devStats->ridley_ifi_opackets = (long)(netData->ifi_opackets); + + //devStats["receive_errs"] = convertFreeBSDCPUTime(uint64(netData.ifi_ierrors)); + devStats->ridley_ifi_ierrors = (long)(netData->ifi_ierrors); + + //devStats["transmit_errs"] = convertFreeBSDCPUTime(uint64(netData.ifi_oerrors)); + devStats->ridley_ifi_oerrors = (long)(netData->ifi_oerrors); + + //devStats["receive_bytes"] = convertFreeBSDCPUTime(uint64(netData.ifi_ibytes)); + devStats->ridley_ifi_ibytes = (long)(netData->ifi_ibytes); + + //devStats["transmit_bytes"] = convertFreeBSDCPUTime(uint64(netData.ifi_obytes)); + devStats->ridley_ifi_obytes = (long)(netData->ifi_obytes); + + //devStats["receive_multicast"] = convertFreeBSDCPUTime(uint64(netData.ifi_imcasts)); + devStats->ridley_ifi_imcasts = (long)(netData->ifi_imcasts); + //devStats["transmit_multicast"] = convertFreeBSDCPUTime(uint64(netData.ifi_omcasts)); + devStats->ridley_ifi_omcasts = (long)(netData->ifi_omcasts); + //devStats["receive_drop"] = convertFreeBSDCPUTime(uint64(netData.ifi_iqdrops)); + devStats->ridley_ifi_iqdrops = (long)(netData->ifi_iqdrops); + + //devStats["transmit_drop"] = convertFreeBSDCPUTime(uint64(netData.ifi_oqdrops)); + // Not present in this version of if_data +} + + +ridley_if_data_t * inline_c_System_Metrics_Prometheus_Ridley_Metrics_Network_Darwin_0_ef41cfb6dc39c2d642dd88d273ce5058cea8099d(int * totalInterfaces_inline_c_0) { + + struct ifaddrs *ifap, *ifa; + struct if_data *netData; + ridley_if_data_t *netDev = malloc(30 * sizeof(ridley_if_data_t)); + int interfaceIdx = 0; + + // Compile a regex to ignore certain devices + regex_t regex; + int ignoreDevice; + + ignoreDevice = regcomp(®ex, "^(ram|loop|fd|(h|s|v|xv)d[a-z]|nvme\\d+n\\d+p)\\d+$", 0); + + if (ignoreDevice) { + netDev[0].ridley_ifi_error = 1; + return netDev; + } + + if (getifaddrs(&ifap) == -1) { + netDev[0].ridley_ifi_error = 1; + return netDev; + } + + // Iterate over all the network interfaces found + for (ifa = ifap; ifa; ifa = ifa->ifa_next) { + if (ifa->ifa_addr->sa_family == AF_LINK) { + char* currentDevice = malloc((strlen(ifa->ifa_name) + 1) * sizeof(char)); + strcpy(currentDevice, ifa->ifa_name); + ignoreDevice = regexec(®ex, currentDevice, 0, NULL, 0); + if (!ignoreDevice) { + regfree(®ex); + free(currentDevice); + continue; + } else { + regfree(®ex); + } + + ridley_if_data_t *devStats = &netDev[interfaceIdx]; + netData = ifa->ifa_data; + devStats->ridley_ifi_name = currentDevice; + set_ridley_ifi_data(netData, devStats); + devStats->ridley_ifi_error = 0; + interfaceIdx++; + + } + } + freeifaddrs(ifap); + *totalInterfaces_inline_c_0 = interfaceIdx; + return netDev; + +} + diff --git a/src/System/Metrics/Prometheus/Ridley/Metrics/Network/Darwin.hs b/src/System/Metrics/Prometheus/Ridley/Metrics/Network/Darwin.hs new file mode 100644 --- /dev/null +++ b/src/System/Metrics/Prometheus/Ridley/Metrics/Network/Darwin.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +module System.Metrics.Prometheus.Ridley.Metrics.Network.Darwin + ( networkMetrics + , getNetworkMetrics + , mkInterfaceGauge + ) where + +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 +import Foreign.Marshal.Alloc +import Foreign.Marshal.Array +import Foreign.Ptr +import Foreign.Storable +import qualified Language.C.Inline as C +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.Metrics.Network.Types +import System.Metrics.Prometheus.Ridley.Types +import Text.RawString.QQ (r) + +C.context (C.baseCtx <> C.vecCtx <> ifDataCtx) +C.include "" +C.include "" +C.include "" +C.include "" +C.include "" +C.include "helpers.h" +C.include "" +C.include "" +C.include "" + + +C.verbatim [r| +void set_ridley_ifi_data(struct if_data* netData, ridley_if_data_t* devStats) { + + //devStats["receive_packets"] = convertFreeBSDCPUTime(uint64(netData.ifi_ipackets)); + devStats->ridley_ifi_ipackets = (long)(netData->ifi_ipackets); + + //devStats["transmit_packets"] = convertFreeBSDCPUTime(uint64(netData.ifi_opackets)); + devStats->ridley_ifi_opackets = (long)(netData->ifi_opackets); + + //devStats["receive_errs"] = convertFreeBSDCPUTime(uint64(netData.ifi_ierrors)); + devStats->ridley_ifi_ierrors = (long)(netData->ifi_ierrors); + + //devStats["transmit_errs"] = convertFreeBSDCPUTime(uint64(netData.ifi_oerrors)); + devStats->ridley_ifi_oerrors = (long)(netData->ifi_oerrors); + + //devStats["receive_bytes"] = convertFreeBSDCPUTime(uint64(netData.ifi_ibytes)); + devStats->ridley_ifi_ibytes = (long)(netData->ifi_ibytes); + + //devStats["transmit_bytes"] = convertFreeBSDCPUTime(uint64(netData.ifi_obytes)); + devStats->ridley_ifi_obytes = (long)(netData->ifi_obytes); + + //devStats["receive_multicast"] = convertFreeBSDCPUTime(uint64(netData.ifi_imcasts)); + devStats->ridley_ifi_imcasts = (long)(netData->ifi_imcasts); + //devStats["transmit_multicast"] = convertFreeBSDCPUTime(uint64(netData.ifi_omcasts)); + devStats->ridley_ifi_omcasts = (long)(netData->ifi_omcasts); + //devStats["receive_drop"] = convertFreeBSDCPUTime(uint64(netData.ifi_iqdrops)); + devStats->ridley_ifi_iqdrops = (long)(netData->ifi_iqdrops); + + //devStats["transmit_drop"] = convertFreeBSDCPUTime(uint64(netData.ifi_oqdrops)); + // Not present in this version of if_data +} +|] + +-------------------------------------------------------------------------------- +getNetworkMetrics' :: IO (Ptr IfData, Ptr C.CInt) +getNetworkMetrics' = do + (totalInterfaces :: Ptr C.CInt) <- malloc + res <- [C.block| ridley_if_data_t* { + struct ifaddrs *ifap, *ifa; + struct if_data *netData; + ridley_if_data_t *netDev = malloc(30 * sizeof(ridley_if_data_t)); + int interfaceIdx = 0; + + // Compile a regex to ignore certain devices + regex_t regex; + int ignoreDevice; + + ignoreDevice = regcomp(®ex, "^(ram|loop|fd|(h|s|v|xv)d[a-z]|nvme\\d+n\\d+p)\\d+$$", 0); + + if (ignoreDevice) { + netDev[0].ridley_ifi_error = 1; + return netDev; + } + + if (getifaddrs(&ifap) == -1) { + netDev[0].ridley_ifi_error = 1; + return netDev; + } + + // Iterate over all the network interfaces found + for (ifa = ifap; ifa; ifa = ifa->ifa_next) { + if (ifa->ifa_addr->sa_family == AF_LINK) { + char* currentDevice = malloc((strlen(ifa->ifa_name) + 1) * sizeof(char)); + strcpy(currentDevice, ifa->ifa_name); + ignoreDevice = regexec(®ex, currentDevice, 0, NULL, 0); + if (!ignoreDevice) { + regfree(®ex); + free(currentDevice); + continue; + } else { + regfree(®ex); + } + + ridley_if_data_t *devStats = &netDev[interfaceIdx]; + netData = ifa->ifa_data; + devStats->ridley_ifi_name = currentDevice; + set_ridley_ifi_data(netData, devStats); + devStats->ridley_ifi_error = 0; + interfaceIdx++; + + } + } + freeifaddrs(ifap); + *$(int* totalInterfaces) = interfaceIdx; + return netDev; + } + |] + return (res, totalInterfaces) + +-------------------------------------------------------------------------------- +getNetworkMetrics :: IO ([IfData], IO ()) +getNetworkMetrics = do + (raw, total) <- getNetworkMetrics' + (CInt interfacesNum) <- peek total + m <- peekArray (fromIntegral interfacesNum) raw + let dtor = freeRidleyIFData raw (CInt interfacesNum) + free total + return (m, dtor) + +-------------------------------------------------------------------------------- +-- | As this is a gauge, it makes no sense flushing it. +updateNetworkMetric :: NetworkMetric -> IfData -> Bool -> IO () +updateNetworkMetric NetworkMetric{..} IfData{..} _ = do + P.set (fromIntegral ifi_ipackets) receive_packets + P.set (fromIntegral ifi_opackets) transmit_packets + P.set (fromIntegral ifi_ierrors) receive_errs + P.set (fromIntegral ifi_oerrors) transmit_errs + P.set (fromIntegral ifi_ibytes) receive_bytes + P.set (fromIntegral ifi_obytes) transmit_bytes + P.set (fromIntegral ifi_imcasts) receive_multicast + P.set (fromIntegral ifi_omcasts) transmit_multicast + P.set (fromIntegral ifi_iqdrops) receive_drop + +-------------------------------------------------------------------------------- +updateNetworkMetrics :: NetworkMetrics -> Bool -> IO () +updateNetworkMetrics nmetrics flush = do + (ifaces, dtor) <- getNetworkMetrics + forM_ ifaces $ \d@IfData{..} -> do + key <- T.pack <$> peekCAString ifi_name + case M.lookup key nmetrics of + Nothing -> return () + Just m -> updateNetworkMetric m d flush + dtor + + +-------------------------------------------------------------------------------- +networkMetrics :: NetworkMetrics -> RidleyMetricHandler +networkMetrics g = RidleyMetricHandler { + metric = g + , updateMetric = updateNetworkMetrics + , flush = False + } + +-------------------------------------------------------------------------------- +mkInterfaceGauge :: MonadIO m => P.Labels -> NetworkMetrics -> IfData -> P.RegistryT m NetworkMetrics +mkInterfaceGauge currentLabels imap d@IfData{..} = do + iname <- T.pack <$> liftIO (peekCAString ifi_name) + let finalLabels = P.addLabel "interface" iname currentLabels + metric <- NetworkMetric <$> P.registerGauge "network_receive_packets" finalLabels + <*> P.registerGauge "network_transmit_packets" finalLabels + <*> P.registerGauge "network_receive_errs" finalLabels + <*> P.registerGauge "network_transmit_errs" finalLabels + <*> P.registerGauge "network_receive_bytes" finalLabels + <*> P.registerGauge "network_transmit_bytes" finalLabels + <*> P.registerGauge "network_receive_multicast" finalLabels + <*> P.registerGauge "network_transmit_multicast" finalLabels + <*> P.registerGauge "network_receive_drop" finalLabels + liftIO $ updateNetworkMetric metric d False + return $! M.insert iname metric $! imap diff --git a/src/System/Metrics/Prometheus/Ridley/Metrics/Network/Types.hsc b/src/System/Metrics/Prometheus/Ridley/Metrics/Network/Types.hsc new file mode 100644 --- /dev/null +++ b/src/System/Metrics/Prometheus/Ridley/Metrics/Network/Types.hsc @@ -0,0 +1,125 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +module System.Metrics.Prometheus.Ridley.Metrics.Network.Types where + +import qualified Data.Map as Map +import Data.Map.Strict as M +import qualified Data.Text as T +import Foreign.C.String +import Foreign.C.Types +import Foreign.Ptr +import Foreign.Storable (Storable(..)) +import Language.C.Inline.Context +import qualified Language.C.Types as C +import qualified Language.Haskell.TH as TH +import qualified System.Metrics.Prometheus.Metric.Gauge as P + +#if __GLASGOW_HASKELL__ < 800 +#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__) +#endif + +#include "helpers.h" + +data IfData = IfData { +#ifdef darwin_HOST_OS + ifi_ipackets :: {-# UNPACK #-} !CUInt + , ifi_opackets :: {-# UNPACK #-} !CUInt + , ifi_ierrors :: {-# UNPACK #-} !CUInt + , ifi_oerrors :: {-# UNPACK #-} !CUInt + , ifi_ibytes :: {-# UNPACK #-} !CUInt + , ifi_obytes :: {-# UNPACK #-} !CUInt + , ifi_imcasts :: {-# UNPACK #-} !CUInt + , ifi_omcasts :: {-# UNPACK #-} !CUInt + , ifi_iqdrops :: {-# UNPACK #-} !CUInt + , ifi_name :: {-# UNPACK #-} !CString + , ifi_error :: {-# UNPACK #-} !CInt +# else + ifi_ipackets :: {-# UNPACK #-} !Int + , ifi_opackets :: {-# UNPACK #-} !Int + , ifi_ierrors :: {-# UNPACK #-} !Int + , ifi_oerrors :: {-# UNPACK #-} !Int + , ifi_ibytes :: {-# UNPACK #-} !Int + , ifi_obytes :: {-# UNPACK #-} !Int + , ifi_imcasts :: {-# UNPACK #-} !Int + , ifi_omcasts :: {-# UNPACK #-} !Int + , ifi_iqdrops :: {-# UNPACK #-} !Int + , ifi_name :: !String + , ifi_error :: {-# UNPACK #-} !Int +#endif + } deriving Show + + +#ifdef darwin_HOST_OS +foreign import ccall "helpers.h free_ridley_if_data" + freeRidleyIFData :: Ptr IfData -> CInt -> IO () + +instance Storable IfData where + sizeOf _ = #{size ridley_if_data_t} + alignment _ = #{alignment ridley_if_data_t} + peek ptr = do + ipackets <- (#peek ridley_if_data_t, ridley_ifi_ipackets) ptr + opackets <- (#peek ridley_if_data_t, ridley_ifi_opackets) ptr + ierrors <- (#peek ridley_if_data_t, ridley_ifi_ierrors) ptr + oerrors <- (#peek ridley_if_data_t, ridley_ifi_oerrors) ptr + ibytes <- (#peek ridley_if_data_t, ridley_ifi_ibytes) ptr + obytes <- (#peek ridley_if_data_t, ridley_ifi_obytes) ptr + imcasts <- (#peek ridley_if_data_t, ridley_ifi_imcasts) ptr + omcasts <- (#peek ridley_if_data_t, ridley_ifi_omcasts) ptr + iqdrops <- (#peek ridley_if_data_t, ridley_ifi_iqdrops) ptr + iname <- (#peek ridley_if_data_t, ridley_ifi_name) ptr + err <- (#peek ridley_if_data_t, ridley_ifi_error) ptr + return IfData { + ifi_ipackets = ipackets + , ifi_opackets = opackets + , ifi_ierrors = ierrors + , ifi_oerrors = oerrors + , ifi_ibytes = ibytes + , ifi_obytes = obytes + , ifi_imcasts = imcasts + , ifi_omcasts = omcasts + , ifi_iqdrops = iqdrops + , ifi_name = iname + , ifi_error = err + } + poke ptr IfData{..} = do + (#poke ridley_if_data_t, ridley_ifi_ipackets) ptr ifi_ipackets + (#poke ridley_if_data_t, ridley_ifi_opackets) ptr ifi_opackets + (#poke ridley_if_data_t, ridley_ifi_ierrors) ptr ifi_ierrors + (#poke ridley_if_data_t, ridley_ifi_oerrors) ptr ifi_oerrors + (#poke ridley_if_data_t, ridley_ifi_ibytes) ptr ifi_ibytes + (#poke ridley_if_data_t, ridley_ifi_obytes) ptr ifi_obytes + (#poke ridley_if_data_t, ridley_ifi_imcasts) ptr ifi_imcasts + (#poke ridley_if_data_t, ridley_ifi_omcasts) ptr ifi_omcasts + (#poke ridley_if_data_t, ridley_ifi_iqdrops) ptr ifi_iqdrops + (#poke ridley_if_data_t, ridley_ifi_name) ptr ifi_name + (#poke ridley_if_data_t, ridley_ifi_error) ptr ifi_error + +ifDataCtx :: Context +ifDataCtx = mempty { ctxTypesTable = ridleyNetworkTypesTable } + +ridleyNetworkTypesTable :: Map.Map C.TypeSpecifier TH.TypeQ +ridleyNetworkTypesTable = Map.fromList + [ (C.TypeName "ridley_if_data_t", [t| IfData |]) + ] + +#endif + +-------------------------------------------------------------------------------- +type NetworkMetrics = M.Map T.Text NetworkMetric + +-------------------------------------------------------------------------------- +data NetworkMetric = NetworkMetric { + receive_packets :: P.Gauge + , transmit_packets :: P.Gauge + , receive_errs :: P.Gauge + , transmit_errs :: P.Gauge + , receive_bytes :: P.Gauge + , transmit_bytes :: P.Gauge + , receive_multicast :: P.Gauge + , transmit_multicast :: P.Gauge + , receive_drop :: P.Gauge + } diff --git a/src/System/Metrics/Prometheus/Ridley/Metrics/Network/Unix.hs b/src/System/Metrics/Prometheus/Ridley/Metrics/Network/Unix.hs new file mode 100644 --- /dev/null +++ b/src/System/Metrics/Prometheus/Ridley/Metrics/Network/Unix.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module System.Metrics.Prometheus.Ridley.Metrics.Network.Unix + ( networkMetrics + , getNetworkMetrics + , mkInterfaceGauge + ) where + +import Control.Monad +import Control.Monad.IO.Class +import qualified Data.Map.Strict as M +import Data.Maybe +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Prelude hiding (FilePath) +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.Metrics.Network.Types +import System.Metrics.Prometheus.Ridley.Types + +-------------------------------------------------------------------------------- +-- | Parse /proc/net/dev to get the relevant stats. +getNetworkMetrics :: IO [IfData] +getNetworkMetrics = do + interfaces <- drop 2 . T.lines . T.strip <$> T.readFile "/proc/net/dev" + return $! mapMaybe mkInterface interfaces + where + mkInterface :: T.Text -> Maybe IfData + mkInterface rawLine = case T.words . T.strip $ rawLine of + [iface, ibytes, ipackets, ierrs, idrop, _, _, _, imulticast, obytes, opackets, oerrs, _, _, _, _, _] -> + Just $ IfData { + ifi_ipackets = read $ T.unpack ipackets + , ifi_opackets = read $ T.unpack opackets + , ifi_ierrors = read $ T.unpack ierrs + , ifi_oerrors = read $ T.unpack oerrs + , ifi_ibytes = read $ T.unpack ibytes + , ifi_obytes = read $ T.unpack obytes + , ifi_imcasts = read $ T.unpack imulticast + , ifi_omcasts = 0 + , ifi_iqdrops = read $ T.unpack idrop + , ifi_name = T.unpack $ T.init iface + , ifi_error = 0 + } + _ -> Nothing + +-------------------------------------------------------------------------------- +updateNetworkMetric :: NetworkMetric -> IfData -> Bool -> IO () +updateNetworkMetric NetworkMetric{..} IfData{..} _ = do + P.set (fromIntegral ifi_ipackets) receive_packets + P.set (fromIntegral ifi_opackets) transmit_packets + P.set (fromIntegral ifi_ierrors) receive_errs + P.set (fromIntegral ifi_oerrors) transmit_errs + P.set (fromIntegral ifi_ibytes) receive_bytes + P.set (fromIntegral ifi_obytes) transmit_bytes + P.set (fromIntegral ifi_imcasts) receive_multicast + P.set (fromIntegral ifi_omcasts) transmit_multicast + P.set (fromIntegral ifi_iqdrops) receive_drop + +-------------------------------------------------------------------------------- +updateNetworkMetrics :: NetworkMetrics -> Bool -> IO () +updateNetworkMetrics nmetrics mustFlush = do + ifaces <- getNetworkMetrics + forM_ ifaces $ \d@IfData{..} -> do + let key = T.pack ifi_name + case M.lookup key nmetrics of + Nothing -> return () + Just m -> updateNetworkMetric m d mustFlush + +-------------------------------------------------------------------------------- +networkMetrics :: NetworkMetrics -> RidleyMetricHandler +networkMetrics g = RidleyMetricHandler { + metric = g + , updateMetric = updateNetworkMetrics + , flush = False + } + +-------------------------------------------------------------------------------- +mkInterfaceGauge :: MonadIO m => P.Labels -> NetworkMetrics -> IfData -> P.RegistryT m NetworkMetrics +mkInterfaceGauge currentLabels imap d@IfData{..} = do + let iname = T.pack ifi_name + let finalLabels = P.addLabel "interface" iname currentLabels + metric <- NetworkMetric <$> P.registerGauge "network_receive_packets" finalLabels + <*> P.registerGauge "network_transmit_packets" finalLabels + <*> P.registerGauge "network_receive_errs" finalLabels + <*> P.registerGauge "network_transmit_errs" finalLabels + <*> P.registerGauge "network_receive_bytes" finalLabels + <*> P.registerGauge "network_transmit_bytes" finalLabels + <*> P.registerGauge "network_receive_multicast" finalLabels + <*> P.registerGauge "network_transmit_multicast" finalLabels + <*> P.registerGauge "network_receive_drop" finalLabels + liftIO $ updateNetworkMetric metric d False + return $! M.insert iname metric $! imap diff --git a/src/System/Metrics/Prometheus/Ridley/Types.hs b/src/System/Metrics/Prometheus/Ridley/Types.hs new file mode 100644 --- /dev/null +++ b/src/System/Metrics/Prometheus/Ridley/Types.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE TemplateHaskell #-} +module System.Metrics.Prometheus.Ridley.Types ( + RidleyT(Ridley) + , Ridley + , runRidley + , RidleyCtx(RidleyCtx) + , ridleyThreadId + , ridleyWaiMetrics + , Port + , PrometheusOptions + , RidleyMetric(..) + , RidleyOptions + , RidleyMetricHandler(..) + , defaultMetrics + , newOptions + , prometheusOptions + , ridleyMetrics + , katipScribes + , katipSeverity + , dataRetentionPeriod + , runHandler + ) where + +import Control.Concurrent (ThreadId) +import Control.Monad.IO.Class +import Control.Monad.Reader (MonadReader) +import Control.Monad.Trans.Class +import Control.Monad.Trans.Reader +import qualified Data.Set as Set +import qualified Data.Text as T +import Data.Time +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 + +-------------------------------------------------------------------------------- +type Port = Int +type PrometheusOptions = AdapterOptions + +-------------------------------------------------------------------------------- +data RidleyMetric = ProcessMemory + | CPULoad + | GHCConc + -- ^ Tap into the metrics exposed by GHC.Conc + | Network + | Wai + | DiskUsage + -- ^ Gets stats about Disk usage (free space, etc) + deriving (Show, Ord, Eq, Enum, Bounded) + +-------------------------------------------------------------------------------- +data RidleyOptions = RidleyOptions { + _prometheusOptions :: PrometheusOptions + , _ridleyMetrics :: Set.Set RidleyMetric + , _katipScribes :: (Katip.Namespace, [(T.Text, Katip.Scribe)]) + , _katipSeverity :: Katip.Severity + , _dataRetentionPeriod :: Maybe NominalDiffTime + -- ^ How much to retain the data, in seconds. + -- Pass `Nothing` to not flush the metrics. + } + +makeLenses ''RidleyOptions + +-------------------------------------------------------------------------------- +defaultMetrics :: [RidleyMetric] +defaultMetrics = [minBound .. maxBound] + +-------------------------------------------------------------------------------- +newOptions :: [(T.Text, T.Text)] + -> [RidleyMetric] + -> RidleyOptions +newOptions appLabels metrics = RidleyOptions { + _prometheusOptions = defaultOptions (P.fromList appLabels) + , _ridleyMetrics = Set.fromList metrics + , _katipSeverity = InfoS + , _katipScribes = mempty + , _dataRetentionPeriod = Nothing + } + +-------------------------------------------------------------------------------- +data RidleyMetricHandler = forall c. RidleyMetricHandler { + metric :: c + , updateMetric :: c -> Bool -> IO () + , flush :: !Bool + -- ^Whether or net to flush this Metric + } + +-------------------------------------------------------------------------------- +runHandler :: RidleyMetricHandler -> IO () +runHandler (RidleyMetricHandler m u f) = u m f + +-------------------------------------------------------------------------------- +newtype RidleyT t a = Ridley { unRidley :: ReaderT RidleyOptions t a } + deriving (Functor, Applicative, Monad, MonadReader RidleyOptions, MonadIO, MonadTrans) + +type Ridley = RidleyT (P.RegistryT (KatipT IO)) + +data RidleyCtx = RidleyCtx { + _ridleyThreadId :: ThreadId + , _ridleyWaiMetrics :: Maybe WaiMetrics + } + +makeLenses ''RidleyCtx + +instance Katip Ridley where + getLogEnv = Ridley $ lift (lift getLogEnv) + +instance KatipContext Ridley where + getKatipContext = return mempty + getKatipNamespace = _logEnvApp <$> Ridley (lift $ lift (getLogEnv)) + +-------------------------------------------------------------------------------- +runRidley :: RidleyOptions -> LogEnv -> Ridley a -> IO a +runRidley opts le ridley = (runReaderT $ unKatipT $ P.evalRegistryT $ (runReaderT $ unRidley ridley) opts) le diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TupleSections #-} +module Main where + +import Control.Concurrent +import Control.Exception +import Control.Monad +import Data.ByteString.Lazy (ByteString) +import Data.List +import qualified Data.Map.Strict as Map +import Data.Maybe (isJust) +import Data.Monoid +import Data.Ord +import Data.String.Conv +import qualified Data.Text as T +import Lens.Micro +import qualified Network.HTTP.Client as HTTP +import System.IO.Unsafe (unsafePerformIO) +import System.Metrics as EKG +import System.Metrics.Prometheus.Registry +import System.Metrics.Prometheus.Ridley +import System.Metrics.Prometheus.Ridley.Types +import System.Remote.Monitoring.Prometheus (toPrometheusRegistry) +import Test.Tasty +import Test.Tasty.HUnit + +ridleyManager :: HTTP.Manager +ridleyManager = unsafePerformIO $ HTTP.newManager HTTP.defaultManagerSettings +{-# NOINLINE ridleyManager #-} + +-------------------------------------------------------------------------------- +main :: IO () +main = defaultMain tests + +-------------------------------------------------------------------------------- +tests :: TestTree +tests = testGroup "Tests" [unitTests] + +-------------------------------------------------------------------------------- +startRidleyWith :: Port -> [RidleyMetric] -> IO (IO Registry, RidleyCtx) +startRidleyWith port metrics = do + store <- EKG.newStore + let opts = newOptions [("service", "ridley-test")] metrics + ctx <- startRidleyWithStore opts ["metrics"] port store + return $ (toPrometheusRegistry store (opts ^. prometheusOptions), ctx) + +-------------------------------------------------------------------------------- +containsMetric :: Port -> T.Text -> Assertion +containsMetric port key = containsMetrics port [key] + +-------------------------------------------------------------------------------- +containsMetrics :: Port -> [T.Text] -> Assertion +containsMetrics port keys = go 3 + where + go !attempts = do + request <- HTTP.parseRequest $ "http://localhost:" <> show port <> "/metrics" + (response :: Either SomeException (HTTP.Response ByteString)) <- try (HTTP.httpLbs request ridleyManager) + case response of + Left e -> if attempts <= 0 then throwIO e else threadDelay (2 * 10^6) >> go (attempts - 1) + Right res -> do + let haystack = toS $ HTTP.responseBody res + forM_ keys $ \key -> do + assertBool (T.unpack $ "Key " <> key <> " was not found in \"" <> haystack <> "\"") (key `T.isInfixOf` haystack) + +-------------------------------------------------------------------------------- +unitTests :: TestTree +unitTests = testGroup "Unit tests" + [ withResource (startRidleyWith 8700 []) (\(_, ctx) -> killThread (ctx ^. ridleyThreadId)) $ \setupFn -> do + testCase "Starting Ridley with empty metrics yield an empty store" $ do + (getRegistry, _) <- setupFn + r <- getRegistry >>= sample + Map.null (unRegistrySample r) @?= True + + , withResource (startRidleyWith 8701 [Wai]) (\(_, ctx) -> killThread (ctx ^. ridleyThreadId)) $ \setupFn -> do + testCase "Starting Ridley with wai metrics populates the store & ctx" $ do + (getRegistry, ctx) <- setupFn + isJust (ctx ^. ridleyWaiMetrics) @?= True + r <- getRegistry >>= sample + Map.null (unRegistrySample r) @?= False + containsMetrics 8701 [ "# TYPE wai_request_count counter" + , "# TYPE wai_response_status_1xx counter" + , "# TYPE wai_response_status_2xx counter" + , "# TYPE wai_response_status_3xx counter" + , "# TYPE wai_response_status_4xx counter" + , "# TYPE wai_response_status_5xx counter" + ] + + , withResource (startRidleyWith 8702 [Network]) (\(_, ctx) -> killThread (ctx ^. ridleyThreadId)) $ \setupFn -> do + testCase "Starting Ridley with network metrics populates the store" $ do + (getRegistry, _) <- setupFn + containsMetrics 8702 [ "# TYPE network_receive_bytes gauge" + , "# TYPE network_receive_drop gauge" + , "# TYPE network_receive_errs gauge" + , "# TYPE network_receive_multicast gauge" + , "# TYPE network_receive_packets gauge" + , "# TYPE network_transmit_bytes gauge" + , "# TYPE network_transmit_errs gauge" + , "# TYPE network_transmit_multicast gauge" + , "# TYPE network_transmit_packets gauge" + ] + + , withResource (startRidleyWith 8703 [ProcessMemory]) (\(_, ctx) -> killThread (ctx ^. ridleyThreadId)) $ \setupFn -> do + testCase "Starting Ridley with process memory metrics populates the store" $ do + (getRegistry, _) <- setupFn + containsMetrics 8703 ["# TYPE process_memory_kb gauge"] + + , withResource (startRidleyWith 8706 [DiskUsage]) (\(_, ctx) -> killThread (ctx ^. ridleyThreadId)) $ \setupFn -> do + testCase "Starting Ridley with Disk Usage metrics populates the store" $ do + (getRegistry, _) <- setupFn + containsMetrics 8706 [ "# TYPE disk_free_bytes_blocks gauge" + , "# TYPE disk_used_bytes_blocks gauge" + ] + + , withResource (startRidleyWith 8704 [CPULoad]) (\(_, ctx) -> killThread (ctx ^. ridleyThreadId)) $ \setupFn -> do + testCase "Starting Ridley with CPU Load metrics populates the store" $ do + (getRegistry, _) <- setupFn + containsMetrics 8704 [ "# TYPE cpu_load1 gauge" + , "# TYPE cpu_load15 gauge" + , "# TYPE cpu_load5 gauge" + ] + + + ]