{-# 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.Async (async, waitAny)
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, absurd)
import HomeAssistant.Controller (HASS, HASSEff (..))
import HomeAssistant.Runtime.Bus
import HomeAssistant.Runtime.Connection (readerAction, writerAction)
import HomeAssistant.Runtime.Supervisor (defaultBackoff, supervised)
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.Ruuvi (ruuviController)
import HomeAssistant.Controller.Children (schoolLightController)
import Data.Maybe (fromMaybe)
import qualified System.Metrics
import qualified HomeAssistant.Runtime.Metrics
import System.FilePath ((</>))
import HomeAssistant.Controller.Kitchen (kitchenMotionController)

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 T.Text (HASS (Event Value) b) Bool

controllers :: [Controller]
controllers =
  [ Controller "bedroom-presence" bedroomPresenceController False
  , Controller "bedroom-button" bedroomButtonController False -- This works but leaving for vacation
  , Controller "bedroom-drawer" bedroomDrawerController True
  , Controller "bedroom-humidifier" humidifierController True
  , Controller "ruuvi-controller" ruuviController False
  , Controller "school-light-controller" schoolLightController True
  , Controller "kitchen-motion-controller" kitchenMotionController True
  ]

-- | 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 :: FilePath -> Bus -> Controller -> IO Void
runController rootDir bus (Controller name machine _enabled) = 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

defaultMain :: IO ()
defaultMain = withSocketsDo $ do
  severity <- maybe InfoS (const DebugS) <$> lookupEnv "HA_DEBUG"
  withBus severity $ \bus -> do
    token <- getEnv "HA_TOKEN"
    host <- getEnv "HA_HOST"
    rootPath <- fromMaybe "/tmp/" <$> lookupEnv "HA_LIB_DIR"
    store <- System.Metrics.newStore
    System.Metrics.registerGcMetrics store
    rrdPath <- fromMaybe "hass-controller.rrd" <$> lookupEnv "HA_RRD_PATH"
    rrdtool <- fromMaybe "rrdtool" <$> lookupEnv "HA_RRDTOOL"
    let active = [c | c@(Controller _ _ True) <- controllers]
        ents = foldMap (\(Controller _ m _) -> entities m) active
        workers =
          [ ("reader", readerAction host 8123 token ents bus)
          , ("writer", writerAction bus)
          ] ++ [ (name, runController rootPath bus c) | c@(Controller name _ True) <- controllers ]
            ++ [("metrics", HomeAssistant.Runtime.Metrics.metricsAction store rrdPath rrdtool)]
    as <- mapM (\(name, act) -> async (supervised name defaultBackoff act)) workers
    (_, v) <- waitAny as
    absurd v

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)