ridley (empty) → 0.3.0.0
raw patch · 19 files changed
+1364/−0 lines, 19 filesdep +asyncdep +basedep +bytestringsetup-changed
Dependencies added: async, base, bytestring, containers, ekg-core, ekg-prometheus-adapter, http-client, inline-c, katip, microlens, microlens-th, mtl, process, prometheus, raw-strings-qq, ridley, shelly, string-conv, tasty, tasty-hunit, tasty-quickcheck, template-haskell, text, time, transformers, unix, vector, wai-middleware-metrics
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- cbits/helpers.c +15/−0
- include/helpers.h +34/−0
- ridley.cabal +91/−0
- src/System/Metrics/Prometheus/Ridley.hs +173/−0
- src/System/Metrics/Prometheus/Ridley/Metrics/CPU.hs +10/−0
- src/System/Metrics/Prometheus/Ridley/Metrics/CPU/Darwin.c +7/−0
- src/System/Metrics/Prometheus/Ridley/Metrics/CPU/Darwin.hs +44/−0
- src/System/Metrics/Prometheus/Ridley/Metrics/CPU/Unix.hs +40/−0
- src/System/Metrics/Prometheus/Ridley/Metrics/DiskUsage.hs +101/−0
- src/System/Metrics/Prometheus/Ridley/Metrics/Memory.hs +39/−0
- src/System/Metrics/Prometheus/Ridley/Metrics/Network.hs +17/−0
- src/System/Metrics/Prometheus/Ridley/Metrics/Network/Darwin.c +104/−0
- src/System/Metrics/Prometheus/Ridley/Metrics/Network/Darwin.hs +191/−0
- src/System/Metrics/Prometheus/Ridley/Metrics/Network/Types.hsc +125/−0
- src/System/Metrics/Prometheus/Ridley/Metrics/Network/Unix.hs +94/−0
- src/System/Metrics/Prometheus/Ridley/Types.hs +122/−0
- test/Spec.hs +125/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cbits/helpers.c view
@@ -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
+ include/helpers.h view
@@ -0,0 +1,34 @@++#ifndef RIDLEY_HELPERS__+#define RIDLEY_HELPERS__++#ifdef __APPLE__++// Apple/Darwin specific code++#include <stdlib.h>++// A subset of if_data, as defined in <net/if_var.h>+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
+ ridley.cabal view
@@ -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
+ src/System/Metrics/Prometheus/Ridley.hs view
@@ -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
+ src/System/Metrics/Prometheus/Ridley/Metrics/CPU.hs view
@@ -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
+ src/System/Metrics/Prometheus/Ridley/Metrics/CPU/Darwin.c view
@@ -0,0 +1,7 @@++#include <stdlib.h>++int inline_c_System_Metrics_Prometheus_Ridley_Metrics_CPU_Darwin_0_fe4c7ffe3048a794673ef39573f91525af37ea82(double * v_inline_c_0) {+return ( getloadavg(v_inline_c_0, 3) );+}+
+ src/System/Metrics/Prometheus/Ridley/Metrics/CPU/Darwin.hs view
@@ -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 "<stdlib.h>"++--------------------------------------------------------------------------------+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+ }
+ src/System/Metrics/Prometheus/Ridley/Metrics/CPU/Unix.hs view
@@ -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+ }
+ src/System/Metrics/Prometheus/Ridley/Metrics/DiskUsage.hs view
@@ -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
+ src/System/Metrics/Prometheus/Ridley/Metrics/Memory.hs view
@@ -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+ }
+ src/System/Metrics/Prometheus/Ridley/Metrics/Network.hs view
@@ -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
+ src/System/Metrics/Prometheus/Ridley/Metrics/Network/Darwin.c view
@@ -0,0 +1,104 @@++#include <sys/types.h>++#include <sys/socket.h>++#include <ifaddrs.h>++#include <regex.h>++#include <stddef.h>++#include "helpers.h"++#include <stdlib.h>++#include <string.h>++#include <net/if.h>+++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;+ +}+
+ src/System/Metrics/Prometheus/Ridley/Metrics/Network/Darwin.hs view
@@ -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 "<sys/types.h>"+C.include "<sys/socket.h>"+C.include "<ifaddrs.h>"+C.include "<regex.h>"+C.include "<stddef.h>"+C.include "helpers.h"+C.include "<stdlib.h>"+C.include "<string.h>"+C.include "<net/if.h>"+++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
+ src/System/Metrics/Prometheus/Ridley/Metrics/Network/Types.hsc view
@@ -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+ }
+ src/System/Metrics/Prometheus/Ridley/Metrics/Network/Unix.hs view
@@ -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
+ src/System/Metrics/Prometheus/Ridley/Types.hs view
@@ -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
+ test/Spec.hs view
@@ -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"+ ]+++ ]