{-# 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