mirror of https://github.com/voidlizard/hbs2
80 lines
2.6 KiB
Haskell
80 lines
2.6 KiB
Haskell
{-# 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])
|
||
|
||
|
||
|