-- | 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),
  NetworkId,
  SocketPath,
 )
import Hydra.Cardano.Api.Prelude (ChainPoint (ChainPoint, ChainPointAtGenesis))
import Hydra.Chain.CardanoClient (
  QueryPoint (QueryTip),
  queryEraHistory,
  querySystemStart,
  queryTip,
 )
import Hydra.Ledger.Cardano.Evaluate (eraHistoryWithHorizonAt)
import Hydra.Tx.Contest (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 node for system start and era history before constructing a
-- 'TimeHandle' using the slot at the tip of the network.
queryTimeHandle :: NetworkId -> SocketPath -> IO TimeHandle
queryTimeHandle :: NetworkId -> SocketPath -> IO TimeHandle
queryTimeHandle NetworkId
networkId SocketPath
socketPath = do
  ChainPoint
tip <- NetworkId -> SocketPath -> IO ChainPoint
queryTip NetworkId
networkId SocketPath
socketPath
  SystemStart
systemStart <- NetworkId -> SocketPath -> QueryPoint -> IO SystemStart
querySystemStart NetworkId
networkId SocketPath
socketPath QueryPoint
QueryTip
  EraHistory
eraHistory <- NetworkId -> SocketPath -> QueryPoint -> IO EraHistory
queryEraHistory NetworkId
networkId SocketPath
socketPath 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