{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
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 (IORef Bool -> Internal) -> IO (IORef Bool) -> IO Internal
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> IO (IORef Bool)
forall (m :: * -> *) a. MonadBase IO m => a -> m (IORef a)
newIORef Bool
False
Hub -> (SystemInit -> EventStore ()) -> IO ()
forall s a.
(Sub s, Typeable a) =>
s -> (a -> EventStore ()) -> IO ()
subscribe Hub
mainBus (Internal -> SystemInit -> EventStore ()
onInit Internal
internal)
Hub -> (SystemShutdown -> EventStore ()) -> IO ()
forall s a.
(Sub s, Typeable a) =>
s -> (a -> EventStore ()) -> IO ()
subscribe Hub
mainBus (Internal -> SystemShutdown -> EventStore ()
onShutdown Internal
internal)
Hub -> (NewTimer -> EventStore ()) -> IO ()
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 :: Internal -> e -> Duration -> Bool -> EventStore ()
delayed Internal{IORef Bool
_stopped :: IORef Bool
_stopped :: Internal -> IORef Bool
..} e
msg (Duration Int64
timespan) Bool
oneOff = () () -> EventStore ThreadId -> EventStore ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ EventStore () -> EventStore ThreadId
forall (m :: * -> *). MonadBaseControl IO m => m () -> m ThreadId
fork (Int64 -> EventStore ()
go Int64
timespan)
where
go :: Int64 -> EventStore ()
go Int64
n = do
Bool -> EventStore () -> EventStore ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int64
n Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int64
0) (EventStore () -> EventStore ()) -> EventStore () -> EventStore ()
forall a b. (a -> b) -> a -> b
$ do
let waiting :: Int64
waiting = Int64 -> Int64 -> Int64
forall a. Ord a => a -> a -> a
min Int64
n (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
forall a. Bounded a => a
maxBound :: Int))
Int -> EventStore ()
forall (m :: * -> *). MonadBase IO m => Int -> m ()
threadDelay (Int -> EventStore ()) -> Int -> EventStore ()
forall a b. (a -> b) -> a -> b
$ Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
waiting
Int64 -> EventStore ()
go (Int64
timespan Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
waiting)
e -> EventStore ()
forall a. Typeable a => a -> EventStore ()
publish e
msg
Bool
stopped <- IORef Bool -> EventStore Bool
forall (m :: * -> *) a. MonadBase IO m => IORef a -> m a
readIORef IORef Bool
_stopped
Bool -> EventStore () -> EventStore ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
oneOff Bool -> Bool -> Bool
|| Bool
stopped) (EventStore () -> EventStore ()) -> EventStore () -> EventStore ()
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
_ = Initialized -> EventStore ()
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 -> Text
Loc -> Text -> LogLevel -> Text -> EventStore ()
(Text -> EventStore ()) -> (Text -> Text) -> 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..."
IORef Bool -> Bool -> EventStore ()
forall (m :: * -> *) a. MonadBase IO m => IORef a -> a -> m ()
atomicWriteIORef IORef Bool
_stopped Bool
True
ServiceTerminated -> EventStore ()
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) = Internal -> e -> Duration -> Bool -> EventStore ()
forall e.
Typeable e =>
Internal -> e -> Duration -> Bool -> EventStore ()
delayed Internal
self e
msg Duration
duration Bool
oneOff