110 lines
3.0 KiB
Haskell
110 lines
3.0 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module HomeAssistant.Runtime.Metrics
|
|
( DsType (..)
|
|
, DsSpec (..)
|
|
, dsTypeOf
|
|
, sanitizeName
|
|
, buildSchema
|
|
, buildCreateArgs
|
|
, buildUpdateArgs
|
|
, ensureRrd
|
|
, sampleAndUpdate
|
|
, metricsAction
|
|
) where
|
|
|
|
import Control.Concurrent (threadDelay)
|
|
import Control.Monad (forever, unless)
|
|
import Data.Int (Int64)
|
|
import Data.List (intercalate, sortBy)
|
|
import Data.Ord (comparing)
|
|
import Data.Text (Text)
|
|
import Data.Void (Void)
|
|
import qualified Data.Text as T
|
|
import qualified Data.HashMap.Strict as HM
|
|
import qualified System.Metrics as M (Value (..), Sample, Store, sampleAll)
|
|
import System.Directory (doesFileExist)
|
|
import System.Process (callProcess)
|
|
|
|
data DsType = Derive | Gauge
|
|
deriving (Eq, Show)
|
|
|
|
data DsSpec = DsSpec
|
|
{ dsEkgName :: Text
|
|
, dsName :: String
|
|
, dsType :: DsType
|
|
}
|
|
deriving (Eq, Show)
|
|
|
|
dsTypeOf :: M.Value -> Maybe DsType
|
|
dsTypeOf (M.Counter _) = Just Derive
|
|
dsTypeOf (M.Gauge _) = Just Gauge
|
|
dsTypeOf _ = Nothing
|
|
|
|
sanitizeName :: Text -> String
|
|
sanitizeName = T.unpack . T.replace "." "_"
|
|
|
|
buildSchema :: M.Sample -> [DsSpec]
|
|
buildSchema sample =
|
|
sortBy (comparing dsName)
|
|
[ DsSpec ekgName (sanitizeName ekgName) dt
|
|
| (ekgName, val) <- HM.toList sample
|
|
, Just dt <- [dsTypeOf val]
|
|
]
|
|
|
|
buildCreateArgs :: FilePath -> Int -> [(String, DsType)] -> [String]
|
|
buildCreateArgs path step specs =
|
|
["create", path, "--step", show step]
|
|
++ concatMap dsArg specs
|
|
++ rras
|
|
where
|
|
dsArg (name, Derive) = ["DS:" ++ name ++ ":DERIVE:20:0:U"]
|
|
dsArg (name, Gauge) = ["DS:" ++ name ++ ":GAUGE:20:0:U"]
|
|
rras =
|
|
[ "RRA:AVERAGE:0.5:1:6000"
|
|
, "RRA:MAX:0.5:1:6000"
|
|
, "RRA:AVERAGE:0.5:360:1680"
|
|
, "RRA:MAX:0.5:360:1680"
|
|
]
|
|
|
|
buildUpdateArgs :: FilePath -> [String] -> [Maybe Int64] -> [String]
|
|
buildUpdateArgs path names values =
|
|
[ "update"
|
|
, path
|
|
, "--template"
|
|
, intercalate ":" names
|
|
, "N:" ++ intercalate ":" (map renderValue values)
|
|
]
|
|
where
|
|
renderValue Nothing = "U"
|
|
renderValue (Just n) = show n
|
|
|
|
lookupValue :: M.Sample -> Text -> Maybe Int64
|
|
lookupValue sample name = case HM.lookup name sample of
|
|
Just (M.Counter n) -> Just n
|
|
Just (M.Gauge n) -> Just n
|
|
_ -> Nothing
|
|
|
|
ensureRrd :: FilePath -> FilePath -> [DsSpec] -> IO ()
|
|
ensureRrd rrdtool rrdPath schema = do
|
|
exists <- doesFileExist rrdPath
|
|
unless exists $
|
|
callProcess rrdtool (buildCreateArgs rrdPath 10 (map toPair schema))
|
|
where
|
|
toPair s = (dsName s, dsType s)
|
|
|
|
sampleAndUpdate :: M.Store -> FilePath -> FilePath -> [DsSpec] -> IO ()
|
|
sampleAndUpdate store rrdtool rrdPath schema = do
|
|
sample <- M.sampleAll store
|
|
let names = map dsName schema
|
|
values = map (lookupValue sample . dsEkgName) schema
|
|
callProcess rrdtool (buildUpdateArgs rrdPath names values)
|
|
|
|
metricsAction :: M.Store -> FilePath -> FilePath -> IO Void
|
|
metricsAction store rrdPath rrdtool = do
|
|
schema <- buildSchema <$> M.sampleAll store
|
|
ensureRrd rrdtool rrdPath schema
|
|
forever $ do
|
|
sampleAndUpdate store rrdtool rrdPath schema
|
|
threadDelay 10000000
|