-- | Module to deal with time in direct cardano chain layer. Defines the type
-- for a 'PointInTime' and a means to acquire one via a 'TimeHandle' and
-- 'queryTimeHandle'.
module Hydra.Chain.Direct.TimeHandle where

import Hydra.Prelude

import Cardano.Slotting.Slot (SlotNo (SlotNo))
import Cardano.Slotting.Time (SystemStart (..), fromRelativeTime, toRelativeTime)
import Control.Concurrent.Class.MonadSTM (readTVarIO, writeTVar)
import Hydra.Cardano.Api (EraHistory (EraHistory))
import Hydra.Cardano.Api.Prelude (ChainPoint (ChainPoint, ChainPointAtGenesis))
import Hydra.Chain.Backend (ChainBackend (..))
import Hydra.Chain.CardanoClient (QueryPoint (QueryTip))
import Hydra.Tx.Close (PointInTime)
import Ouroboros.Consensus.HardFork.History.Qry (interpretQuery, slotToWallclock, wallclockToSlot)

data TimeHandle = TimeHandle
  { TimeHandle -> Either Text PointInTime
currentPointInTime :: Either Text PointInTime
  -- ^ Get the current 'PointInTime'
  , TimeHandle -> UTCTime -> Either Text SlotNo
slotFromUTCTime :: UTCTime -> Either Text SlotNo
  -- ^ Lookup slot number given a 'UTCTime'. This will fail if the time is
  -- outside the "safe zone".
  , TimeHandle -> SlotNo -> Either Text UTCTime
slotToUTCTime :: SlotNo -> Either Text UTCTime
  -- ^ Convert a slot number to a 'UTCTime' using the stored epoch info. This
  -- will fail if the slot is outside the "safe zone".
  }

data TimeHandleParams = TimeHandleParams
  { TimeHandleParams -> SystemStart
systemStart :: SystemStart
  , TimeHandleParams -> EraHistory
eraHistory :: EraHistory
  , TimeHandleParams -> SlotNo
horizonSlot :: SlotNo
  , TimeHandleParams -> SlotNo
currentSlot :: SlotNo
  }

-- | Construct a time handle using current slot and given chain parameters. See
-- 'queryTimeHandle' to create one by querying a cardano-node.
mkTimeHandle ::
  SlotNo ->
  SystemStart ->
  EraHistory ->
  TimeHandle
mkTimeHandle :: SlotNo -> SystemStart -> EraHistory -> TimeHandle
mkTimeHandle SlotNo
currentSlotNo SystemStart
systemStart EraHistory
eraHistory =
  TimeHandle
    { $sel:currentPointInTime:TimeHandle :: Either Text PointInTime
currentPointInTime = do
        UTCTime
pt <- SlotNo -> Either Text UTCTime
slotToUTCTime SlotNo
currentSlotNo
        PointInTime -> Either Text PointInTime
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SlotNo
currentSlotNo, UTCTime
pt)
    , UTCTime -> Either Text SlotNo
$sel:slotFromUTCTime:TimeHandle :: UTCTime -> Either Text SlotNo
slotFromUTCTime :: UTCTime -> Either Text SlotNo
slotFromUTCTime
    , SlotNo -> Either Text UTCTime
$sel:slotToUTCTime:TimeHandle :: SlotNo -> Either Text UTCTime
slotToUTCTime :: SlotNo -> Either Text UTCTime
slotToUTCTime
    }
 where
  slotToUTCTime :: SlotNo -> Either Text UTCTime
slotToUTCTime = SystemStart -> EraHistory -> SlotNo -> Either Text UTCTime
slotToUTCTimeWith SystemStart
systemStart EraHistory
eraHistory
  slotFromUTCTime :: UTCTime -> Either Text SlotNo
slotFromUTCTime = SystemStart -> EraHistory -> UTCTime -> Either Text SlotNo
slotFromUTCTimeWith SystemStart
systemStart EraHistory
eraHistory

-- | Convert a slot number to wall-clock time using the given chain parameters.
-- Fails if the slot is outside the era history's horizon.
slotToUTCTimeWith :: SystemStart -> EraHistory -> SlotNo -> Either Text UTCTime
slotToUTCTimeWith :: SystemStart -> EraHistory -> SlotNo -> Either Text UTCTime
slotToUTCTimeWith SystemStart
systemStart (EraHistory Interpreter xs
interpreter) SlotNo
slot =
  case Interpreter xs
-> Qry (RelativeTime, SlotLength)
-> Either PastHorizonException (RelativeTime, SlotLength)
forall (xs :: [*]) a.
HasCallStack =>
Interpreter xs -> Qry a -> Either PastHorizonException a
interpretQuery Interpreter xs
interpreter (SlotNo -> Qry (RelativeTime, SlotLength)
slotToWallclock SlotNo
slot) of
    Left PastHorizonException
pastHorizonEx -> Text -> Either Text UTCTime
forall a b. a -> Either a b
Left (Text -> Either Text UTCTime) -> Text -> Either Text UTCTime
forall a b. (a -> b) -> a -> b
$ PastHorizonException -> Text
forall b a. (Show a, IsString b) => a -> b
show PastHorizonException
pastHorizonEx
    Right (RelativeTime
relativeTime, SlotLength
_slotLength) -> UTCTime -> Either Text UTCTime
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTCTime -> Either Text UTCTime) -> UTCTime -> Either Text UTCTime
forall a b. (a -> b) -> a -> b
$ SystemStart -> RelativeTime -> UTCTime
fromRelativeTime SystemStart
systemStart RelativeTime
relativeTime

-- | Look up the slot containing the given wall-clock time.
-- Fails if the time is outside the era history's horizon.
slotFromUTCTimeWith :: SystemStart -> EraHistory -> UTCTime -> Either Text SlotNo
slotFromUTCTimeWith :: SystemStart -> EraHistory -> UTCTime -> Either Text SlotNo
slotFromUTCTimeWith SystemStart
systemStart (EraHistory Interpreter xs
interpreter) UTCTime
utcTime =
  case Interpreter xs
-> Qry (SlotNo, NominalDiffTime, NominalDiffTime)
-> Either
     PastHorizonException (SlotNo, NominalDiffTime, NominalDiffTime)
forall (xs :: [*]) a.
HasCallStack =>
Interpreter xs -> Qry a -> Either PastHorizonException a
interpretQuery Interpreter xs
interpreter (RelativeTime -> Qry (SlotNo, NominalDiffTime, NominalDiffTime)
wallclockToSlot RelativeTime
relativeTime) of
    Left PastHorizonException
pastHorizonEx -> Text -> Either Text SlotNo
forall a b. a -> Either a b
Left (Text -> Either Text SlotNo) -> Text -> Either Text SlotNo
forall a b. (a -> b) -> a -> b
$ PastHorizonException -> Text
forall b a. (Show a, IsString b) => a -> b
show PastHorizonException
pastHorizonEx
    Right (SlotNo
slotNo, NominalDiffTime
_timeSpentInSlot, NominalDiffTime
_timeLeftInSlot) -> SlotNo -> Either Text SlotNo
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SlotNo
slotNo
 where
  relativeTime :: RelativeTime
relativeTime = SystemStart -> UTCTime -> RelativeTime
toRelativeTime SystemStart
systemStart UTCTime
utcTime

-- | Create a cached variant of 'queryTimeHandle' for converting a given slot:
-- system start is queried once, era history is cached and only re-queried
-- when the demanded slot cannot be converted with it any more (its horizon
-- was outrun, e.g. after a hard fork or a long-lived cache). Should a freshly
-- queried era history still not cover the slot, the returned handle reports
-- the conversion failure to its consumer.
newTimeHandleCache ::
  MonadLabelledSTM m =>
  -- | How to query the system start (used once).
  m SystemStart ->
  -- | How to (re-)query the era history.
  m EraHistory ->
  m (SlotNo -> m TimeHandle)
newTimeHandleCache :: forall (m :: * -> *).
MonadLabelledSTM m =>
m SystemStart -> m EraHistory -> m (SlotNo -> m TimeHandle)
newTimeHandleCache m SystemStart
querySystemStart' m EraHistory
queryEraHistory' = do
  SystemStart
systemStart <- m SystemStart
querySystemStart'
  TVar m EraHistory
eraHistoryVar <- String -> EraHistory -> m (TVar m EraHistory)
forall (m :: * -> *) a.
MonadLabelledSTM m =>
String -> a -> m (TVar m a)
newLabelledTVarIO String
"era-history-cache" (EraHistory -> m (TVar m EraHistory))
-> m EraHistory -> m (TVar m EraHistory)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m EraHistory
queryEraHistory'
  (SlotNo -> m TimeHandle) -> m (SlotNo -> m TimeHandle)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((SlotNo -> m TimeHandle) -> m (SlotNo -> m TimeHandle))
-> (SlotNo -> m TimeHandle) -> m (SlotNo -> m TimeHandle)
forall a b. (a -> b) -> a -> b
$ \SlotNo
slot -> do
    EraHistory
eraHistory <- TVar m EraHistory -> m EraHistory
forall a. TVar m a -> m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> m a
readTVarIO TVar m EraHistory
eraHistoryVar
    case SystemStart -> EraHistory -> SlotNo -> Either Text UTCTime
slotToUTCTimeWith SystemStart
systemStart EraHistory
eraHistory SlotNo
slot of
      Right UTCTime
_ -> TimeHandle -> m TimeHandle
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TimeHandle -> m TimeHandle) -> TimeHandle -> m TimeHandle
forall a b. (a -> b) -> a -> b
$ SlotNo -> SystemStart -> EraHistory -> TimeHandle
mkTimeHandle SlotNo
slot SystemStart
systemStart EraHistory
eraHistory
      Left Text
_ -> do
        EraHistory
refreshed <- m EraHistory
queryEraHistory'
        STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ TVar m EraHistory -> EraHistory -> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m EraHistory
eraHistoryVar EraHistory
refreshed
        TimeHandle -> m TimeHandle
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TimeHandle -> m TimeHandle) -> TimeHandle -> m TimeHandle
forall a b. (a -> b) -> a -> b
$ SlotNo -> SystemStart -> EraHistory -> TimeHandle
mkTimeHandle SlotNo
slot SystemStart
systemStart EraHistory
refreshed

-- | Create cached time conversions for the chain-sync path using the given
-- backend runner. That path only converts block slots and never needs the
-- chain tip, so this replaces three chain queries per block with cached
-- values; see 'newTimeHandleCache' for when the era history is re-queried.
newCachedTimeHandle ::
  ChainBackend backend =>
  (forall a. backend a -> IO a) ->
  IO (SlotNo -> IO TimeHandle)
newCachedTimeHandle :: forall (backend :: * -> *).
ChainBackend backend =>
(forall a. backend a -> IO a) -> IO (SlotNo -> IO TimeHandle)
newCachedTimeHandle forall a. backend a -> IO a
runInBackend =
  IO SystemStart -> IO EraHistory -> IO (SlotNo -> IO TimeHandle)
forall (m :: * -> *).
MonadLabelledSTM m =>
m SystemStart -> m EraHistory -> m (SlotNo -> m TimeHandle)
newTimeHandleCache
    (backend SystemStart -> IO SystemStart
forall a. backend a -> IO a
runInBackend (backend SystemStart -> IO SystemStart)
-> backend SystemStart -> IO SystemStart
forall a b. (a -> b) -> a -> b
$ QueryPoint -> backend SystemStart
forall (m :: * -> *). ChainBackend m => QueryPoint -> m SystemStart
querySystemStart QueryPoint
QueryTip)
    (backend EraHistory -> IO EraHistory
forall a. backend a -> IO a
runInBackend (backend EraHistory -> IO EraHistory)
-> backend EraHistory -> IO EraHistory
forall a b. (a -> b) -> a -> b
$ QueryPoint -> backend EraHistory
forall (m :: * -> *). ChainBackend m => QueryPoint -> m EraHistory
queryEraHistory QueryPoint
QueryTip)

-- | Query the chain for system start and era history before constructing a
-- 'TimeHandle' using the slot at the tip of the network.
queryTimeHandle :: (ChainBackend m, Monad m) => m TimeHandle
queryTimeHandle :: forall (m :: * -> *). (ChainBackend m, Monad m) => m TimeHandle
queryTimeHandle = do
  ChainPoint
tip <- m ChainPoint
forall (m :: * -> *). ChainBackend m => m ChainPoint
queryTip
  SystemStart
systemStart <- QueryPoint -> m SystemStart
forall (m :: * -> *). ChainBackend m => QueryPoint -> m SystemStart
querySystemStart QueryPoint
QueryTip
  EraHistory
eraHistory <- QueryPoint -> m EraHistory
forall (m :: * -> *). ChainBackend m => QueryPoint -> m EraHistory
queryEraHistory QueryPoint
QueryTip
  SlotNo
currentTipSlot <-
    case ChainPoint
tip of
      ChainPoint
ChainPointAtGenesis -> SlotNo -> m SlotNo
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SlotNo -> m SlotNo) -> SlotNo -> m SlotNo
forall a b. (a -> b) -> a -> b
$ Word64 -> SlotNo
SlotNo Word64
0
      ChainPoint SlotNo
slotNo Hash BlockHeader
_ -> SlotNo -> m SlotNo
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SlotNo
slotNo

  TimeHandle -> m TimeHandle
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TimeHandle -> m TimeHandle) -> TimeHandle -> m TimeHandle
forall a b. (a -> b) -> a -> b
$ SlotNo -> SystemStart -> EraHistory -> TimeHandle
mkTimeHandle SlotNo
currentTipSlot SystemStart
systemStart EraHistory
eraHistory