{-# Language TemplateHaskell #-}
module HBS2.ScheduledAction
  ( Scheduled
  , scheduleRunPeriod
  , defScheduled
  , runScheduled
  , schedule
  ) where

import HBS2.Prelude.Plated
import HBS2.Clock

import Prelude hiding (all)
import Data.Word
import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as HashMap
import Lens.Micro.Platform
import Control.Monad
import Data.List qualified as List

import Control.Exception qualified as E

import UnliftIO as U

-- NOTE: scheduled-action
--   держит список действий (IO ())
--   привязанных к временным "слотам" (секундам) с точностью до
--   секунды.
--   После наступления секунды --- выполняет список действий,
--   привязанных к слоту, удаляет действия, удаляет слот.
--   Полезно, что бы очищать данные, имеющие продолжительность
--   жизни -- всякие там кэши, хэшмапы и так далее.
--
--   В отличие от Cache, не знает о сути действий ничего,
--   кроме того, что это IO ().
--
--   Может быть (и должно, наверное) быть глобальным на
--   всё приложение

type SlotNum = Word64

data Scheduled =
  Scheduled
  { _scheduleRunPeriod  :: Timeout 'Seconds
  , slots               :: TVar (HashMap SlotNum [IO ()])
  }

makeLenses 'Scheduled

defScheduled :: MonadUnliftIO m => m Scheduled
defScheduled = Scheduled 10 <$> newTVarIO mempty

runScheduled :: MonadUnliftIO m => Scheduled -> m ()
runScheduled sch = forever do
  pause (view scheduleRunPeriod sch)

  now <- getTimeCoarse <&> toNanoSecs <&> (/1e9) . realToFrac <&> round

  expired <- atomically do
    all   <- readTVar (slots sch) <&> HashMap.toList
    let (rest, expired)  = List.partition ( (>now) . fst) all
    writeTVar (slots sch) (HashMap.fromList rest)
    pure expired

  for_ expired $ \(_, all) -> do
    for_ all $ \action -> do
      -- TODO: error-logging-maybe
      liftIO $ void $ action `E.catch` (\(_ :: E.ArithException) -> pure ())
                             `E.catch` (\(_ :: E.IOException)    -> pure ())
                             `E.catch` (\(_ :: E.SomeException)  -> pure ())

schedule :: forall a m . (MonadUnliftIO m, Integral a) => Scheduled -> a -> IO () -> m ()
schedule s ttl what = do
  now <- getTimeCoarse <&> toNanoSecs <&> (/1e9) . realToFrac <&> round
  let slot = now + fromIntegral ttl
  atomically $ modifyTVar (slots s) (HashMap.insertWith (<>) slot [what])