gRPC: add tip timestamp to ChainPoint response

cardano-api/src/Cardano/Api/Internal/Orphans/Misc.hs

@@ -31,6 +31,12 @@ import Cardano.Ledger.HKD (NoUpdate (..))
 import Cardano.Ledger.Plutus.Language qualified as L
 import Cardano.Ledger.Shelley.PParams qualified as Ledger
 import Ouroboros.Consensus.Cardano.Block (EraMismatch (..))
+import Ouroboros.Consensus.HardFork.History.Qry (PastHorizonException (..))
+import Ouroboros.Consensus.HardFork.History.Summary
+  ( Bound (..)
+  , EraEnd (..)
+  , EraSummary (..)
+  )
 import PlutusLedgerApi.Common qualified as P
 
 import Codec.Binary.Bech32 qualified as Bech32
@@ -44,7 +50,9 @@ import Data.Text.Encoding.Error qualified as T
 import Data.Type.Equality
 import Data.Typeable
 import GHC.Exts (IsList (..))
+import GHC.Stack (prettyCallStack)
 import Network.Mux qualified as Mux
+import Prettyprinter (indent)
 import Text.Parsec.Error qualified as P
 
 deriving instance Data DecoderError
@@ -299,6 +307,28 @@ instance Error Byron.GenesisDataGenerationError where
 instance Error P.ParseError where
   prettyError = pretty . show
 
+instance Error PastHorizonException where
+  prettyError e =
+    vsep
+      [ "Past horizon! Tried to convert a slot/time past the point where the"
+          <+> "hard fork history is known."
+      , mempty
+      , "Expression:" <+> pshow (pastHorizonExpression e)
+      , mempty
+      , "Era summary (" <> pretty (length $ pastHorizonSummary e) <+> "eras):"
+      , indent 2 . vsep $ zipWith prettyEraSummary [1 :: Int ..] (pastHorizonSummary e)
+      , mempty
+      , "Call stack:"
+      , indent 2 . pretty . prettyCallStack $ pastHorizonCallStack e
+      ]
+   where
+    prettyEraSummary i era =
+      "Era" <+> pretty i <> ":" <+> prettyBound (eraStart era) <+> "-" <+> prettyEraEnd (eraEnd era)
+    prettyBound bound =
+      "slot" <+> pshow (boundSlot bound) <> "," <+> "epoch" <+> pshow (boundEpoch bound)
+    prettyEraEnd EraUnbounded = "unbounded"
+    prettyEraEnd (EraEnd bound) = prettyBound bound
+
 deriving via ShowOf TypeRep instance Pretty TypeRep
 
 instance TestEquality L.SLanguage where

cardano-api/src/Cardano/Api/Query.hs

@@ -37,6 +37,7 @@ module Cardano.Api.Query
   , LedgerState (..)
   , getProgress
   , getSlotForRelativeTime
+  , slotToUTCTime
   , decodeLedgerPeerSnapshot
 
     -- * Convenience functions

cardano-api/src/Cardano/Api/Query/Internal/Type/QueryInMode.hs

@@ -58,6 +58,7 @@ module Cardano.Api.Query.Internal.Type.QueryInMode
   , LedgerState (..)
   , getProgress
   , getSlotForRelativeTime
+  , slotToUTCTime
   , decodeLedgerPeerSnapshot
 
     -- * Internal conversion functions
@@ -102,7 +103,7 @@ import Cardano.Ledger.Shelley.API qualified as Shelley
 import Cardano.Ledger.Shelley.Core qualified as Core
 import Cardano.Slotting.EpochInfo (hoistEpochInfo)
 import Cardano.Slotting.Slot (WithOrigin (..))
-import Cardano.Slotting.Time (SystemStart (..))
+import Cardano.Slotting.Time (SystemStart (..), fromRelativeTime)
 import Ouroboros.Consensus.BlockchainTime.WallClock.Types (RelativeTime, SlotLength)
 import Ouroboros.Consensus.Byron.Ledger qualified as Consensus
 import Ouroboros.Consensus.Cardano.Block (LedgerState (..), StandardCrypto)
@@ -140,6 +141,7 @@ import Data.Set qualified as Set
 import Data.Singletons qualified as Singletons
 import Data.Text (Text)
 import Data.Text qualified as Text
+import Data.Time (UTCTime)
 import Data.Word (Word64)
 import GHC.Exts (IsList (..))
 import GHC.Stack
@@ -210,6 +212,17 @@ getSlotForRelativeTime relTime (EraHistory interpreter) = do
   (slotNo, _, _) <- Qry.interpretQuery interpreter $ Qry.wallclockToSlot relTime
   pure slotNo
 
+-- | Convert a 'SlotNo' to a 'UTCTime' given the 'SystemStart' and 'EraHistory'.
+slotToUTCTime
+  :: ()
+  => SystemStart
+  -> EraHistory
+  -> SlotNo
+  -> Either Qry.PastHorizonException UTCTime
+slotToUTCTime systemStart eraHistory slotNo = do
+  (relTime, _slotLen) <- getProgress slotNo eraHistory
+  pure $ fromRelativeTime systemStart relTime
+
 newtype LedgerEpochInfo = LedgerEpochInfo {unLedgerEpochInfo :: Consensus.EpochInfo (Either Text)}
 
 toLedgerEpochInfo

cardano-rpc/cardano-rpc.cabal

@@ -92,6 +92,7 @@ library
     random,
     rio,
     text,
+    time,
 
 -- this should be replaced by utxorpc package from hackage
 -- ideally we should upstream whatever is implemented in Proto.Cardano.Rpc.Node
@@ -132,6 +133,7 @@ test-suite cardano-rpc-test
     rio,
     tasty,
     tasty-hedgehog,
+    time,
 
   ghc-options:
     -threaded

cardano-rpc/src/Cardano/Rpc/Server/Internal/UtxoRpc/Query.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE QuantifiedConstraints #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -27,6 +28,7 @@ import RIO hiding (toList)
 
 import Data.Default
 import Data.ProtoLens (defMessage)
+import Data.Time.Clock (UTCTime)
 import GHC.IsList
 import Network.GRPC.Spec
 
@@ -44,15 +46,19 @@ readParamsMethod _req = do
   let sbe = convert eon
 
   let target = VolatileTip
-  (pparams, chainPoint, blockNo) <- liftIO . (throwEither =<<) $ executeLocalStateQueryExpr nodeConnInfo target $ do
+  (pparams, chainPoint, blockNo, systemStart, eraHistory) <- liftIO . (throwEither =<<) $ executeLocalStateQueryExpr nodeConnInfo target $ do
     pparams <- throwEither =<< throwEither =<< queryProtocolParameters sbe
     chainPoint <- throwEither =<< queryChainPoint
     blockNo <- throwEither =<< queryChainBlockNo
-    pure (pparams, chainPoint, blockNo)
+    systemStart <- throwEither =<< querySystemStart
+    eraHistory <- throwEither =<< queryEraHistory
+    pure (pparams, chainPoint, blockNo, systemStart, eraHistory)
+
+  timestamp <- slotToTimestamp systemStart eraHistory chainPoint
 
   pure $
     def
-      & U5c.ledgerTip .~ mkChainPointMsg chainPoint blockNo
+      & U5c.ledgerTip .~ mkChainPointMsg chainPoint blockNo timestamp
       & U5c.values . U5c.cardano .~ obtainCommonConstraints eon (protocolParamsToUtxoRpcPParams eon pparams)
 
 readUtxosMethod
@@ -73,15 +79,19 @@ readUtxosMethod req = do
   eon <- forEraInEon @Era era (error "Minimum Conway era required") pure
 
   let target = VolatileTip
-  (utxo, chainPoint, blockNo) <- liftIO . (throwEither =<<) $ executeLocalStateQueryExpr nodeConnInfo target $ do
+  (utxo, chainPoint, blockNo, systemStart, eraHistory) <- liftIO . (throwEither =<<) $ executeLocalStateQueryExpr nodeConnInfo target $ do
     utxo <- throwEither =<< throwEither =<< queryUtxo (convert eon) utxoFilter
     chainPoint <- throwEither =<< queryChainPoint
     blockNo <- throwEither =<< queryChainBlockNo
-    pure (utxo, chainPoint, blockNo)
+    systemStart <- throwEither =<< querySystemStart
+    eraHistory <- throwEither =<< queryEraHistory
+    pure (utxo, chainPoint, blockNo, systemStart, eraHistory)
+
+  timestamp <- slotToTimestamp systemStart eraHistory chainPoint
 
   pure $
     defMessage
-      & U5c.ledgerTip .~ mkChainPointMsg chainPoint blockNo
+      & U5c.ledgerTip .~ mkChainPointMsg chainPoint blockNo timestamp
       & U5c.items .~ obtainCommonConstraints eon (utxoToUtxoRpcAnyUtxoData utxo)
  where
   txoRefToTxIn :: MonadRpc e m => Proto UtxoRpc.TxoRef -> m TxIn
@@ -93,3 +103,13 @@ readUtxosMethod req = do
 -- readAddress :: MonadRpc e m => ByteString -> m AddressAny
 -- readAddress =
 --   throwEither . first stringException . P.runParser parseAddressAny <=< throwEither . T.decodeUtf8'
+
+slotToTimestamp
+  :: HasCallStack
+  => MonadIO m
+  => SystemStart -> EraHistory -> ChainPoint -> m UTCTime
+slotToTimestamp systemStart eraHistory = \case
+  ChainPointAtGenesis ->
+    let SystemStart t = systemStart in pure t
+  ChainPoint slotNo _ ->
+    throwEither $ slotToUTCTime systemStart eraHistory slotNo

cardano-rpc/src/Cardano/Rpc/Server/Internal/UtxoRpc/Type.hs

@@ -19,6 +19,7 @@ module Cardano.Rpc.Server.Internal.UtxoRpc.Type
   , simpleScriptToUtxoRpcNativeScript
   , utxoRpcBigIntToInteger
   , mkChainPointMsg
+  , utxoRpcChainPointMsgToChainPoint
   )
 where
 
@@ -56,6 +57,8 @@ import Data.Map.Strict qualified as M
 import Data.ProtoLens (defMessage)
 import Data.Text qualified as T
 import Data.Text.Encoding qualified as T
+import Data.Time.Clock (UTCTime)
+import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
 import GHC.IsList
 import Network.GRPC.Spec
 
@@ -331,18 +334,44 @@ utxoRpcPParamsToProtocolParams era pp = conwayEraOnwardsConstraints (convert era
 mkChainPointMsg
   :: ChainPoint
   -> WithOrigin BlockNo
+  -> UTCTime
   -> Proto UtxoRpc.ChainPoint
-mkChainPointMsg chainPoint blockNo = do
+mkChainPointMsg chainPoint blockNo timestamp = do
   let (slotNo, blockHash) = case chainPoint of
         ChainPointAtGenesis -> (0, mempty)
         ChainPoint (SlotNo slot) (HeaderHash hash) -> (slot, SBS.fromShort hash)
       blockHeight = case blockNo of
         Origin -> 0
         At (BlockNo h) -> h
+      timestampMs = round . (* 1000) . utcTimeToPOSIXSeconds $ timestamp
   defMessage
     & U5c.slot .~ slotNo
     & U5c.hash .~ blockHash
     & U5c.height .~ blockHeight
+    & U5c.timestamp .~ timestampMs
+
+-- | Inverse of 'mkChainPointMsg'. Note: @Origin@ and @At (BlockNo 0)@ both
+-- encode to @height=0@, so the decode always maps @0@ back to @Origin@.
+utxoRpcChainPointMsgToChainPoint
+  :: HasCallStack
+  => MonadThrow m
+  => Proto UtxoRpc.ChainPoint
+  -> m (ChainPoint, WithOrigin BlockNo, UTCTime)
+utxoRpcChainPointMsgToChainPoint msg = do
+  let slot = msg ^. U5c.slot
+      blockHash = msg ^. U5c.hash
+      blockHeight = msg ^. U5c.height
+      timestamp = posixSecondsToUTCTime . (/ 1000) . fromIntegral $ msg ^. U5c.timestamp
+  chainPoint <-
+    if slot == 0 && blockHash == mempty
+      then pure ChainPointAtGenesis
+      else do
+        headerHash <- liftEitherError $ deserialiseFromRawBytes (AsHash asType) blockHash
+        pure $ ChainPoint (SlotNo slot) headerHash
+  let blockNo
+        | blockHeight == 0 = Origin
+        | otherwise = At (BlockNo blockHeight)
+  pure (chainPoint, blockNo, timestamp)
 
 simpleScriptToUtxoRpcNativeScript :: SimpleScript -> Proto UtxoRpc.NativeScript
 simpleScriptToUtxoRpcNativeScript = \case

cardano-rpc/test/cardano-rpc-test/Test/Cardano/Rpc/Type.hs

@@ -4,11 +4,18 @@
 
 module Test.Cardano.Rpc.Type where
 
+import Cardano.Api (BlockNo (..), ChainPoint (..), SlotNo (..))
 import Cardano.Api.Experimental.Era
 import Cardano.Rpc.Server.Internal.UtxoRpc.Type
 
+import Cardano.Ledger.BaseTypes (WithOrigin (..))
+
 import RIO
 
+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
+
+import Test.Gen.Cardano.Api.Typed (genBlockHeaderHash)
+
 import Hedgehog as H
 import Hedgehog.Extras qualified as H
 import Hedgehog.Gen qualified as H
@@ -28,6 +35,44 @@ hprop_roundtrip_bigint = H.property $ do
   H.note_ "Check that BigInt -> Integer -> BigInt preserves the value"
   bigInt === bigInt'
 
+-- | Test that ChainPoint protobuf message roundtrips, including the timestamp field.
+-- Note: @At (BlockNo 0)@ is excluded because it encodes identically to @Origin@.
+hprop_roundtrip_chain_point_msg :: Property
+hprop_roundtrip_chain_point_msg = H.property $ do
+  chainPoint <- forAll genChainPoint
+  blockNo <- forAll genWithOriginBlockNo
+  -- Generate from Word64 milliseconds directly to stay in range and at ms precision
+  timestamp <-
+    forAll $
+      posixSecondsToUTCTime . (/ 1000) . fromIntegral
+        <$> H.word64 (H.linearFrom 0 0 maxBound)
+
+  H.tripping
+    (chainPoint, blockNo, timestamp)
+    (uncurry3 mkChainPointMsg)
+    (first @Either displayException . utxoRpcChainPointMsgToChainPoint)
+ where
+  uncurry3 f (a, b, c) = f a b c
+
+-- | Generate a 'ChainPoint', avoiding @ChainPoint (SlotNo 0) hash@ which is
+-- ambiguous with 'ChainPointAtGenesis' after protobuf encoding (both map to
+-- @slot=0, hash=empty@).
+genChainPoint :: Gen ChainPoint
+genChainPoint =
+  H.choice
+    [ pure ChainPointAtGenesis
+    , ChainPoint . SlotNo <$> H.word64 (H.linear 1 maxBound) <*> genBlockHeaderHash
+    ]
+
+-- | Generate a @WithOrigin BlockNo@, excluding @At (BlockNo 0)@ which is
+-- ambiguous with 'Origin' after protobuf encoding (both map to @height=0@).
+genWithOriginBlockNo :: Gen (WithOrigin BlockNo)
+genWithOriginBlockNo =
+  H.choice
+    [ pure Origin
+    , At . BlockNo <$> H.word64 (H.linear 1 maxBound)
+    ]
+
 -- generate integer for each of the BigInt proto type constructors
 genLargeInteger :: Gen Integer
 genLargeInteger =