home-assistant-controller/src/HomeAssistant/Runtime/Graphing.hs

{-# LANGUAGE OverloadedStrings #-}

module HomeAssistant.Runtime.Graphing
  ( Range (..)
  , parseRange
  , rangeStart
  , Series (..)
  , GraphSpec (..)
  , graphs
  , lookupGraph
  , parseNameParam
  , buildGraphArgs
  , readProcessBytes
  , Graph(..)
  , renderGraph
  ) where

import Control.Exception (evaluate)
import Control.Monad.IO.Class (liftIO, MonadIO)
import qualified Data.ByteString as BS
import Data.Text (Text)
import qualified Data.Text as T
import System.Exit (ExitCode (..))
import System.IO (hGetContents)
import System.Process (CreateProcess (..), StdStream (..), proc, waitForProcess, withCreateProcess)
import Servant.API (FromHttpApiData (..), ToHttpApiData (..))

data Range = TenMinutes | OneHour | OneDay | OneWeek | OneMonth
  deriving (Eq, Show, Bounded, Enum)

rangeSuffix :: Range -> String
rangeSuffix TenMinutes = "10m"
rangeSuffix OneHour     = "1h"
rangeSuffix OneDay      = "24h"
rangeSuffix OneWeek     = "7d"
rangeSuffix OneMonth    = "30d"

parseRange :: Text -> Maybe Range
parseRange t = lookup t [(T.pack (rangeSuffix r), r) | r <- [minBound .. maxBound]]

instance ToHttpApiData Range where
  toQueryParam = T.pack . rangeSuffix

instance FromHttpApiData Range where
  parseQueryParam x = maybe (Left ("Could not parse '" <> x <> "' as Range")) Right $ parseRange x

rangeStart :: Range -> String
rangeStart r = "end-" ++ rangeSuffix r

data CF = Average | Minimum | Maximum | Last
  deriving (Eq, Show)

data Source = Source
  { srcDs :: String
  , srcCF :: CF
  }
  deriving (Eq, Show)

data Transform
  = Identity
  | Multiply Double
  deriving (Eq, Show)

data Series = Series
  { serSource    :: Source
  , serTransform :: Transform
  , serAlias     :: String
  , serColor     :: String
  , serLabel     :: String
  }
  deriving (Eq, Show)

data Plot
  = Line Int Series
  | Area Series
  deriving (Eq, Show)

data GraphSpec = GraphSpec
  { gsName  :: Text
  , gsTitle :: String
  , gsPlots :: [Plot]
  , gsIdentifier :: Graph
  }
  deriving (Eq, Show)

average :: String -> Source
average ds = Source ds Average

maximumCF :: String -> Source
maximumCF ds = Source ds Maximum

line :: String -> String -> Source -> Plot
line alias color source =
  Line 2 Series
    { serSource = source
    , serTransform = Identity
    , serAlias = alias
    , serColor = color
    , serLabel = alias
    }

area :: String -> String -> Source -> Plot
area alias color source =
  Area Series
    { serSource = source
    , serTransform = Identity
    , serAlias = alias
    , serColor = color
    , serLabel = alias
    }

ratelimitGraph :: GraphSpec
ratelimitGraph =
  GraphSpec
    { gsName = "ratelimit"
    , gsTitle = "Rate limiting"
    , gsPlots =
        [ Line 2 Series
            { serSource = Source "ratelimit_retry" Average
            , serTransform = Multiply 60
            , serAlias = "retry"
            , serColor = "#0066cc"
            , serLabel = "Requests retried/min"
            }
        , Line 2 Series
            { serSource = Source "ratelimit_exhausted" Average
            , serTransform = Multiply 60
            , serAlias = "exhaust"
            , serColor = "#cc0000"
            , serLabel = "Requests exhausted/min"
            }
        ]
    , gsIdentifier = RateLimit
    }

trafficGraph :: GraphSpec
trafficGraph =
  GraphSpec
    { gsName = "traffic"
    , gsTitle = "Hass triggers in / services out"
    , gsPlots =
        [ Line 2 Series
            { serSource = Source "hass_trigger_in" Average
            , serTransform = Multiply 60
            , serAlias = "in"
            , serColor = "#0066cc"
            , serLabel = "Triggers in/min"
            }
        , Line 2 Series
            { serSource = Source "hass_service_out" Average
            , serTransform = Multiply 60
            , serAlias = "out"
            , serColor = "#cc0000"
            , serLabel = "Service calls out/min"
            }
        ]
    , gsIdentifier = Traffic
    }

memoryGraph :: GraphSpec
memoryGraph =
  GraphSpec
    "memory"
    "Memory use"
    [ area "live" "#99ccff" (average "rts_gc_current__a7a")
    , line "peak" "#cc0000" (maximumCF "rts_gc_current__a7a")
    ]
    Memory

graphs :: [GraphSpec]
graphs = [memoryGraph, ratelimitGraph, trafficGraph]

-- XXX: Proper lookup..?
lookupGraph :: [GraphSpec] -> Graph -> Maybe GraphSpec
lookupGraph specs graphMode = case [g | g <- specs, gsIdentifier g == graphMode] of
  (g : _) -> Just g
  []      -> Nothing

parseNameParam :: [GraphSpec] -> Text -> Maybe GraphSpec
parseNameParam specs t = rightToMaybe (parseQueryParam t) >>= lookupGraph specs
  where
    rightToMaybe = either (const Nothing) Just

cfName :: CF -> String
cfName = \case
  Average -> "AVERAGE"
  Minimum -> "MIN"
  Maximum -> "MAX"
  Last    -> "LAST"

defArgs :: FilePath -> Series -> [String]
defArgs rrdPath series =
  [ "DEF:" ++ rawF ++ "=" ++ rrdPath ++ ":"
      ++ srcDs source ++ ":" ++ cfName (srcCF source)
  ]
    ++ transformArgs
  where
    source = serSource series
    alias = serAlias series
    rawF = alias ++ "_raw"

    transformArgs = case serTransform series of
      Identity ->
        [ "CDEF:" ++ alias ++ "=" ++ rawF ]

      Multiply factor ->
        [ "CDEF:" ++ alias ++ "=" ++ rawF
            ++ "," ++ show factor ++ ",*"
        ]

plotArg :: Plot -> String
plotArg = \case
  Line width series ->
    "LINE" ++ show width ++ ":" ++ serAlias series
      ++ serColor series ++ ":" ++ serLabel series

  Area series ->
    "AREA:" ++ serAlias series
      ++ serColor series ++ ":" ++ serLabel series

plotSeries :: Plot -> Series
plotSeries = \case
  Line _ series -> series
  Area series   -> series

buildGraphArgs :: FilePath -> GraphSpec -> Range -> [String]
buildGraphArgs rrdPath spec range =
  [ "graph"
  , "-"
  , "--start", rangeStart range
  , "--title", gsTitle spec
  , "--width", "800"
  , "--height", "250"
  , "--imgformat", "PNG"
  ]
    ++ concatMap (defArgs rrdPath . plotSeries) (gsPlots spec)
    ++ map plotArg (gsPlots spec)


readProcessBytes :: FilePath -> [String] -> IO (ExitCode, BS.ByteString, String)
readProcessBytes cmd args =
  withCreateProcess (proc cmd args) { std_out = CreatePipe, std_err = CreatePipe } $
    \_ mout merr ph ->
      case (mout, merr) of
        (Just hout, Just herr) -> do
          out <- BS.hGetContents hout
          err <- hGetContents herr
          code <- waitForProcess ph
          _ <- evaluate (length err)
          pure (code, out, err)
        _ -> pure (ExitFailure 1, BS.empty, "failed to create pipes")

renderGraph :: MonadIO m => FilePath -> FilePath -> GraphSpec -> Range -> m (Either Text BS.ByteString)
renderGraph rrdPath rrdtool spec range = do
  (code, out, err) <- liftIO (readProcessBytes rrdtool (buildGraphArgs rrdPath spec range))
  case code of
    ExitSuccess
      | not (BS.null out) -> pure $ Right out
      | otherwise -> pure $ Left "empty graph"
    _ -> pure $ Left (T.pack $ take 200 err)




data Graph
  = Memory
  | Traffic
  | RateLimit
  deriving (Show, Eq, Enum, Bounded)

instance ToHttpApiData Graph where
  toQueryParam Memory = "memory.png"
  toQueryParam Traffic = "traffic.png"
  toQueryParam RateLimit = "ratelimit.png"

instance FromHttpApiData Graph where
  parseQueryParam "memory.png" = Right Memory
  parseQueryParam "traffic.png" = Right Traffic
  parseQueryParam "ratelimit.png" = Right RateLimit
  parseQueryParam x = Left ("Can't parse '" <> x <> "' as Graph")