{-# 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 (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