diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Commands.hs b/cardano-cli/src/Cardano/CLI/Shelley/Commands.hs index 50a50267e08..d5540e68e0b 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Commands.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Commands.hs @@ -338,7 +338,8 @@ renderPoolCmd cmd = PoolMetadataHash {} -> "stake-pool metadata-hash" data QueryCmd = - QueryProtocolParameters' AnyConsensusModeParams NetworkId (Maybe OutputFile) + QueryLeadershipSchedule AnyConsensusModeParams NetworkId FilePath (Hash StakePoolKey) FilePath + | QueryProtocolParameters' AnyConsensusModeParams NetworkId (Maybe OutputFile) | QueryTip AnyConsensusModeParams NetworkId (Maybe OutputFile) | QueryStakePools' AnyConsensusModeParams NetworkId (Maybe OutputFile) | QueryStakeDistribution' AnyConsensusModeParams NetworkId (Maybe OutputFile) @@ -353,6 +354,7 @@ data QueryCmd = renderQueryCmd :: QueryCmd -> Text renderQueryCmd cmd = case cmd of + QueryLeadershipSchedule {} -> "query leadership-schedule" QueryProtocolParameters' {} -> "query protocol-parameters " QueryTip {} -> "query tip" QueryStakePools' {} -> "query stake-pools" diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs index 777905090ea..dc4c07f6c03 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs @@ -23,34 +23,43 @@ module Cardano.CLI.Shelley.Run.Query , executeQuery ) where +import Cardano.Prelude import Prelude (String, id) import Cardano.Api import Cardano.Api.Byron import Cardano.Api.Shelley - -import Cardano.Binary (decodeFull) import Cardano.CLI.Environment (EnvSocketError, readEnvSocketPath, renderEnvSocketError) import Cardano.CLI.Helpers (HelpersError (..), hushM, pPrintCBOR, renderHelpersError) import Cardano.CLI.Shelley.Orphans () import qualified Cardano.CLI.Shelley.Output as O import Cardano.CLI.Shelley.Parsers (OutputFile (..), QueryCmd (..)) +import Cardano.CLI.Shelley.Run.Genesis (ShelleyGenesisReadError, + readAndDecodeShelleyGenesis) import Cardano.CLI.Types import Cardano.Crypto.Hash (hashToBytesAsHex) -import Cardano.Ledger.Compactible +import qualified Cardano.Crypto.VRF as Crypto +import qualified Cardano.Ledger.Alonzo.PParams as Alonzo +import Cardano.Ledger.BaseTypes (Seed, UnitInterval) import Cardano.Ledger.Coin +import Cardano.Ledger.Compactible +import qualified Cardano.Ledger.Core as Core import Cardano.Ledger.Crypto (StandardCrypto) import qualified Cardano.Ledger.Crypto as Crypto import qualified Cardano.Ledger.Era as Era +import qualified Cardano.Ledger.Era as Ledger import Cardano.Ledger.Keys (KeyHash (..), KeyRole (..)) -import qualified Cardano.Ledger.Shelley.API.Protocol as Ledger import Cardano.Ledger.Shelley.Constraints (UsesValue) import Cardano.Ledger.Shelley.EpochBoundary -import Cardano.Ledger.Shelley.LedgerState hiding (_delegations) +import Cardano.Ledger.Shelley.LedgerState (DPState (_pstate), + EpochState (esLState, esSnapshots), LedgerState (_delegationState), + NewEpochState (nesEs), PState (_fPParams, _pParams, _retiring)) +import qualified Cardano.Ledger.Shelley.PParams as Shelley import Cardano.Ledger.Shelley.Scripts () -import Cardano.Prelude hiding (atomically) +import Cardano.Slotting.EpochInfo (EpochInfo (..), hoistEpochInfo) import Control.Monad.Trans.Except (except) -import Control.Monad.Trans.Except.Extra (firstExceptT, handleIOExceptT, hoistMaybe, left) +import Control.Monad.Trans.Except.Extra (firstExceptT, handleIOExceptT, hoistEither, + hoistMaybe, left, newExceptT) import Data.Aeson.Encode.Pretty (encodePretty) import Data.Aeson.Types as Aeson import Data.List (nub) @@ -72,7 +81,7 @@ import qualified Data.Text.Encoding as Text import qualified Data.Text.IO as T import qualified Data.Text.IO as Text import qualified Data.Vector as Vector - +import qualified Ouroboros.Consensus.HardFork.History as Consensus import qualified Ouroboros.Consensus.HardFork.History.Qry as Qry import qualified Ouroboros.Network.Protocol.LocalStateQuery.Type as LocalStateQuery import qualified System.IO as IO @@ -95,6 +104,9 @@ data ShelleyQueryCmdError | ShelleyQueryCmdUnsupportedMode !AnyConsensusMode | ShelleyQueryCmdPastHorizon !Qry.PastHorizonException | ShelleyQueryCmdSystemStartUnavailable + | ShelleyQueryCmdGenesisReadError !ShelleyGenesisReadError + | ShelleyQueryCmdLeaderShipError !LeadershipError + | ShelleyQueryCmdTextEnvelopeReadError !(FileError TextEnvelopeError) deriving Show renderShelleyQueryCmdError :: ShelleyQueryCmdError -> Text @@ -116,10 +128,15 @@ renderShelleyQueryCmdError err = ShelleyQueryCmdUnsupportedMode mode -> "Unsupported mode: " <> renderMode mode ShelleyQueryCmdPastHorizon e -> "Past horizon: " <> show e ShelleyQueryCmdSystemStartUnavailable -> "System start unavailable" + ShelleyQueryCmdGenesisReadError err' -> Text.pack $ displayError err' + ShelleyQueryCmdLeaderShipError _ -> "" + ShelleyQueryCmdTextEnvelopeReadError _ -> "" runQueryCmd :: QueryCmd -> ExceptT ShelleyQueryCmdError IO () runQueryCmd cmd = case cmd of + QueryLeadershipSchedule consensusModeParams network shelleyGenFp poolid vrkSkeyFp -> + runQueryLeadershipSchedule consensusModeParams network shelleyGenFp poolid vrkSkeyFp QueryProtocolParameters' consensusModeParams network mOutFile -> runQueryProtocolParameters consensusModeParams network mOutFile QueryTip consensusModeParams network mOutFile -> @@ -514,7 +531,7 @@ writeLedgerState :: forall era ledgerera. -> ExceptT ShelleyQueryCmdError IO () writeLedgerState mOutFile qState@(SerialisedDebugLedgerState serLedgerState) = case mOutFile of - Nothing -> case decodeLedgerState qState of + Nothing -> case decodeDebugLedgerState qState of Left bs -> firstExceptT ShelleyQueryCmdHelpersError $ pPrintCBOR bs Right ledgerState -> liftIO . LBS.putStrLn $ encodePretty ledgerState Just (OutputFile fpath) -> @@ -529,7 +546,7 @@ writeStakeSnapshot :: forall era ledgerera. () -> SerialisedDebugLedgerState era -> ExceptT ShelleyQueryCmdError IO () writeStakeSnapshot (StakePoolKeyHash hk) qState = - case decodeLedgerState qState of + case decodeDebugLedgerState qState of -- In the event of decode failure print the CBOR instead Left bs -> firstExceptT ShelleyQueryCmdHelpersError $ pPrintCBOR bs @@ -574,8 +591,8 @@ writePoolParams :: forall era ledgerera. () -> SerialisedDebugLedgerState era -> ExceptT ShelleyQueryCmdError IO () writePoolParams (StakePoolKeyHash hk) qState = - case decodeLedgerState qState of - -- In the event of decode failure print the CBOR instead + case decodeDebugLedgerState qState of + -- In the decodeDebugLedgerState of decode failure print the CBOR instead Left bs -> firstExceptT ShelleyQueryCmdHelpersError $ pPrintCBOR bs Right ledgerState -> do @@ -589,14 +606,7 @@ writePoolParams (StakePoolKeyHash hk) qState = liftIO . LBS.putStrLn $ encodePretty $ Params poolParams fPoolParams retiring -decodeLedgerState :: forall era. () - => FromCBOR (DebugLedgerState era) - => SerialisedDebugLedgerState era - -> Either LBS.ByteString (DebugLedgerState era) -decodeLedgerState (SerialisedDebugLedgerState (Serialised ls)) = first (const ls) (decodeFull ls) - -writeProtocolState :: Crypto.Crypto StandardCrypto - => Maybe OutputFile +writeProtocolState :: Maybe OutputFile -> ProtocolState era -> ExceptT ShelleyQueryCmdError IO () writeProtocolState mOutFile ps@(ProtocolState pstate) = @@ -607,12 +617,6 @@ writeProtocolState mOutFile ps@(ProtocolState pstate) = Just (OutputFile fpath) -> handleIOExceptT (ShelleyQueryCmdWriteFileError . FileIOError fpath) . LBS.writeFile fpath $ unSerialised pstate - where - decodeProtocolState - :: ProtocolState era - -> Either LBS.ByteString (Ledger.ChainDepState StandardCrypto) - decodeProtocolState (ProtocolState (Serialised pbs)) = - first (const pbs) (decodeFull pbs) writeFilteredUTxOs :: ShelleyBasedEra era -> Maybe OutputFile @@ -862,6 +866,52 @@ instance FromJSON DelegationsAndRewards where rewardAccountBalance <- o .:? "rewardAccountBalance" pure (address, rewardAccountBalance, delegation) +runQueryLeadershipSchedule + :: AnyConsensusModeParams + -> NetworkId + -> FilePath + -> Hash StakePoolKey + -> FilePath + -> ExceptT ShelleyQueryCmdError IO () +runQueryLeadershipSchedule (AnyConsensusModeParams cModeParams) network genFile poolid vrfSkeyFp = do + SocketPath sockPath <- firstExceptT ShelleyQueryCmdEnvVarSocketErr readEnvSocketPath + let localNodeConnInfo = LocalNodeConnectInfo cModeParams network sockPath + + anyE@(AnyCardanoEra era) <- determineEra cModeParams localNodeConnInfo + sbe <- getSbe $ cardanoEraStyle era + let cMode = consensusModeOnly cModeParams + vrkSkey <-firstExceptT ShelleyQueryCmdTextEnvelopeReadError . newExceptT + $ readFileTextEnvelope (AsSigningKey AsVrfKey) vrfSkeyFp + shelleyGenesis <- firstExceptT ShelleyQueryCmdGenesisReadError $ + newExceptT $ readAndDecodeShelleyGenesis genFile + case cMode of + CardanoMode -> do + eInMode <- toEraInMode era cMode + & hoistMaybe (ShelleyQueryCmdEraConsensusModeMismatch (AnyConsensusMode cMode) anyE) + + let pparamsQuery = QueryInEra eInMode $ QueryInShelleyBasedEra sbe QueryProtocolParameters + serDebugLedgerStateQuery = QueryInEra eInMode . QueryInShelleyBasedEra sbe $ QueryDebugLedgerState + ptclStateQuery = QueryInEra eInMode . QueryInShelleyBasedEra sbe $ QueryProtocolState + eraHistoryQuery = QueryEraHistory CardanoModeIsMultiEra + + pparams <- executeQuery era cModeParams localNodeConnInfo pparamsQuery + serDebugLedState <- executeQuery era cModeParams localNodeConnInfo serDebugLedgerStateQuery + ptclState <- executeQuery era cModeParams localNodeConnInfo ptclStateQuery + eraHistory <- firstExceptT ShelleyQueryCmdAcquireFailure . newExceptT $ queryNodeLocalState localNodeConnInfo Nothing eraHistoryQuery + + schedule :: Set SlotNo + <- firstExceptT ShelleyQueryCmdLeaderShipError $ hoistEither + $ eligibleLeaderSlotsConstaints sbe + $ eligibleLeadershipSlots sbe shelleyGenesis (toEpochInfo eraHistory) + pparams serDebugLedState ptclState poolid vrkSkey + liftIO $ IO.print schedule + mode -> left . ShelleyQueryCmdUnsupportedMode $ AnyConsensusMode mode + where + toEpochInfo :: EraHistory CardanoMode -> EpochInfo (Either Text) + toEpochInfo (EraHistory _ interpreter) = + hoistEpochInfo (first (Text.pack . show ) . runExcept) + $ Consensus.interpreterToEpochInfo interpreter + -- Helpers calcEraInMode @@ -929,3 +979,22 @@ obtainLedgerEraClassConstraints ShelleyBasedEraShelley f = f obtainLedgerEraClassConstraints ShelleyBasedEraAllegra f = f obtainLedgerEraClassConstraints ShelleyBasedEraMary f = f obtainLedgerEraClassConstraints ShelleyBasedEraAlonzo f = f + + +eligibleLeaderSlotsConstaints + :: ShelleyLedgerEra era ~ ledgerera + => ShelleyBasedEra era + -> (( ShelleyLedgerEra era ~ ledgerera + , Ledger.Crypto ledgerera ~ StandardCrypto + , FromCBOR (DebugLedgerState era) + , Era.Era ledgerera + , HasField "_d" (Core.PParams (ShelleyLedgerEra era)) UnitInterval + , Crypto.Signable (Crypto.VRF (Ledger.Crypto ledgerera)) Seed + ) => a + ) + -> a +eligibleLeaderSlotsConstaints ShelleyBasedEraShelley f = f +eligibleLeaderSlotsConstaints ShelleyBasedEraAllegra f = f +eligibleLeaderSlotsConstaints ShelleyBasedEraMary f = f +eligibleLeaderSlotsConstaints ShelleyBasedEraAlonzo f = f +