module Ouroboros.Consensus.BlockchainTime.WallClock.Default (defaultSystemTime) where

import           Control.Monad
import           Control.Tracer
import           Data.Time (UTCTime, diffUTCTime)

import           Control.Monad.Class.MonadTime (MonadTime (..))

import           Ouroboros.Consensus.BlockchainTime.WallClock.Types
import           Ouroboros.Consensus.BlockchainTime.WallClock.Util
import           Ouroboros.Consensus.Util.IOLike
import           Ouroboros.Consensus.Util.Time

defaultSystemTime :: (MonadTime m, MonadDelay m)
                  => SystemStart
                  -> Tracer m (TraceBlockchainTimeEvent UTCTime)
                  -> SystemTime m
defaultSystemTime :: SystemStart
-> Tracer m (TraceBlockchainTimeEvent UTCTime) -> SystemTime m
defaultSystemTime SystemStart
start Tracer m (TraceBlockchainTimeEvent UTCTime)
tracer = SystemTime :: forall (m :: * -> *). m RelativeTime -> m () -> SystemTime m
SystemTime {
      systemTimeCurrent :: m RelativeTime
systemTimeCurrent = SystemStart -> UTCTime -> RelativeTime
toRelativeTime SystemStart
start (UTCTime -> RelativeTime) -> m UTCTime -> m RelativeTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
    , systemTimeWait :: m ()
systemTimeWait    = SystemStart -> Tracer m (TraceBlockchainTimeEvent UTCTime) -> m ()
forall (m :: * -> *).
(MonadTime m, MonadDelay m) =>
SystemStart -> Tracer m (TraceBlockchainTimeEvent UTCTime) -> m ()
waitForSystemStart SystemStart
start Tracer m (TraceBlockchainTimeEvent UTCTime)
tracer
    }

-- | Wait until system start if necessary
waitForSystemStart :: (MonadTime m, MonadDelay m)
                   => SystemStart
                   -> Tracer m (TraceBlockchainTimeEvent UTCTime)
                   -> m ()
waitForSystemStart :: SystemStart -> Tracer m (TraceBlockchainTimeEvent UTCTime) -> m ()
waitForSystemStart SystemStart
start Tracer m (TraceBlockchainTimeEvent UTCTime)
tracer = do
    UTCTime
now <- m UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SystemStart -> UTCTime
getSystemStart SystemStart
start UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
> UTCTime
now) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      let delay :: NominalDiffTime
delay = SystemStart -> UTCTime
getSystemStart SystemStart
start UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` UTCTime
now
      Tracer m (TraceBlockchainTimeEvent UTCTime)
-> TraceBlockchainTimeEvent UTCTime -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceBlockchainTimeEvent UTCTime)
tracer (TraceBlockchainTimeEvent UTCTime -> m ())
-> TraceBlockchainTimeEvent UTCTime -> m ()
forall a b. (a -> b) -> a -> b
$ SystemStart -> NominalDiffTime -> TraceBlockchainTimeEvent UTCTime
forall t.
SystemStart -> NominalDiffTime -> TraceBlockchainTimeEvent t
TraceStartTimeInTheFuture SystemStart
start NominalDiffTime
delay
      DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay (NominalDiffTime -> DiffTime
nominalDelay NominalDiffTime
delay)