-- | 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 (SystemStart), fromRelativeTime, toRelativeTime)
import Data.Time (secondsToNominalDiffTime)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
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.Ledger.Cardano.Evaluate (eraHistoryWithHorizonAt)
import Hydra.Tx.Close (PointInTime)
import Ouroboros.Consensus.HardFork.History.Qry (interpretQuery, slotToWallclock, wallclockToSlot)
import Test.QuickCheck (getPositive)

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
  }

-- | Generate consistent values for 'SystemStart' and 'EraHistory' which has
-- a horizon at the returned SlotNo as well as some UTCTime before that
genTimeParams :: Gen TimeHandleParams
genTimeParams :: Gen TimeHandleParams
genTimeParams = do
  Pico
startSeconds <- Positive Pico -> Pico
forall a. Positive a -> a
getPositive (Positive Pico -> Pico) -> Gen (Positive Pico) -> Gen Pico
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Positive Pico)
forall a. Arbitrary a => Gen a
arbitrary
  let startTime :: UTCTime
startTime = POSIXTime -> UTCTime
posixSecondsToUTCTime (POSIXTime -> UTCTime) -> POSIXTime -> UTCTime
forall a b. (a -> b) -> a -> b
$ Pico -> POSIXTime
secondsToNominalDiffTime Pico
startSeconds
  Pico
uptimeSeconds <- Positive Pico -> Pico
forall a. Positive a -> a
getPositive (Positive Pico -> Pico) -> Gen (Positive Pico) -> Gen Pico
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Positive Pico)
forall a. Arbitrary a => Gen a
arbitrary
  -- it is ok to construct a slot from seconds here since on the devnet slot = 1s
  let currentSlotNo :: SlotNo
currentSlotNo = Word64 -> SlotNo
SlotNo (Word64 -> SlotNo) -> Word64 -> SlotNo
forall a b. (a -> b) -> a -> b
$ Pico -> Word64
forall b. Integral b => Pico -> b
forall a b. (RealFrac a, Integral b) => a -> b
truncate (Pico -> Word64) -> Pico -> Word64
forall a b. (a -> b) -> a -> b
$ Pico
uptimeSeconds Pico -> Pico -> Pico
forall a. Num a => a -> a -> a
+ Pico
startSeconds
      -- formula: 3 * k / f where k = securityParam and f = slotLength from the genesis config
      safeZone :: Pico
safeZone = Pico
3 Pico -> Pico -> Pico
forall a. Num a => a -> a -> a
* Pico
2160 Pico -> Pico -> Pico
forall a. Fractional a => a -> a -> a
/ Pico
0.05
      horizonSlot :: SlotNo
horizonSlot = Word64 -> SlotNo
SlotNo (Word64 -> SlotNo) -> Word64 -> SlotNo
forall a b. (a -> b) -> a -> b
$ Pico -> Word64
forall b. Integral b => Pico -> b
forall a b. (RealFrac a, Integral b) => a -> b
truncate (Pico -> Word64) -> Pico -> Word64
forall a b. (a -> b) -> a -> b
$ Pico
uptimeSeconds Pico -> Pico -> Pico
forall a. Num a => a -> a -> a
+ Pico
safeZone
  TimeHandleParams -> Gen TimeHandleParams
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TimeHandleParams -> Gen TimeHandleParams)
-> TimeHandleParams -> Gen TimeHandleParams
forall a b. (a -> b) -> a -> b
$
    TimeHandleParams
      { $sel:systemStart:TimeHandleParams :: SystemStart
systemStart = UTCTime -> SystemStart
SystemStart UTCTime
startTime
      , $sel:eraHistory:TimeHandleParams :: EraHistory
eraHistory = SlotNo -> EraHistory
eraHistoryWithHorizonAt SlotNo
horizonSlot
      , $sel:horizonSlot:TimeHandleParams :: SlotNo
horizonSlot = SlotNo
horizonSlot
      , $sel:currentSlot:TimeHandleParams :: SlotNo
currentSlot = SlotNo
currentSlotNo
      }

instance Arbitrary TimeHandle where
  arbitrary :: Gen TimeHandle
arbitrary = do
    TimeHandleParams{SystemStart
$sel:systemStart:TimeHandleParams :: TimeHandleParams -> SystemStart
systemStart :: SystemStart
systemStart, EraHistory
$sel:eraHistory:TimeHandleParams :: TimeHandleParams -> EraHistory
eraHistory :: EraHistory
eraHistory, SlotNo
$sel:currentSlot:TimeHandleParams :: TimeHandleParams -> SlotNo
currentSlot :: SlotNo
currentSlot} <- Gen TimeHandleParams
genTimeParams
    TimeHandle -> Gen TimeHandle
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TimeHandle -> Gen TimeHandle) -> TimeHandle -> Gen TimeHandle
forall a b. (a -> b) -> a -> b
$ HasCallStack => SlotNo -> SystemStart -> EraHistory -> TimeHandle
SlotNo -> SystemStart -> EraHistory -> TimeHandle
mkTimeHandle SlotNo
currentSlot SystemStart
systemStart EraHistory
eraHistory

-- | Construct a time handle using current slot and given chain parameters. See
-- 'queryTimeHandle' to create one by querying a cardano-node.
mkTimeHandle ::
  HasCallStack =>
  SlotNo ->
  SystemStart ->
  EraHistory ->
  TimeHandle
mkTimeHandle :: HasCallStack => SlotNo -> SystemStart -> EraHistory -> TimeHandle
mkTimeHandle SlotNo
currentSlotNo SystemStart
systemStart EraHistory
eraHistory = do
  TimeHandle
    { $sel:currentPointInTime:TimeHandle :: Either Text PointInTime
currentPointInTime = do
        UTCTime
pt <- HasCallStack => SlotNo -> Either Text UTCTime
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)
    , HasCallStack => UTCTime -> Either Text SlotNo
UTCTime -> Either Text SlotNo
$sel:slotFromUTCTime:TimeHandle :: UTCTime -> Either Text SlotNo
slotFromUTCTime :: HasCallStack => UTCTime -> Either Text SlotNo
slotFromUTCTime
    , HasCallStack => SlotNo -> Either Text UTCTime
SlotNo -> Either Text UTCTime
$sel:slotToUTCTime:TimeHandle :: SlotNo -> Either Text UTCTime
slotToUTCTime :: HasCallStack => SlotNo -> Either Text UTCTime
slotToUTCTime
    }
 where
  slotToUTCTime :: HasCallStack => SlotNo -> Either Text UTCTime
  slotToUTCTime :: HasCallStack => SlotNo -> Either Text UTCTime
slotToUTCTime SlotNo
slot =
    case Interpreter (CardanoEras StandardCrypto)
-> Qry (RelativeTime, SlotLength)
-> Either PastHorizonException (RelativeTime, SlotLength)
forall (xs :: [*]) a.
HasCallStack =>
Interpreter xs -> Qry a -> Either PastHorizonException a
interpretQuery Interpreter (CardanoEras StandardCrypto)
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

  slotFromUTCTime :: HasCallStack => UTCTime -> Either Text SlotNo
  slotFromUTCTime :: HasCallStack => UTCTime -> Either Text SlotNo
slotFromUTCTime UTCTime
utcTime = do
    let relativeTime :: RelativeTime
relativeTime = SystemStart -> UTCTime -> RelativeTime
toRelativeTime SystemStart
systemStart UTCTime
utcTime
    case Interpreter (CardanoEras StandardCrypto)
-> Qry (SlotNo, POSIXTime, POSIXTime)
-> Either PastHorizonException (SlotNo, POSIXTime, POSIXTime)
forall (xs :: [*]) a.
HasCallStack =>
Interpreter xs -> Qry a -> Either PastHorizonException a
interpretQuery Interpreter (CardanoEras StandardCrypto)
interpreter (RelativeTime -> Qry (SlotNo, POSIXTime, POSIXTime)
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, POSIXTime
_timeSpentInSlot, POSIXTime
_timeLeftInSlot) -> SlotNo -> Either Text SlotNo
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SlotNo
slotNo

  (EraHistory Interpreter xs
Interpreter (CardanoEras StandardCrypto)
interpreter) = EraHistory
eraHistory

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

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