{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE RecordWildCards    #-}
--------------------------------------------------------------------------------
-- |
-- Module : Database.EventStore.Internal.Exec
-- 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.Exec
  ( Exec
  , Terminated(..)
  , newExec
  , execSettings
  , execWaitTillClosed
  ) where

--------------------------------------------------------------------------------
import Prelude (String)
import Data.Typeable

--------------------------------------------------------------------------------
import Database.EventStore.Internal.Communication
import Database.EventStore.Internal.Connection
import Database.EventStore.Internal.ConnectionManager
import Database.EventStore.Internal.Control
import Database.EventStore.Internal.Discovery
import Database.EventStore.Internal.Logger
import Database.EventStore.Internal.Prelude
import Database.EventStore.Internal.TimerService

--------------------------------------------------------------------------------
type ServicePendingInit = HashMap Service ()

--------------------------------------------------------------------------------
data Stage
  = Init
  | Available Publish
  | Errored String

--------------------------------------------------------------------------------
newtype Terminated = Terminated String deriving (Int -> Terminated -> ShowS
[Terminated] -> ShowS
Terminated -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Terminated] -> ShowS
$cshowList :: [Terminated] -> ShowS
show :: Terminated -> String
$cshow :: Terminated -> String
showsPrec :: Int -> Terminated -> ShowS
$cshowsPrec :: Int -> Terminated -> ShowS
Show, Typeable)

--------------------------------------------------------------------------------
instance Exception Terminated

--------------------------------------------------------------------------------
data Exec =
  Exec { Exec -> Settings
execSettings       :: Settings
       , Exec -> STM Publish
_execPub           :: STM Publish
       , Exec -> Internal
_internal          :: Internal
       , Exec -> IO ()
execWaitTillClosed :: IO ()
       }

--------------------------------------------------------------------------------
data Internal =
  Internal { Internal -> IORef ServicePendingInit
_initRef   :: IORef ServicePendingInit
           , Internal -> IORef ServicePendingInit
_finishRef :: IORef ServicePendingInit
           , Internal -> TVar Stage
_stageVar  :: TVar Stage
           }

--------------------------------------------------------------------------------
instance Pub Exec where
  publishSTM :: forall a. Typeable a => Exec -> a -> STM Bool
publishSTM Exec
e a
a = do
    Publish
pub     <- Exec -> STM Publish
_execPub Exec
e
    Bool
handled <- forall p a. (Pub p, Typeable a) => p -> a -> STM Bool
publishSTM Publish
pub a
a
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
handled forall a b. (a -> b) -> a -> b
$
      forall e a. Exception e => e -> STM a
throwSTM forall a b. (a -> b) -> a -> b
$ String -> Terminated
Terminated String
"Connection Closed."

    forall (m :: * -> *) a. Monad m => a -> m a
return Bool
handled

--------------------------------------------------------------------------------
stageSTM :: TVar Stage -> STM Publish
stageSTM :: TVar Stage -> STM Publish
stageSTM TVar Stage
var = do
  Stage
stage <- forall a. TVar a -> STM a
readTVar TVar Stage
var
  case Stage
stage of
    Stage
Init          -> forall a. STM a
retrySTM
    Available Publish
pub -> forall (m :: * -> *) a. Monad m => a -> m a
return Publish
pub
    Errored String
msg   -> forall e a. Exception e => e -> STM a
throwSTM forall a b. (a -> b) -> a -> b
$ String -> Terminated
Terminated String
msg

--------------------------------------------------------------------------------
errored :: TVar Stage -> String -> STM ()
errored :: TVar Stage -> String -> STM ()
errored TVar Stage
var String
err = do
  Stage
stage <- forall a. TVar a -> STM a
readTVar TVar Stage
var
  case Stage
stage of
    Errored String
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Stage
_         -> forall a. TVar a -> a -> STM ()
writeTVar TVar Stage
var (String -> Stage
Errored String
err)

--------------------------------------------------------------------------------
initServicePending :: ServicePendingInit
initServicePending :: ServicePendingInit
initServicePending = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\Service
svc -> forall map. IsMap map => ContainerKey map -> MapValue map -> map
singletonMap Service
svc ()) [forall a. Bounded a => a
minBound..]

--------------------------------------------------------------------------------
newExec :: Settings -> Bus -> ConnectionBuilder -> Discovery -> IO Exec
newExec :: Settings -> Bus -> ConnectionBuilder -> Discovery -> IO Exec
newExec Settings
setts Bus
mainBus ConnectionBuilder
builder Discovery
disc = do

  Internal
internal <- IORef ServicePendingInit
-> IORef ServicePendingInit -> TVar Stage -> 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 ServicePendingInit
initServicePending
                       forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. MonadBase IO m => a -> m (IORef a)
newIORef ServicePendingInit
initServicePending
                       forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. a -> IO (TVar a)
newTVarIO Stage
Init

  let stagePub :: STM Publish
stagePub = TVar Stage -> STM Publish
stageSTM forall a b. (a -> b) -> a -> b
$ Internal -> TVar Stage
_stageVar Internal
internal
      exe :: Exec
exe      = Settings -> STM Publish -> Internal -> IO () -> Exec
Exec Settings
setts STM Publish
stagePub Internal
internal (Bus -> IO ()
busProcessedEverything Bus
mainBus)
      hub :: Hub
hub      = forall h. (Sub h, Pub h) => h -> Hub
asHub Bus
mainBus

  Hub -> IO ()
timerService Hub
hub
  Settings -> ConnectionBuilder -> Discovery -> Hub -> IO ()
connectionManager Settings
setts ConnectionBuilder
builder Discovery
disc Hub
hub

  forall s a.
(Sub s, Typeable a) =>
s -> (a -> EventStore ()) -> IO ()
subscribe Bus
mainBus (Internal -> Initialized -> EventStore ()
onInit Internal
internal)
  forall s a.
(Sub s, Typeable a) =>
s -> (a -> EventStore ()) -> IO ()
subscribe Bus
mainBus (Internal -> InitFailed -> EventStore ()
onInitFailed Internal
internal)
  forall s a.
(Sub s, Typeable a) =>
s -> (a -> EventStore ()) -> IO ()
subscribe Bus
mainBus (Internal -> FatalException -> EventStore ()
onFatal Internal
internal)
  forall s a.
(Sub s, Typeable a) =>
s -> (a -> EventStore ()) -> IO ()
subscribe Bus
mainBus (Internal -> ServiceTerminated -> EventStore ()
onTerminated Internal
internal)
  forall s a.
(Sub s, Typeable a) =>
s -> (a -> EventStore ()) -> IO ()
subscribe Bus
mainBus (Internal -> SystemShutdown -> EventStore ()
onShutdown Internal
internal)

  forall p a (m :: * -> *).
(Pub p, Typeable a, MonadIO m) =>
p -> a -> m ()
publishWith Bus
mainBus SystemInit
SystemInit

  forall (m :: * -> *) a. Monad m => a -> m a
return Exec
exe

--------------------------------------------------------------------------------
onInit :: Internal -> Initialized -> EventStore ()
onInit :: Internal -> Initialized -> EventStore ()
onInit Internal{TVar Stage
IORef ServicePendingInit
_stageVar :: TVar Stage
_finishRef :: IORef ServicePendingInit
_initRef :: IORef ServicePendingInit
_stageVar :: Internal -> TVar Stage
_finishRef :: Internal -> IORef ServicePendingInit
_initRef :: Internal -> IORef ServicePendingInit
..} (Initialized Service
svc) = 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 [i|Service #{svc} initialized|]
  Bool
initialized <- forall (m :: * -> *) a b.
MonadBase IO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' IORef ServicePendingInit
_initRef forall a b. (a -> b) -> a -> b
$ \ServicePendingInit
m ->
    let m' :: ServicePendingInit
m' = forall map. IsMap map => ContainerKey map -> map -> map
deleteMap Service
svc ServicePendingInit
m in
    (ServicePendingInit
m', forall mono. MonoFoldable mono => mono -> Bool
null ServicePendingInit
m')

  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
initialized forall a b. (a -> b) -> a -> b
$ 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
"Entire system initialized properly"
    Publish
pub <- EventStore Publish
publisher
    forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> a -> STM ()
writeTVar TVar Stage
_stageVar (Publish -> Stage
Available Publish
pub)

--------------------------------------------------------------------------------
onInitFailed :: Internal -> InitFailed -> EventStore ()
onInitFailed :: Internal -> InitFailed -> EventStore ()
onInitFailed Internal{TVar Stage
IORef ServicePendingInit
_stageVar :: TVar Stage
_finishRef :: IORef ServicePendingInit
_initRef :: IORef ServicePendingInit
_stageVar :: Internal -> TVar Stage
_finishRef :: Internal -> IORef ServicePendingInit
_initRef :: Internal -> IORef ServicePendingInit
..} (InitFailed Service
svc) = do
  forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ TVar Stage -> String -> STM ()
errored TVar Stage
_stageVar String
"Driver failed to initialized"
  $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
logError [i|Service #{svc} failed to initialize.|]
  EventStore ()
stopBus
  $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
logError Text
"System can't start."

--------------------------------------------------------------------------------
onFatal :: Internal -> FatalException -> EventStore ()
onFatal :: Internal -> FatalException -> EventStore ()
onFatal self :: Internal
self@Internal{TVar Stage
IORef ServicePendingInit
_stageVar :: TVar Stage
_finishRef :: IORef ServicePendingInit
_initRef :: IORef ServicePendingInit
_stageVar :: Internal -> TVar Stage
_finishRef :: Internal -> IORef ServicePendingInit
_initRef :: Internal -> IORef ServicePendingInit
..} FatalException
situation = do
  case FatalException
situation of
    FatalException e
e ->
      $(logOther "Fatal") [i|Fatal exception: #{e}|]
    FatalCondition Text
msg ->
      $(logOther "Fatal") [i|Driver is in unrecoverable state: #{msg}.|]

  Internal -> EventStore ()
shutdown Internal
self

--------------------------------------------------------------------------------
onTerminated :: Internal -> ServiceTerminated -> EventStore ()
onTerminated :: Internal -> ServiceTerminated -> EventStore ()
onTerminated Internal{TVar Stage
IORef ServicePendingInit
_stageVar :: TVar Stage
_finishRef :: IORef ServicePendingInit
_initRef :: IORef ServicePendingInit
_stageVar :: Internal -> TVar Stage
_finishRef :: Internal -> IORef ServicePendingInit
_initRef :: Internal -> IORef ServicePendingInit
..} (ServiceTerminated Service
svc) = 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 [i|Service #{svc} terminated.|]
  Bool
terminated <- forall (m :: * -> *) a b.
MonadBase IO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' IORef ServicePendingInit
_finishRef forall a b. (a -> b) -> a -> b
$ \ServicePendingInit
m ->
    let m' :: ServicePendingInit
m' = forall map. IsMap map => ContainerKey map -> map -> map
deleteMap Service
svc ServicePendingInit
m in
    (ServicePendingInit
m', forall mono. MonoFoldable mono => mono -> Bool
null ServicePendingInit
m')

  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
terminated forall a b. (a -> b) -> a -> b
$ 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
"Entire system shutdown properly"
    EventStore ()
stopBus

--------------------------------------------------------------------------------
onShutdown :: Internal -> SystemShutdown -> EventStore ()
onShutdown :: Internal -> SystemShutdown -> EventStore ()
onShutdown Internal{TVar Stage
IORef ServicePendingInit
_stageVar :: TVar Stage
_finishRef :: IORef ServicePendingInit
_initRef :: IORef ServicePendingInit
_stageVar :: Internal -> TVar Stage
_finishRef :: Internal -> IORef ServicePendingInit
_initRef :: Internal -> IORef ServicePendingInit
..} SystemShutdown
_ =
  forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> a -> STM ()
writeTVar TVar Stage
_stageVar (String -> Stage
Errored String
"Connection closed")

--------------------------------------------------------------------------------
shutdown :: Internal -> EventStore ()
shutdown :: Internal -> EventStore ()
shutdown Internal{TVar Stage
IORef ServicePendingInit
_stageVar :: TVar Stage
_finishRef :: IORef ServicePendingInit
_initRef :: IORef ServicePendingInit
_stageVar :: Internal -> TVar Stage
_finishRef :: Internal -> IORef ServicePendingInit
_initRef :: Internal -> IORef ServicePendingInit
..} = do
  forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> a -> STM ()
writeTVar TVar Stage
_stageVar (String -> Stage
Errored String
"Connection closed")
  forall a. Typeable a => a -> EventStore ()
publish SystemShutdown
SystemShutdown