0.2.5 initial commit

Makefile incomplete

agent/src/Lib/External/Metrics/Df.hs

@@ -0,0 +1,40 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE RecordWildCards  #-}
+
+module Lib.External.Metrics.Df where
+
+import           Startlude
+
+import           System.Process
+
+import           Lib.Error
+import           Lib.External.Metrics.Types
+
+-- Disk :: Size Used Avail Use%
+data DfMetrics = DfMetrics
+    { metricDiskSize           :: Maybe Gigabytes
+    , metricDiskUsed           :: Maybe Gigabytes
+    , metricDiskAvailable      :: Maybe Gigabytes
+    , metricDiskUsedPercentage :: Maybe Percentage
+    } deriving (Eq, Show)
+
+getDfMetrics :: MonadIO m => S9ErrT m DfMetrics
+getDfMetrics = fmap parseDf runDf
+
+runDf :: MonadIO m => S9ErrT m Text
+runDf = do
+    (_, output, err') <- liftIO $ readProcessWithExitCode "df" ["-a", "/"] ""
+    unless (null err') $ throwE . MetricE $ "df command failed with " <> toS err'
+    pure $ toS output
+
+parseDf :: Text -> DfMetrics
+parseDf t =
+    let dataLine                 = words <$> lines t `atMay` 1
+        metricDiskSize           = fmap oneKBlocksToGigs . readMaybe =<< (`atMay` 1) =<< dataLine
+        metricDiskUsed           = fmap oneKBlocksToGigs . readMaybe =<< (`atMay` 2) =<< dataLine
+        metricDiskAvailable      = fmap oneKBlocksToGigs . readMaybe =<< (`atMay` 3) =<< dataLine
+        metricDiskUsedPercentage = readMaybe =<< (`atMay` 4) =<< dataLine
+    in  DfMetrics { .. }
+
+oneKBlocksToGigs :: Double -> Gigabytes
+oneKBlocksToGigs s = Gigabytes $ s / 1e6

agent/src/Lib/External/Metrics/Iotop.hs

@@ -0,0 +1,58 @@
+{-# LANGUAGE FlexibleContexts #-}
+
+module Lib.External.Metrics.Iotop where
+
+import           Startlude
+
+import qualified Data.HashMap.Strict           as HM
+import           System.Process
+
+import           Lib.Error
+import           Lib.External.Metrics.Types
+import           Lib.External.Util
+import           Util.Text
+
+data IotopMetrics = IotopMetrics
+    { metricCurrentRead  :: Maybe BytesPerSecond
+    , metricCurrentWrite :: Maybe BytesPerSecond
+    , metricTotalRead    :: Maybe BytesPerSecond
+    , metricTotalWrite   :: Maybe BytesPerSecond
+    } deriving (Eq, Show)
+
+getIotopMetrics :: MonadIO m => S9ErrT m IotopMetrics
+getIotopMetrics = fmap parseIotop runIotop
+
+runIotop :: MonadIO m => S9ErrT m Text
+runIotop = do
+    (_, output, err') <- liftIO $ readProcessWithExitCode "iotop" ["-bn1"] ""
+    unless (null err') $ throwE . MetricE $ "iotop command failed with " <> toS err'
+    pure $ toS output
+
+parseIotop :: Text -> IotopMetrics
+parseIotop t = IotopMetrics { metricCurrentRead  = BytesPerSecond . fst <$> current
+                            , metricCurrentWrite = BytesPerSecond . snd <$> current
+                            , metricTotalRead    = BytesPerSecond . fst <$> total
+                            , metricTotalWrite   = BytesPerSecond . snd <$> total
+                            }
+    where
+        iotopLines = lines t
+        current    = getHeaderAggregates currentHeader iotopLines
+        total      = getHeaderAggregates totalHeader iotopLines
+
+currentHeader :: Text
+currentHeader = "Current"
+
+totalHeader :: Text
+totalHeader = "Total"
+
+getHeaderAggregates :: Text -> [Text] -> Maybe (Double, Double)
+getHeaderAggregates header iotopLines = do
+    actualLine <- getLineByHeader header iotopLines
+    let stats = HM.fromList . getStats $ actualLine
+    r <- HM.lookup "READ" stats
+    w <- HM.lookup "WRITE" stats
+    pure (r, w)
+getStats :: Text -> [(Text, Double)]
+getStats = mapMaybe (parseToPair readMaybe . words . gsub ":" "") . getMatches statRegex
+    where statRegex = "([\x21-\x7E]+)[ ]{0,}:[ ]{1,}([\x21-\x7E]+)"
+

agent/src/Lib/External/Metrics/ProcDev.hs

@@ -0,0 +1,118 @@
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE RecordWildCards  #-}
+{-# LANGUAGE TupleSections  #-}
+
+module Lib.External.Metrics.ProcDev where
+
+import           Startlude
+
+import           Lib.External.Util
+import           Lib.External.Metrics.Types
+import           Lib.Error
+import           Util.Text
+
+data ProcDevMetrics = ProcDevMetrics
+    { metricRBytesPerSecond    :: Maybe BytesPerSecond
+    , metricRPacketsPerSecond  :: Maybe BytesPerSecond
+    , metricRErrorsPerSecond   :: Maybe BytesPerSecond
+    , metricTBytesPerSecond    :: Maybe BytesPerSecond
+    , metricTPacketsPerSecond  :: Maybe BytesPerSecond
+    , metricTErrorsPerSecond   :: Maybe BytesPerSecond
+    , metricFrom :: UTCTime -- time range across which the above rates were calculated
+    , metricTo   :: UTCTime
+    } deriving Show
+
+getProcDevMetrics :: MonadIO m
+                  => (UTCTime, ProcDevMomentStats)
+                  -> S9ErrT m (UTCTime, ProcDevMomentStats, ProcDevMetrics)
+getProcDevMetrics oldMomentStats = do
+    newMomentStats@(newTime, newStats) <- newProcDevMomentStats
+    let metrics = computeProcDevMetrics oldMomentStats newMomentStats
+    pure (newTime, newStats, metrics)
+
+newProcDevMomentStats :: MonadIO m => S9ErrT m (UTCTime, ProcDevMomentStats)
+newProcDevMomentStats = do
+    res <- runProcDev
+    now <- liftIO getCurrentTime
+    pure $ parseProcDev now res
+
+runProcDev :: MonadIO m => S9ErrT m Text
+runProcDev = do
+    eOutput <- liftIO . try @SomeException $ readFile "/proc/net/dev"
+    case eOutput of
+        Left  e      -> throwE . MetricE $ "ProcDev proc file could not be read with " <> show e
+        Right output -> pure . toS $ output
+
+parseProcDev :: UTCTime -> Text -> (UTCTime, ProcDevMomentStats)
+parseProcDev now t = do
+    (now, ) . fold . foreach filteredLines $ \l ->
+        let ws              = words l
+            procDevRBytes   = ws `atMay` 1 >>= readMaybe
+            procDevRPackets = ws `atMay` 2 >>= readMaybe
+            procDevRErrors  = ws `atMay` 3 >>= readMaybe
+
+            procDevTBytes   = ws `atMay` 9 >>= readMaybe
+            procDevTPackets = ws `atMay` 10 >>= readMaybe
+            procDevTErrors  = ws `atMay` 11 >>= readMaybe
+        in  ProcDevMomentStats { .. }
+    where
+        wlanRegex     = "^[ ]{0,}wlan0"
+        ethRegex      = "^[ ]{0,}eth0"
+
+        isWlan        = containsMatch wlanRegex
+        isEth         = containsMatch ethRegex
+
+        filteredLines = filter (liftA2 (||) isWlan isEth) $ lines t
+
+computeProcDevMetrics :: (UTCTime, ProcDevMomentStats) -> (UTCTime, ProcDevMomentStats) -> ProcDevMetrics
+computeProcDevMetrics (fromTime, fromStats) (toTime, toStats) =
+    let metricRBytesPerSecond   = getMetric (procDevRBytes fromStats, fromTime) (procDevRBytes toStats, toTime)
+        metricRPacketsPerSecond = getMetric (procDevRPackets fromStats, fromTime) (procDevRPackets toStats, toTime)
+        metricRErrorsPerSecond  = getMetric (procDevRErrors fromStats, fromTime) (procDevRErrors toStats, toTime)
+        metricTBytesPerSecond   = getMetric (procDevTBytes fromStats, fromTime) (procDevTBytes toStats, toTime)
+        metricTPacketsPerSecond = getMetric (procDevTPackets fromStats, fromTime) (procDevTPackets toStats, toTime)
+        metricTErrorsPerSecond  = getMetric (procDevTErrors fromStats, fromTime) (procDevTErrors toStats, toTime)
+        metricFrom              = fromTime
+        metricTo                = toTime
+    in  ProcDevMetrics { .. }
+
+getMetric :: (Maybe Integer, UTCTime) -> (Maybe Integer, UTCTime) -> Maybe BytesPerSecond
+getMetric (Just fromMetric, fromTime) (Just toMetric, toTime) = Just . BytesPerSecond $ if timeDiff == 0
+    then 0
+    else truncateTo @Double 10 . fromRational $ (fromIntegral $ toMetric - fromMetric) / (toRational timeDiff)
+    where timeDiff = diffUTCTime toTime fromTime
+getMetric _ _ = Nothing
+
+data ProcDevMomentStats = ProcDevMomentStats
+    { procDevRBytes    :: Maybe Integer
+    , procDevRPackets  :: Maybe Integer
+    , procDevRErrors   :: Maybe Integer
+    , procDevTBytes    :: Maybe Integer
+    , procDevTPackets  :: Maybe Integer
+    , procDevTErrors   :: Maybe Integer
+    } deriving (Eq, Show)
+
+(?+?) :: Num a => Maybe a -> Maybe a -> Maybe a
+(?+?) Nothing Nothing = Nothing
+(?+?) m1      m2      = Just $ fromMaybe 0 m1 + fromMaybe 0 m2
+
+(?-?) :: Num a => Maybe a -> Maybe a -> Maybe a
+(?-?) Nothing Nothing = Nothing
+(?-?) m1      m2      = Just $ fromMaybe 0 m1 - fromMaybe 0 m2
+
+instance Semigroup ProcDevMomentStats where
+    m1 <> m2 = ProcDevMomentStats rBytes rPackets rErrors tBytes tPackets tErrors
+        where
+            rBytes   = procDevRBytes m1 ?+? procDevRBytes m2
+            rPackets = procDevRPackets m1 ?+? procDevRPackets m2
+            rErrors  = procDevRErrors m1 ?+? procDevRErrors m2
+            tBytes   = procDevTBytes m1 ?+? procDevTBytes m2
+            tPackets = procDevTPackets m1 ?+? procDevTPackets m2
+            tErrors  = procDevTErrors m1 ?+? procDevTErrors m2
+instance Monoid ProcDevMomentStats where
+    mempty = ProcDevMomentStats (Just 0) (Just 0) (Just 0) (Just 0) (Just 0) (Just 0)
+
+getDefaultProcDevMetrics :: MonadIO m => m ProcDevMetrics
+getDefaultProcDevMetrics = do
+    now <- liftIO getCurrentTime
+    pure $ ProcDevMetrics Nothing Nothing Nothing Nothing Nothing Nothing now now

agent/src/Lib/External/Metrics/Temperature.hs

@@ -0,0 +1,22 @@
+module Lib.External.Metrics.Temperature where
+
+import           Startlude
+
+import qualified Data.Attoparsec.Text          as A
+import qualified Data.Text                     as T
+import           Lib.External.Metrics.Types
+import           System.Process.Text
+
+-- Pi4 Specific
+getTemperature :: MonadIO m => m (Maybe Celsius)
+getTemperature = liftIO $ do
+    (ec, tempString, errlog) <- readProcessWithExitCode "/opt/vc/bin/vcgencmd" ["measure_temp"] ""
+    unless (T.null errlog) $ putStrLn errlog
+    case ec of
+        ExitFailure _ -> pure Nothing
+        ExitSuccess   -> case A.parse tempParser tempString of
+            A.Done _ c -> pure $ Just c
+            _          -> pure Nothing
+
+tempParser :: A.Parser Celsius
+tempParser = A.asciiCI "temp=" *> fmap Celsius A.double <* "'C" <* A.endOfLine

agent/src/Lib/External/Metrics/Top.hs

@@ -0,0 +1,114 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE QuasiQuotes      #-}
+{-# LANGUAGE RecordWildCards  #-}
+
+module Lib.External.Metrics.Top where
+
+import           Startlude
+
+import qualified Data.HashMap.Strict           as HM
+import           System.Process
+
+import           Lib.Error
+import           Lib.External.Metrics.Types
+import           Lib.External.Util
+import           Util.Text
+
+data TopMetrics = TopMetrics
+    { metricMemPercentageUsed :: Maybe Percentage
+    , metricMemFree           :: Maybe MebiBytes
+    , metricMemUsed           :: Maybe MebiBytes
+
+    , metricSwapTotal         :: Maybe MebiBytes
+    , metricSwapUsed          :: Maybe MebiBytes
+
+    , metricCpuIdle           :: Maybe Percentage
+    , metricCpuUserSpace      :: Maybe Percentage
+    , metricWait              :: Maybe Percentage
+    , metricCpuPercentageUsed :: Maybe Percentage
+    } deriving (Eq, Show)
+
+getTopMetrics :: MonadIO m => S9ErrT m TopMetrics
+getTopMetrics = fmap parseTop runTop
+
+runTop :: MonadIO m => S9ErrT m Text
+runTop = do
+    (_, output, err') <- liftIO $ readProcessWithExitCode "top" ["-bn1"] ""
+    unless (null err') $ throwE . MetricE $ "top command failed with " <> toS err'
+    pure $ toS output
+
+parseTop :: Text -> TopMetrics
+parseTop t = TopMetrics { metricMemPercentageUsed = getMemPercentageUsed <$> mem
+                        , metricMemFree           = MebiBytes . memFree <$> mem
+                        , metricMemUsed           = MebiBytes . memUsed <$> mem
+                        , metricSwapTotal         = MebiBytes . memTotal <$> swapS
+                        , metricSwapUsed          = MebiBytes . memUsed <$> swapS
+                        , metricCpuIdle           = cpuId <$> cpu
+                        , metricCpuUserSpace      = cpuUs <$> cpu
+                        , metricWait              = cpuWa <$> cpu
+                        , metricCpuPercentageUsed = getCpuPercentageUsed <$> cpu
+                        }
+    where
+        topLines = lines t
+        cpu      = getCpuAggregates topLines
+        mem      = getMemAggregates memHeader topLines
+        swapS    = getMemAggregates swapHeader topLines
+
+memHeader :: Text
+memHeader = "MiB Mem"
+
+swapHeader :: Text
+swapHeader = "MiB Swap"
+
+data TopMemAggregates = TopMemAggregates
+    { memTotal :: Double
+    , memFree  :: Double
+    , memUsed  :: Double
+    } deriving (Eq, Show)
+
+cpuHeader :: Text
+cpuHeader = "%Cpu(s)"
+
+data TopCpuAggregates = TopCpuAggregates
+    { cpuUs :: Percentage
+    , cpuSy :: Percentage
+    , cpuNi :: Percentage
+    , cpuId :: Percentage
+    , cpuWa :: Percentage
+    , cpuHi :: Percentage
+    , cpuSi :: Percentage
+    , cpuSt :: Percentage
+    } deriving (Eq, Show)
+
+getMemAggregates :: Text -> [Text] -> Maybe TopMemAggregates
+getMemAggregates header topRes = do
+    memLine <- getLineByHeader header topRes
+    let stats = HM.fromList $ getStats readMaybe memLine
+    memTotal <- HM.lookup "total" stats
+    memFree  <- HM.lookup "free" stats
+    memUsed  <- HM.lookup "used" stats
+    pure TopMemAggregates { .. }
+
+getCpuAggregates :: [Text] -> Maybe TopCpuAggregates
+getCpuAggregates topRes = do
+    memLine <- getLineByHeader cpuHeader topRes
+    let stats = HM.fromList $ getStats (mkPercentage <=< readMaybe) memLine
+    cpuUs <- HM.lookup "us" stats
+    cpuSy <- HM.lookup "sy" stats
+    cpuNi <- HM.lookup "ni" stats
+    cpuId <- HM.lookup "id" stats
+    cpuWa <- HM.lookup "wa" stats
+    cpuHi <- HM.lookup "hi" stats
+    cpuSi <- HM.lookup "si" stats
+    cpuSt <- HM.lookup "st" stats
+    pure TopCpuAggregates { .. }
+
+getCpuPercentageUsed :: TopCpuAggregates -> Percentage
+getCpuPercentageUsed TopCpuAggregates {..} = Percentage (100 - unPercent cpuId)
+
+getMemPercentageUsed :: TopMemAggregates -> Percentage
+getMemPercentageUsed TopMemAggregates {..} = Percentage . truncateTo @Double 10 . (* 100) $ memUsed / memTotal
+
+getStats :: (Text -> Maybe a) -> Text -> [(Text, a)]
+getStats parseData = mapMaybe (parseToPair parseData) . fmap (words . toS) . getMatches statRegex . toS
+    where statRegex = "[0-9]+(.[0-9][0-9]?)? ([\x21-\x7E][^(,|.)]+)"

agent/src/Lib/External/Metrics/Types.hs

@@ -0,0 +1,89 @@
+module Lib.External.Metrics.Types where
+
+import           Startlude
+
+import           Data.Aeson
+import qualified GHC.Read                       ( Read(..)
+                                                , readsPrec
+                                                )
+import qualified GHC.Show                       ( Show(..) )
+
+import           Lib.External.Util
+
+class Metric a where
+    mUnit :: a -> Text
+    mValue :: a -> Double
+
+toMetricJson :: Metric a => a -> Value
+toMetricJson x = object ["value" .= truncateToS 2 (mValue x), "unit" .= mUnit x]
+toMetricShow :: Metric a => a -> String
+toMetricShow a = show (mValue a) <> " " <> toS (mUnit a)
+
+newtype Percentage = Percentage { unPercent :: Double } deriving (Eq)
+instance Metric Percentage where
+    mValue (Percentage p) = p
+    mUnit _ = "%"
+instance ToJSON Percentage where
+    toJSON = toMetricJson
+instance Show Percentage where
+    show = toMetricShow
+instance Read Percentage where
+    readsPrec _ s = case reverse s of
+        '%' : rest -> case GHC.Read.readsPrec 0 (reverse rest) of
+            [(result, "")] -> case mkPercentage result of
+                Just p -> [(p, "")]
+                _      -> []
+            _ -> []
+        _ -> []
+
+mkPercentage :: Double -> Maybe Percentage
+mkPercentage s | 0 <= s && s <= 100 = Just $ Percentage s
+               | otherwise          = Nothing
+
+newtype MebiBytes = MebiBytes Double
+    deriving stock Eq
+    deriving newtype Num
+
+instance Metric MebiBytes where
+    mValue (MebiBytes p) = p
+    mUnit _ = "MiB"
+instance ToJSON MebiBytes where
+    toJSON = toMetricJson
+instance Show MebiBytes where
+    show = toMetricShow
+
+newtype BytesPerSecond = BytesPerSecond Double
+    deriving stock Eq
+    deriving newtype Num
+
+instance Metric BytesPerSecond where
+    mValue (BytesPerSecond p) = p
+    mUnit _ = "B/s"
+instance ToJSON BytesPerSecond where
+    toJSON = toMetricJson
+instance Show BytesPerSecond where
+    show = toMetricShow
+
+newtype Gigabytes = Gigabytes Double
+    deriving stock Eq
+    deriving newtype Num
+
+instance Metric Gigabytes where
+    mValue (Gigabytes p) = p
+    mUnit _ = "Gb"
+instance ToJSON Gigabytes where
+    toJSON = toMetricJson
+instance Show Gigabytes where
+    show = toMetricShow
+
+newtype Celsius = Celsius { unCelsius :: Double }
+    deriving stock Eq
+    deriving newtype Num
+
+instance Metric Celsius where
+    mValue (Celsius c) = c
+    mUnit _ = "°C"
+instance ToJSON Celsius where
+    toJSON = toMetricJson
+instance Show Celsius where
+    show = toMetricShow