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

{-# LANGUAGE OverloadedStrings #-}

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

import Control.Exception (evaluate)
import Control.Monad (forever)
import Control.Monad.IO.Class (liftIO, MonadIO)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import Data.Void (Void)
import Network.HTTP.Types.Status (Status, status400, status404, status500)
import Network.Wai.Handler.Warp (defaultSettings, setHost, setPort)
import System.Exit (ExitCode (..))
import System.IO (hGetContents)
import System.Process (CreateProcess (..), StdStream (..), proc, waitForProcess, withCreateProcess)
import Web.Scotty
  ( ActionM
  , ScottyM
  , defaultOptions
  , get
  , pathParam
  , queryParamMaybe
  , raw
  , scottyOpts
  , setHeader
  , settings
  , status
  , text
  )

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]]

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]
  }
  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"
            }
        ]
    }

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"
            }
        ]
    }

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

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

lookupGraph :: [GraphSpec] -> Text -> Maybe GraphSpec
lookupGraph specs name = case [g | g <- specs, gsName g == name] of
  (g : _) -> Just g
  []      -> Nothing

parseNameParam :: [GraphSpec] -> Text -> Maybe GraphSpec
parseNameParam specs t = T.stripSuffix ".png" t >>= lookupGraph specs

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")

respond :: Status -> TL.Text -> ActionM ()
respond st body = status st >> text body

serve :: FilePath -> FilePath -> GraphSpec -> Range -> ActionM ()
serve rrdPath rrdtool spec range = do
  (code, out, err) <- liftIO (readProcessBytes rrdtool (buildGraphArgs rrdPath spec range))
  case code of
    ExitSuccess
      | not (BS.null out) -> do
          setHeader "Content-Type" "image/png"
          raw (BL.fromStrict out)
      | otherwise -> respond status500 "empty graph"
    _ -> respond status500 (TL.pack (take 200 err))

handler :: FilePath -> FilePath -> ActionM ()
handler rrdPath rrdtool = do
  name <- pathParam "name"
  case parseNameParam graphs name of
    Nothing -> respond status404 "unknown graph"
    Just spec -> do
      rangeArg <- queryParamMaybe "range"
      case rangeArg of
        Nothing -> serve rrdPath rrdtool spec OneDay
        Just t -> case parseRange t of
          Nothing -> respond status400 "invalid range"
          Just range -> serve rrdPath rrdtool spec range

app :: FilePath -> FilePath -> ScottyM ()
app rrdPath rrdtool = get "/metrics/:name" (handler rrdPath rrdtool)

graphAction :: MonadIO m => FilePath -> FilePath -> Int -> m Void
graphAction rrdPath rrdtool port = liftIO $ forever $ scottyOpts opts (app rrdPath rrdtool)
  where
    opts = defaultOptions
      { settings = setHost "127.0.0.1" (setPort port defaultSettings)
      }