Stuff

IntersectMBO · Sep 28, 2021 · ffc3854 · ffc3854
1 parent e9e4f1c
commit ffc3854
Show file tree

Hide file tree

Showing 4 changed files with 61 additions and 85 deletions.
diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs
@@ -611,9 +611,8 @@ module Cardano.Api (
     queryExpr,
     determineEraExpr,
 
-    Point(..),
-    pointToSlotNo,
-    pointToHeaderHash
+    chainPointToSlotNo,
+    chainPointToHeaderHash
 
   ) where
 

diff --git a/cardano-api/src/Cardano/Api/Query.hs b/cardano-api/src/Cardano/Api/Query.hs
@@ -52,9 +52,8 @@ module Cardano.Api.Query (
     toLedgerUTxO,
     fromLedgerUTxO,
 
-    Point(..),
-    pointToSlotNo,
-    pointToHeaderHash
+    chainPointToSlotNo,
+    chainPointToHeaderHash
   ) where
 
 import           Data.Aeson (ToJSON (..), object, (.=))
@@ -83,9 +82,7 @@ import           Ouroboros.Consensus.Cardano.Block (LedgerState (..), StandardCr
 import qualified Ouroboros.Consensus.Cardano.Block as Consensus
 import qualified Ouroboros.Consensus.Ledger.Query as Consensus
 import qualified Ouroboros.Consensus.Shelley.Ledger as Consensus
-import           Ouroboros.Network.Block (Serialised, HeaderHash)
-import qualified Ouroboros.Network.Block as Network
-import qualified Ouroboros.Network.Point as Network (Block (..))
+import           Ouroboros.Network.Block (Serialised)
 
 import           Cardano.Binary
 import           Cardano.Slotting.Slot (WithOrigin (..))
@@ -138,28 +135,16 @@ data QueryInMode mode result where
     :: QueryInMode mode (WithOrigin BlockNo)
 
   QueryChainPoint
-    :: QueryInMode mode (Point mode)
+    :: ConsensusMode mode
+    -> QueryInMode mode ChainPoint
 
-data Point mode where
-  Point
-    :: ConsensusBlockForMode mode ~ blk
-    => Network.Point blk
-    -> Point mode
+chainPointToSlotNo :: ChainPoint -> Maybe SlotNo
+chainPointToSlotNo ChainPointAtGenesis = Nothing
+chainPointToSlotNo (ChainPoint slotNo _) = Just slotNo
 
-pointToSlotNo :: Point mode -> WithOrigin SlotNo
-pointToSlotNo (Point (Network.Point Origin)) = Origin
-pointToSlotNo (Point (Network.Point (At (Network.Block slotNo _)))) = At slotNo
-
-pointToHeaderHash :: ConsensusBlockForMode mode ~ blk => Point mode -> WithOrigin (HeaderHash blk)
-pointToHeaderHash (Point (Network.Point Origin)) = Origin
-pointToHeaderHash (Point (Network.Point (At (Network.Block _ headerHash)))) = At headerHash
-
-instance
-    ( Show (HeaderHash blk)
-    , Network.StandardHash blk
-    , ConsensusBlockForMode mode ~ blk
-    ) => Show (Point mode) where
-  show (Point cPoint) = show cPoint
+chainPointToHeaderHash :: ChainPoint -> Maybe (Hash BlockHeader)
+chainPointToHeaderHash ChainPointAtGenesis = Nothing
+chainPointToHeaderHash (ChainPoint _ blockHeader) = Just blockHeader
 
 data EraHistory mode where
   EraHistory
@@ -407,7 +392,7 @@ toConsensusQuery QuerySystemStart = Some Consensus.GetSystemStart
 
 toConsensusQuery QueryChainBlockNo = Some Consensus.GetChainBlockNo
 
-toConsensusQuery QueryChainPoint = Some Consensus.GetChainPoint
+toConsensusQuery (QueryChainPoint _) = Some Consensus.GetChainPoint
 
 toConsensusQuery (QueryInEra ByronEraInCardanoMode QueryByronUpdateState) =
     Some $ Consensus.BlockQuery $
@@ -533,10 +518,10 @@ fromConsensusQueryResult QueryChainBlockNo q' r' =
         -> r'
       _ -> fromConsensusQueryResultMismatch
 
-fromConsensusQueryResult QueryChainPoint q' r' =
+fromConsensusQueryResult (QueryChainPoint mode) q' r' =
     case q' of
       Consensus.GetChainPoint
-        -> Point r'
+        -> fromConsensusPointInMode mode r'
       _ -> fromConsensusQueryResultMismatch
 
 fromConsensusQueryResult (QueryCurrentEra CardanoModeIsMultiEra) q' r' =

diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Output.hs b/cardano-cli/src/Cardano/CLI/Shelley/Output.hs
@@ -5,7 +5,6 @@ module Cardano.CLI.Shelley.Output
   ( QueryTipOutput(..)
   , QueryTipLocalState(..)
   , QueryTipLocalStateOutput(..)
-  , ChainTipInfo(..)
   ) where
 
 import           Cardano.Api
@@ -19,27 +18,20 @@ import           Data.Function (id, ($), (.))
 import           Data.Maybe
 import           Data.Monoid (mconcat)
 import           Shelley.Spec.Ledger.Scripts ()
-import           Text.Show (Show)
 
 import qualified Data.Aeson as J
 import qualified Data.Aeson.Encoding as JE
 
-data ChainTipInfo = ChainTipInfo
-  { mBlockNo :: BlockNo
-  , mSlotNo :: SlotNo
-  , mHeaderHash :: Text
-  } deriving Show
-
 data QueryTipOutput localState = QueryTipOutput
-  { mChainTip :: Maybe ChainTipInfo
+  { mLocalChainTip :: Maybe ChainTip
   , mLocalState :: Maybe localState
   }
 
 data QueryTipLocalState mode = QueryTipLocalState
   { era :: AnyCardanoEra
   , eraHistory :: EraHistory CardanoMode
   , mSystemStart :: Maybe SystemStart
-  , mChainTipInfo :: Maybe ChainTipInfo
+  , mChainTip :: Maybe ChainTip
   }
 
 data QueryTipLocalStateOutput = QueryTipLocalStateOutput
@@ -59,24 +51,36 @@ data QueryTipLocalStateOutput = QueryTipLocalStateOutput
   Nothing -> id
 
 instance ToJSON (QueryTipOutput QueryTipLocalStateOutput) where
-  toJSON a = case mChainTip a of
+  toJSON a = case mLocalChainTip a of
     Nothing -> J.Null
-    Just (ChainTipInfo slot bNum hh) ->
+    Just ChainTipAtGenesis ->
+      J.object $
+        ( ("era" ..=? (mLocalState a >>= mEra))
+        . ("epoch" ..=? (mLocalState a >>= mEpoch))
+        . ("syncProgress" ..=? (mLocalState a >>= mSyncProgress))
+        ) []
+    Just (ChainTip slotNo _blockHeader blockNo) ->
       J.object $
-        ( ("slot" ..= slot)
-        . ("hash" ..= hh)
-        . ("block" ..= bNum)
+        ( ("slot" ..= slotNo)
+        . ("hash" ..= ("TODO" :: Text)) -- blockHeader)
+        . ("block" ..= blockNo)
         . ("era" ..=? (mLocalState a >>= mEra))
         . ("epoch" ..=? (mLocalState a >>= mEpoch))
         . ("syncProgress" ..=? (mLocalState a >>= mSyncProgress))
         ) []
-  toEncoding a = case mChainTip a of
+  toEncoding a = case mLocalChainTip a of
     Nothing -> JE.null_
-    Just (ChainTipInfo slot bNum hh) ->
+    Just ChainTipAtGenesis ->
+      J.pairs $ mconcat $
+        ( ("era" ..=? (mLocalState a >>= mEra))
+        . ("epoch" ..=? (mLocalState a >>= mEpoch))
+        . ("syncProgress" ..=? (mLocalState a >>= mSyncProgress))
+        ) []
+    Just (ChainTip slotNo _blockHeader blockNo) ->
       J.pairs $ mconcat $
-        ( ("slot" ..= slot)
-        . ("hash" ..= hh)
-        . ("block" ..= bNum)
+        ( ("slot" ..= slotNo)
+        . ("hash" ..= ("TODO" :: Text)) -- blockHeader)
+        . ("block" ..= blockNo)
         . ("era" ..=? (mLocalState a >>= mEra))
         . ("epoch" ..=? (mLocalState a >>= mEpoch))
         . ("syncProgress" ..=? (mLocalState a >>= mSyncProgress))

diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs
@@ -36,20 +36,18 @@ import           Cardano.Ledger.Coin
 import           Cardano.Ledger.Crypto (StandardCrypto)
 import           Cardano.Ledger.Keys (KeyHash (..), KeyRole (..))
 import           Cardano.Prelude hiding (atomically)
-import           Cardano.Slotting.Slot (withOriginToMaybe)
+import           Cardano.Slotting.Slot (WithOrigin (..))
 import           Control.Monad.Trans.Except (except)
 import           Control.Monad.Trans.Except.Extra (firstExceptT, handleIOExceptT, hoistMaybe, left)
 import           Data.Aeson (ToJSON (..), (.=))
 import           Data.Aeson.Encode.Pretty (encodePretty)
 import           Data.List (nub)
 import           Data.Time.Clock
 import           Numeric (showEFloat)
-import           Ouroboros.Consensus.Block (ConvertRawHash (..))
 import           Ouroboros.Consensus.BlockchainTime.WallClock.Types (RelativeTime (..),
                    SystemStart (..), toRelativeTime)
 import           Ouroboros.Consensus.Cardano.Block as Consensus (EraMismatch (..))
-import           Ouroboros.Consensus.Cardano.Block (CardanoBlock)
-import           Ouroboros.Network.Block (HeaderHash, Serialised (..))
+import           Ouroboros.Network.Block (Serialised (..))
 import           Ouroboros.Network.Protocol.LocalStateQuery.Type (AcquireFailure (..))
 import           Prelude (String, id)
 import           Shelley.Spec.Ledger.EpochBoundary
@@ -75,17 +73,10 @@ import qualified Ouroboros.Network.Protocol.LocalStateQuery.Type as LocalStateQu
 import qualified Shelley.Spec.Ledger.API.Protocol as Ledger
 import qualified System.IO as IO
 
-import qualified Data.ByteString.Base16 as B16
-
 {- HLINT ignore "Reduce duplication" -}
 {- HLINT ignore "Use const" -}
 {- HLINT ignore "Use let" -}
 
--- | Hex encode and render a 'HeaderHash' as text.
-renderHeaderHash :: (ConvertRawHash blk, blk ~ CardanoBlock StandardCrypto) => proxy blk -> HeaderHash blk -> Text
-renderHeaderHash p = Text.decodeLatin1 . B16.encode . toRawHash p
-
-
 data ShelleyQueryCmdError
   = ShelleyQueryCmdEnvVarSocketErr !EnvSocketError
   | ShelleyQueryCmdLocalStateQueryError !ShelleyQueryCmdLocalStateQueryError
@@ -211,19 +202,11 @@ relativeTimeSeconds (RelativeTime dt) = floor (nominalDiffTimeToSeconds dt)
 -- | Query the chain tip via the chain sync protocol.
 --
 -- This is a fallback query to support older versions of node to client protocol.
-queryChainTipViaChainSync :: MonadIO m => LocalNodeConnectInfo mode -> m (Maybe O.ChainTipInfo)
+queryChainTipViaChainSync :: MonadIO m => LocalNodeConnectInfo mode -> m ChainTip
 queryChainTipViaChainSync localNodeConnInfo = do
   liftIO . T.hPutStrLn IO.stderr $
     "Warning: Local header state query unavailable. Falling back to chain sync query"
-  ct <- liftIO $ getLocalChainTip localNodeConnInfo
-  case ct of
-    ChainTipAtGenesis -> return Nothing
-    ChainTip slotNo hash blockNo ->
-      return $ Just O.ChainTipInfo
-        { O.mSlotNo = slotNo
-        , O.mHeaderHash = serialiseToRawBytesHexText hash
-        , O.mBlockNo = blockNo
-        }
+  liftIO $ getLocalChainTip localNodeConnInfo
 
 runQueryTip
   :: AnyConsensusModeParams
@@ -244,38 +227,35 @@ runQueryTip (AnyConsensusModeParams cModeParams) network mOutFile = do
           then Just <$> queryExpr QueryChainBlockNo
           else return Nothing
         mChainPoint <- if ntcVersion >= NodeToClientV_10
-          then Just <$> queryExpr QueryChainPoint
+          then Just <$> queryExpr (QueryChainPoint CardanoMode)
           else return Nothing
         mSystemStart <- if ntcVersion >= NodeToClientV_9
           then Just <$> queryExpr QuerySystemStart
           else return Nothing
 
-        let mChainTipInfo = O.ChainTipInfo
-              <$> join (fmap withOriginToMaybe mChainBlockNo)
-              <*> join (withOriginToMaybe . pointToSlotNo <$> mChainPoint)
-              <*> join (fmap (renderHeaderHash Proxy) . withOriginToMaybe . pointToHeaderHash <$> mChainPoint)
         return O.QueryTipLocalState
           { O.era = era
           , O.eraHistory = eraHistory
           , O.mSystemStart = mSystemStart
-          , O.mChainTipInfo = mChainTipInfo
+          , O.mChainTip = makeChainTip <$> mChainBlockNo <*> mChainPoint
           }
 
       mLocalState <- hushM (first ShelleyQueryCmdAcquireFailure eLocalState) $ \e ->
         liftIO . T.hPutStrLn IO.stderr $ "Warning: Local state unavailable: " <> renderShelleyQueryCmdError e
 
-      mChainTip <- case mLocalState >>= O.mChainTipInfo of
-        Just chainTipInfo -> return $ Just chainTipInfo
+      mChainTip <- case mLocalState >>= O.mChainTip of
+        Just chainTip -> return $ Just chainTip
         Nothing ->
           -- The chain tip is unavailable via local state query because we are connecting with an older
           -- node to client protocol so we use chain sync instead which necessitates another connection.
           -- At some point when we can stop supporting the older node to client protocols, this fallback
           -- can be removed.
-          queryChainTipViaChainSync localNodeConnInfo
+          Just <$> queryChainTipViaChainSync localNodeConnInfo
 
-      let tipSlotNo = case mChainTip of
+      let tipSlotNo :: SlotNo = case mChainTip of
             Nothing -> 0
-            Just (O.ChainTipInfo _ slotNo _) -> slotNo
+            Just ChainTipAtGenesis -> 0
+            Just (ChainTip slotNo _ _) -> slotNo
 
       mLocalStateOutput :: Maybe O.QueryTipLocalStateOutput <- fmap join . forM mLocalState $ \localState -> do
         case slotToEpoch tipSlotNo (O.eraHistory localState) of
@@ -304,7 +284,7 @@ runQueryTip (AnyConsensusModeParams cModeParams) network mOutFile = do
 
 
       let jsonOutput = encodePretty $ O.QueryTipOutput
-            { O.mChainTip = mChainTip
+            { O.mLocalChainTip = mChainTip
             , O.mLocalState = mLocalStateOutput
             }
 
@@ -314,6 +294,14 @@ runQueryTip (AnyConsensusModeParams cModeParams) network mOutFile = do
 
     mode -> left (ShelleyQueryCmdUnsupportedMode (AnyConsensusMode mode))
 
+
+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
+
 -- | Query the UTxO, filtered by a given set of addresses, from a Shelley node
 -- via the local state query protocol.
 --