{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_HADDOCK show-extensions #-}

{-|
Module      : $Header$
Copyright   : (c) 2016 Deakin Software & Technology Innovation Lab
License     : BSD3

Maintainer  : Rhys Adams <rhys.adams@deakin.edu.au>
Stability   : unstable
Portability : portable

Updating local state with data from the scheduler.
-}

module Eclogues.Threads.Update (loadSchedulerState) where

import Eclogues.Prelude
import Eclogues.AppConfig (AppConfig)
import qualified Eclogues.AppConfig as Config
import qualified Eclogues.Persist as Persist
import Eclogues.Scheduling.Run (getSchedulerStatuses, mkSchedConf)
import Eclogues.State (jobsProgressingOnScheduler, updateJobs)
import qualified Eclogues.State.Monad as ES
import Eclogues.State.Types (AppState)

import qualified Control.Concurrent.AdvSTM as STM
import qualified Control.Concurrent.AdvSTM.TChan as STM
import qualified Control.Concurrent.AdvSTM.TVar as STM
import Control.Exception.Safe (IOException, try)
import Network.HTTP.Client (Manager)
import Say (sayErrString)

-- | Query the scheduler and run 'updateJobs'.
loadSchedulerState :: Manager -> AppConfig -> STM.TVar AppState -> IO ()
loadSchedulerState mgr conf stateV = do
    (newStatusesRes, aJobs) <- do
        state <- STM.atomically $ STM.readTVar stateV
        let aJobs = jobsProgressingOnScheduler state
        newStatusesRes <- try . runExceptT $ getSchedulerStatuses schedConf aJobs
        pure (newStatusesRes, aJobs)
    case newStatusesRes of
        Right (Right newStatuses) -> STM.atomically $ do
            state <- STM.readTVar stateV
            let (_, ts) = ES.runState state $ updateJobs aJobs newStatuses
            mapM_ (STM.writeTChan $ Config.schedChan conf) $ ts ^. ES.scheduleCommands
            STM.writeTVar stateV $ ts ^. ES.appState
            mapM_ (STM.onCommit . Persist.atomically (Config.pctx conf)) $ ts ^. ES.persist
        -- TODO: avoid exceptions, capture in underlying Left
        Left (ex :: IOException)  ->
            sayErrString $ "Error connecting to scheduler; retrying: " ++ show ex
        Right (Left resp)         ->
            sayErrString $ "Error communicating with scheduler; retrying: " ++ show resp
  where
    schedConf = mkSchedConf mgr conf
