Merge #3179

3179: Use new GetChainBlockNo and GetChainPoint queries in query tip r=newhoggy a=newhoggy



Co-authored-by: John Ky <[email protected]>

cardano-api/src/Cardano/Api.hs

@@ -609,7 +609,12 @@ module Cardano.Api (
     executeLocalStateQueryExpr,
     executeLocalStateQueryExprWithChainSync,
     queryExpr,
-    determineEraExpr
+    determineEraExpr,
+
+    chainPointToSlotNo,
+    chainPointToHeaderHash,
+    makeChainTip
+
   ) where
 
 import           Cardano.Api.Address

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

@@ -38,6 +38,10 @@ module Cardano.Api.Block (
 
     -- * Data family instances
     Hash(..),
+
+    chainPointToHeaderHash,
+    chainPointToSlotNo,
+    makeChainTip,
   ) where
 
 import           Prelude
@@ -49,7 +53,7 @@ import qualified Data.ByteString.Short as SBS
 import           Data.Foldable (Foldable (toList))
 
 import           Cardano.Slotting.Block (BlockNo)
-import           Cardano.Slotting.Slot (EpochNo, SlotNo)
+import           Cardano.Slotting.Slot (EpochNo, SlotNo, WithOrigin (..))
 
 import qualified Cardano.Crypto.Hash.Class
 import qualified Cardano.Crypto.Hashing
@@ -343,6 +347,14 @@ fromConsensusPoint (Consensus.BlockPoint slot h) =
     proxy :: Proxy (Consensus.ShelleyBlock ledgerera)
     proxy = Proxy
 
+chainPointToSlotNo :: ChainPoint -> Maybe SlotNo
+chainPointToSlotNo ChainPointAtGenesis = Nothing
+chainPointToSlotNo (ChainPoint slotNo _) = Just slotNo
+
+chainPointToHeaderHash :: ChainPoint -> Maybe (Hash BlockHeader)
+chainPointToHeaderHash ChainPointAtGenesis = Nothing
+chainPointToHeaderHash (ChainPoint _ blockHeader) = Just blockHeader
+
 
 -- ----------------------------------------------------------------------------
 -- Chain tips
@@ -369,6 +381,12 @@ chainTipToChainPoint :: ChainTip -> ChainPoint
 chainTipToChainPoint ChainTipAtGenesis = ChainPointAtGenesis
 chainTipToChainPoint (ChainTip s h _)  = ChainPoint s h
 
+makeChainTip :: WithOrigin BlockNo -> ChainPoint -> ChainTip
+makeChainTip woBlockNo chainPoint = case woBlockNo of
+  Origin -> ChainTipAtGenesis
+  At blockNo -> case chainPoint of
+    ChainPointAtGenesis -> ChainTipAtGenesis
+    ChainPoint slotNo headerHash -> ChainTip slotNo headerHash blockNo
 
 fromConsensusTip  :: ConsensusBlockForMode mode ~ block
                   => ConsensusMode mode

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

@@ -114,7 +114,6 @@ import           Cardano.Api.Protocol.Types
 import           Cardano.Api.Query
 import           Cardano.Api.TxInMode
 
-
 -- ----------------------------------------------------------------------------
 -- The types for the client side of the node-to-client IPC protocols
 --
@@ -217,8 +216,8 @@ connectToLocalNodeWithVersion LocalNodeConnectInfo {
 
 
 mkVersionedProtocols :: forall block.
-                        ( Consensus.ShowQuery (Consensus.Query block),
-                          ProtocolClient block
+                        ( Consensus.ShowQuery (Consensus.Query block)
+                        , ProtocolClient block
                         )
                      => NetworkId
                      -> ProtocolClientInfoArgs block
@@ -578,4 +577,3 @@ chainSyncGetCurrentTip tipVar =
         void $ atomically $ tryPutTMVar tipVar tip
         pure $ Net.Sync.SendMsgDone ()
     }
-

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

@@ -51,6 +51,7 @@ module Cardano.Api.Query (
     -- * Internal conversion functions
     toLedgerUTxO,
     fromLedgerUTxO,
+
   ) where
 
 import           Data.Aeson (ToJSON (..), object, (.=))
@@ -82,6 +83,7 @@ import qualified Ouroboros.Consensus.Shelley.Ledger as Consensus
 import           Ouroboros.Network.Block (Serialised)
 
 import           Cardano.Binary
+import           Cardano.Slotting.Slot (WithOrigin (..))
 import           Cardano.Slotting.Time (SystemStart (..))
 
 import qualified Cardano.Chain.Update.Validation.Interface as Byron.Update
@@ -127,6 +129,13 @@ data QueryInMode mode result where
   QuerySystemStart
     :: QueryInMode mode SystemStart
 
+  QueryChainBlockNo
+    :: QueryInMode mode (WithOrigin BlockNo)
+
+  QueryChainPoint
+    :: ConsensusMode mode
+    -> QueryInMode mode ChainPoint
+
 data EraHistory mode where
   EraHistory
     :: ConsensusBlockForMode mode ~ Consensus.HardForkBlock xs
@@ -164,9 +173,6 @@ deriving instance Show (QueryInEra era result)
 
 
 data QueryInShelleyBasedEra era result where
-     QueryChainPoint
-       :: QueryInShelleyBasedEra era ChainPoint
-
      QueryEpoch
        :: QueryInShelleyBasedEra era EpochNo
 
@@ -374,6 +380,10 @@ toConsensusQuery (QueryEraHistory CardanoModeIsMultiEra) =
 
 toConsensusQuery QuerySystemStart = Some Consensus.GetSystemStart
 
+toConsensusQuery QueryChainBlockNo = Some Consensus.GetChainBlockNo
+
+toConsensusQuery (QueryChainPoint _) = Some Consensus.GetChainPoint
+
 toConsensusQuery (QueryInEra ByronEraInCardanoMode QueryByronUpdateState) =
     Some $ Consensus.BlockQuery $
       Consensus.QueryIfCurrentByron
@@ -399,9 +409,6 @@ toConsensusQueryShelleyBased
   => EraInMode era mode
   -> QueryInShelleyBasedEra era result
   -> Some (Consensus.Query block)
-toConsensusQueryShelleyBased erainmode QueryChainPoint =
-    Some (consensusQueryInEraInMode erainmode Consensus.GetLedgerTip)
-
 toConsensusQueryShelleyBased erainmode QueryEpoch =
     Some (consensusQueryInEraInMode erainmode Consensus.GetEpochNo)
 
@@ -478,8 +485,7 @@ consensusQueryInEraInMode erainmode =
 -- Conversions of query results from the consensus types.
 --
 
-fromConsensusQueryResult :: forall mode block result result'.
-                            ConsensusBlockForMode mode ~ block
+fromConsensusQueryResult :: forall mode block result result'. ConsensusBlockForMode mode ~ block
                          => QueryInMode mode result
                          -> Consensus.Query block result'
                          -> result'
@@ -496,6 +502,18 @@ fromConsensusQueryResult QuerySystemStart q' r' =
         -> r'
       _ -> fromConsensusQueryResultMismatch
 
+fromConsensusQueryResult QueryChainBlockNo q' r' =
+    case q' of
+      Consensus.GetChainBlockNo
+        -> r'
+      _ -> fromConsensusQueryResultMismatch
+
+fromConsensusQueryResult (QueryChainPoint mode) q' r' =
+    case q' of
+      Consensus.GetChainPoint
+        -> fromConsensusPointInMode mode r'
+      _ -> fromConsensusQueryResultMismatch
+
 fromConsensusQueryResult (QueryCurrentEra CardanoModeIsMultiEra) q' r' =
     case q' of
       Consensus.BlockQuery (Consensus.QueryHardFork Consensus.GetCurrentEra)
@@ -578,18 +596,12 @@ fromConsensusQueryResult (QueryInEra AlonzoEraInCardanoMode
 fromConsensusQueryResultShelleyBased
   :: forall era ledgerera result result'.
      ShelleyLedgerEra era ~ ledgerera
-  => Consensus.ShelleyBasedEra ledgerera
   => Ledger.Crypto ledgerera ~ Consensus.StandardCrypto
   => ShelleyBasedEra era
   -> QueryInShelleyBasedEra era result
   -> Consensus.BlockQuery (Consensus.ShelleyBlock ledgerera) result'
   -> result'
   -> result
-fromConsensusQueryResultShelleyBased _ QueryChainPoint q' point =
-    case q' of
-      Consensus.GetLedgerTip -> fromConsensusPoint point
-      _                      -> fromConsensusQueryResultMismatch
-
 fromConsensusQueryResultShelleyBased _ QueryEpoch q' epoch =
     case q' of
       Consensus.GetEpochNo -> epoch

cardano-cli/src/Cardano/CLI/Shelley/Output.hs

@@ -2,41 +2,33 @@
 {-# LANGUAGE FlexibleInstances #-}
 
 module Cardano.CLI.Shelley.Output
-  ( QueryTipOutput(..)
-  , QueryTipLocalState(..)
+  ( QueryTipLocalState(..)
   , QueryTipLocalStateOutput(..)
   ) where
 
 import           Cardano.Api
 
 import           Cardano.CLI.Shelley.Orphans ()
-import           Cardano.Prelude (Either, Text)
-import           Cardano.Slotting.EpochInfo (EpochInfo)
+import           Cardano.Prelude (Text)
 import           Cardano.Slotting.Time (SystemStart (..))
-import           Control.Monad
 import           Data.Aeson (KeyValue, ToJSON (..), (.=))
 import           Data.Function (id, ($), (.))
-import           Data.Maybe
+import           Data.Maybe ( Maybe(..) )
 import           Data.Monoid (mconcat)
 import           Shelley.Spec.Ledger.Scripts ()
 
 import qualified Data.Aeson as J
-import qualified Data.Aeson.Encoding as JE
 
-data QueryTipOutput localState = QueryTipOutput
-  { chainTip :: ChainTip
-  , mLocalState :: Maybe localState
-  }
-
-data QueryTipLocalState = QueryTipLocalState
+data QueryTipLocalState mode = QueryTipLocalState
   { era :: AnyCardanoEra
   , eraHistory :: EraHistory CardanoMode
   , mSystemStart :: Maybe SystemStart
-  , epochInfo :: EpochInfo (Either TransactionValidityIntervalError)
+  , mChainTip :: Maybe ChainTip
   }
 
 data QueryTipLocalStateOutput = QueryTipLocalStateOutput
-  { mEra :: Maybe AnyCardanoEra
+  { localStateChainTip :: ChainTip
+  , mEra :: Maybe AnyCardanoEra
   , mEpoch :: Maybe EpochNo
   , mSyncProgress :: Maybe Text
   }
@@ -51,26 +43,36 @@ data QueryTipLocalStateOutput = QueryTipLocalStateOutput
   Just v -> (n .= v:)
   Nothing -> id
 
-instance ToJSON (QueryTipOutput QueryTipLocalStateOutput) where
-  toJSON a = case chainTip a of
-    ChainTipAtGenesis -> J.Null
-    ChainTip slot headerHash (BlockNo bNum) ->
+instance ToJSON QueryTipLocalStateOutput where
+  toJSON a = case localStateChainTip a of
+    ChainTipAtGenesis ->
+      J.object $
+        ( ("era" ..=? mEra a)
+        . ("epoch" ..=? mEpoch a)
+        . ("syncProgress" ..=? mSyncProgress a)
+        ) []
+    ChainTip slotNo blockHeader blockNo ->
       J.object $
-        ( ("slot" ..= slot)
-        . ("hash" ..= serialiseToRawBytesHexText headerHash)
-        . ("block" ..= bNum)
-        . ("era" ..=? (mLocalState a >>= mEra))
-        . ("epoch" ..=? (mLocalState a >>= mEpoch))
-        . ("syncProgress" ..=? (mLocalState a >>= mSyncProgress))
+        ( ("slot" ..= slotNo)
+        . ("hash" ..= serialiseToRawBytesHexText blockHeader)
+        . ("block" ..= blockNo)
+        . ("era" ..=? mEra a)
+        . ("epoch" ..=? mEpoch a)
+        . ("syncProgress" ..=? mSyncProgress a)
+        ) []
+  toEncoding a = case localStateChainTip a of
+    ChainTipAtGenesis ->
+      J.pairs $ mconcat $
+        ( ("era" ..=? mEra a)
+        . ("epoch" ..=? mEpoch a)
+        . ("syncProgress" ..=? mSyncProgress a)
         ) []
-  toEncoding a = case chainTip a of
-    ChainTipAtGenesis -> JE.null_
-    ChainTip slot headerHash (BlockNo bNum) ->
+    ChainTip slotNo blockHeader blockNo ->
       J.pairs $ mconcat $
-        ( ("slot" ..= slot)
-        . ("hash" ..= serialiseToRawBytesHexText headerHash)
-        . ("block" ..= bNum)
-        . ("era" ..=? (mLocalState a >>= mEra))
-        . ("epoch" ..=? (mLocalState a >>= mEpoch))
-        . ("syncProgress" ..=? (mLocalState a >>= mSyncProgress))
+        ( ("slot" ..= slotNo)
+        . ("hash" ..= serialiseToRawBytesHexText blockHeader)
+        . ("block" ..= blockNo)
+        . ("era" ..=? mEra a)
+        . ("epoch" ..=? mEpoch a)
+        . ("syncProgress" ..=? mSyncProgress a)
         ) []