{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

module HomeAssistant.Runtime
  ( defaultMain
  , step
  , CallIdGen
  , mkCallIdGen
  , dryRunHassEval
  , Controller(..)
  , runController
  ) where

import AFRP (Event (..), Mealy (..), Request (..), Auto, stepAutoSerializing, load, DecodedAuto (..))
import Control.Concurrent.STM (atomically, dupTChan, readTChan)
import Data.Aeson (Value)
import qualified Data.Text as T
import Data.Time (getCurrentTime, getCurrentTimeZone)
import Data.Void (Void)
import HomeAssistant.Controller (HASS, HASSEff (..))
import HomeAssistant.Runtime.Bus
import HomeAssistant.Runtime.Connection (writerAction, readerAction)
import Network.Socket (withSocketsDo)
import System.Environment (getEnv, lookupEnv)
import HomeAssistant.Controller.Bedroom (bedroomPresenceController, bedroomButtonController, bedroomDrawerController, humidifierController)
import Data.UUID (UUID, toText)
import qualified Data.UUID.V4 as UUID.V4
import Katip (runKatipT, logF, sl, Severity (..), ls, Namespace (Namespace), runKatipContextT)
import Control.Monad.IO.Class (liftIO, MonadIO)
import HomeAssistant.Controller.Children (schoolLightController, childrenBedroomButtonController)
import Data.Maybe (fromMaybe)
import qualified System.Metrics
import qualified HomeAssistant.Runtime.Metrics
import System.FilePath ((</>))
import Text.Read (readMaybe)
import HomeAssistant.Controller.Kitchen (kitchenMotionController)
import HomeAssistant.Controller.Livingroom (livingroomPresenceController)
import HomeAssistant.Runtime.RateLimit (slidingWindowLimiter, registerRateLimitMetrics)
import UnliftIO.Async
import HomeAssistant.Runtime.Supervisor (supervised)
import HomeAssistant.Controller.Hallway (hallwayLightsController)
import qualified HttpServer

step :: (MonadIO m) => FilePath -> UUID -> Auto m a b -> a -> m (b, Auto m a b)
step path trace st a = do
  now <- liftIO getCurrentTime
  tz <- liftIO getCurrentTimeZone
  let req = Request now tz trace
  stepAutoSerializing path st req a

data Controller = forall b. Controller Bool T.Text (HASS (Event Value) b)

controllers :: [Controller]
controllers =
  [ Controller True "bedroom-presence" bedroomPresenceController
  , Controller True "bedroom-button" bedroomButtonController
  , Controller True "bedroom-drawer" bedroomDrawerController
  , Controller True "bedroom-humidifier" humidifierController
  , Controller True "school-light-controller" schoolLightController
  , Controller True "kitchen-motion-controller" kitchenMotionController
  , Controller True "livingroom-presence" livingroomPresenceController
  , Controller True "hallway-motion-controller" hallwayLightsController
  , Controller True "children-button" childrenBedroomButtonController
  ]

-- | Steps the machine for every inbound message; service calls go to the
-- bus. A restart re-dups the inbound channel and starts from the machine's
-- initial state; messages broadcast during the restart window are lost.
runController :: MonadIO m => FilePath -> Bus -> Controller -> m Void
runController rootDir bus (Controller _enabled name machine ) = liftIO $ do
  inbound <- atomically (dupTChan (busInbound bus))
  let ns = Namespace [name]
  let workerDefinition = runMealy machine (runKatipContextT (busLogEnv bus) () ns . channelHassEval bus)
  let path  = rootDir </> T.unpack name
  worker <- load path workerDefinition >>= \case
    Decoded a -> pure a
    FailDecode err a -> a <$ putStrLn ("Failed to load (" <> T.unpack name <> "): " <> err)
  go path inbound worker
  where
    go path inbound f = do
      msg <- atomically (readTChan inbound)
      uuid <- UUID.V4.nextRandom
      (_, next) <- step path uuid f msg
      go path inbound next

lookupPort :: IO Int
lookupPort = do
  m <- lookupEnv "HA_METRICS_PORT"
  case m of
    Nothing -> pure 8124
    Just s  -> case readMaybe s of
      Just p | p >= 1 && p <= 65535 -> pure p
      _ -> fail ("HA_METRICS_PORT must be a port in 1..65535: " <> s)

defaultMain :: IO ()
defaultMain = withSocketsDo $ do
  severity <- maybe InfoS (const DebugS) <$> lookupEnv "HA_DEBUG"
  store <- System.Metrics.newStore
  System.Metrics.registerGcMetrics store
  appMetrics <- HomeAssistant.Runtime.Metrics.registerAppMetrics store
  rateLimitMetrics <- registerRateLimitMetrics store
  withBus severity appMetrics $ \bus -> do
    token <- getEnv "HA_TOKEN"
    host <- getEnv "HA_HOST"
    rootPath <- fromMaybe "/tmp/" <$> lookupEnv "HA_LIB_DIR"
    rrdPath <- fromMaybe "hass-controller.rrd" <$> lookupEnv "HA_RRD_PATH"
    rrdtool <- fromMaybe "rrdtool" <$> lookupEnv "HA_RRDTOOL"
    metricsPort <- lookupPort
    writerLimiter <- slidingWindowLimiter rateLimitMetrics 10 20
    let active = [c | c@(Controller True _ _) <- controllers]
        ents = foldMap (\(Controller _ _ m) -> entities m) active
        workers =
          [ ("reader", readerAction host 8123 token ents bus)
          , ("writer", writerAction writerLimiter bus)
          , ("metrics", HomeAssistant.Runtime.Metrics.metricsAction store rrdPath rrdtool)
          , ("metrics-http", HttpServer.runHttpServer rrdPath rrdtool metricsPort)
          ] ++ [ (name, runController rootPath bus c) | c@(Controller True name _) <- active ]
    runKatipContextT (busLogEnv bus) () mempty $
      mapConcurrently_ (uncurry supervised) workers

dryRunHassEval :: Namespace -> Bus -> HASSEff a -> IO a
dryRunHassEval ns bus = \case
  CallService req x -> runKatipT (busLogEnv bus) $ do
    callId <- liftIO $ generateCallId (busGen bus)
    logF (sl "traceId" (toText (requestTraceId req))) ns DebugS (ls $ show (callId, x))
  Debug x -> runKatipT (busLogEnv bus) $ do
    logF () ns DebugS (ls $ show x)
  Trace req x -> runKatipT (busLogEnv bus) $ do
    logF (sl "traceId" (toText (requestTraceId req))) ns InfoS (ls $ show x)