{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE OverloadedStrings         #-}
{-# LANGUAGE RecordWildCards           #-}
--------------------------------------------------------------------------------
-- |
-- Module : Database.EventStore.Internal.TimerService
-- Copyright : (C) 2017 Yorick Laupa
-- License : (see the file LICENSE)
--
-- Maintainer : Yorick Laupa <yo.eight@gmail.com>
-- Stability : provisional
-- Portability : non-portable
--
--------------------------------------------------------------------------------
module Database.EventStore.Internal.TimerService
  ( timerService ) where

--------------------------------------------------------------------------------
import Data.Typeable

--------------------------------------------------------------------------------
import Database.EventStore.Internal.Communication
import Database.EventStore.Internal.Control
import Database.EventStore.Internal.Logger
import Database.EventStore.Internal.Prelude
import Database.EventStore.Internal.Types

--------------------------------------------------------------------------------
data Internal =
  Internal { Internal -> IORef Bool
_stopped :: IORef Bool }

--------------------------------------------------------------------------------
timerService :: Hub -> IO ()
timerService :: Hub -> IO ()
timerService Hub
mainBus = do

  Internal
internal <- IORef Bool -> Internal
Internal forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadBase IO m => a -> m (IORef a)
newIORef Bool
False

  forall s a.
(Sub s, Typeable a) =>
s -> (a -> EventStore ()) -> IO ()
subscribe Hub
mainBus (Internal -> SystemInit -> EventStore ()
onInit Internal
internal)
  forall s a.
(Sub s, Typeable a) =>
s -> (a -> EventStore ()) -> IO ()
subscribe Hub
mainBus (Internal -> SystemShutdown -> EventStore ()
onShutdown Internal
internal)
  forall s a.
(Sub s, Typeable a) =>
s -> (a -> EventStore ()) -> IO ()
subscribe Hub
mainBus (Internal -> NewTimer -> EventStore ()
onNew Internal
internal)

--------------------------------------------------------------------------------
delayed :: Typeable e
        => Internal
        -> e
        -> Duration
        -> Bool
        -> EventStore ()
delayed :: forall e.
Typeable e =>
Internal -> e -> Duration -> Bool -> EventStore ()
delayed Internal{IORef Bool
_stopped :: IORef Bool
_stopped :: Internal -> IORef Bool
..} e
msg (Duration Int64
timespan) Bool
oneOff = () forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (m :: * -> *). MonadBaseControl IO m => m () -> m ThreadId
fork (Int64 -> EventStore ()
go Int64
timespan)
  where
    go :: Int64 -> EventStore ()
go Int64
n = do
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int64
n forall a. Ord a => a -> a -> Bool
> Int64
0) forall a b. (a -> b) -> a -> b
$ do
        let waiting :: Int64
waiting = forall a. Ord a => a -> a -> a
min Int64
n (forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound :: Int))
        forall (m :: * -> *). MonadBase IO m => Int -> m ()
threadDelay forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
waiting
        Int64 -> EventStore ()
go (Int64
timespan forall a. Num a => a -> a -> a
- Int64
waiting)

      forall a. Typeable a => a -> EventStore ()
publish e
msg
      Bool
stopped <- forall (m :: * -> *) a. MonadBase IO m => IORef a -> m a
readIORef IORef Bool
_stopped
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
oneOff Bool -> Bool -> Bool
|| Bool
stopped) forall a b. (a -> b) -> a -> b
$ Int64 -> EventStore ()
go Int64
timespan

--------------------------------------------------------------------------------
onInit ::Internal -> SystemInit -> EventStore ()
onInit :: Internal -> SystemInit -> EventStore ()
onInit Internal{IORef Bool
_stopped :: IORef Bool
_stopped :: Internal -> IORef Bool
..} SystemInit
_ = forall a. Typeable a => a -> EventStore ()
publish (Service -> Initialized
Initialized Service
TimerService)

--------------------------------------------------------------------------------
onShutdown :: Internal -> SystemShutdown -> EventStore ()
onShutdown :: Internal -> SystemShutdown -> EventStore ()
onShutdown Internal{IORef Bool
_stopped :: IORef Bool
_stopped :: Internal -> IORef Bool
..} SystemShutdown
_ = do
  $Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> EventStore ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: String -> Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
logInfo Text
"Shutting down..."
  forall (m :: * -> *) a. MonadBase IO m => IORef a -> a -> m ()
atomicWriteIORef IORef Bool
_stopped Bool
True
  forall a. Typeable a => a -> EventStore ()
publish (Service -> ServiceTerminated
ServiceTerminated Service
TimerService)

--------------------------------------------------------------------------------
onNew :: Internal -> NewTimer -> EventStore ()
onNew :: Internal -> NewTimer -> EventStore ()
onNew Internal
self (NewTimer e
msg Duration
duration Bool
oneOff) = forall e.
Typeable e =>
Internal -> e -> Duration -> Bool -> EventStore ()
delayed Internal
self e
msg Duration
duration Bool
oneOff