From 0dc0a0bec28df622182454c92c5134618ee4710e Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Fri, 27 Nov 2020 15:51:53 +0000 Subject: [PATCH 1/5] Update cli query commands to take an era flag First step of updating all the query commands to support the Allegra and Mary eras. In principle the queries could find out the era from the node itself, but this is a bit awkward so for now we require an extra cli flag. --- .../src/Cardano/CLI/Shelley/Commands.hs | 12 ++-- .../src/Cardano/CLI/Shelley/Parsers.hs | 43 +++++++++------ .../src/Cardano/CLI/Shelley/Run/Query.hs | 55 ++++++++++--------- 3 files changed, 63 insertions(+), 47 deletions(-) diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Commands.hs b/cardano-cli/src/Cardano/CLI/Shelley/Commands.hs index ba31cb3b9bd..bc32549ae95 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Commands.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Commands.hs @@ -270,13 +270,13 @@ renderPoolCmd cmd = PoolMetaDataHash {} -> "stake-pool metadata-hash" data QueryCmd = - QueryProtocolParameters Protocol NetworkId (Maybe OutputFile) + QueryProtocolParameters AnyCardanoEra Protocol NetworkId (Maybe OutputFile) | QueryTip Protocol NetworkId (Maybe OutputFile) - | QueryStakeDistribution Protocol NetworkId (Maybe OutputFile) - | QueryStakeAddressInfo Protocol StakeAddress NetworkId (Maybe OutputFile) - | QueryUTxO Protocol QueryFilter NetworkId (Maybe OutputFile) - | QueryLedgerState Protocol NetworkId (Maybe OutputFile) - | QueryProtocolState Protocol NetworkId (Maybe OutputFile) + | QueryStakeDistribution AnyCardanoEra Protocol NetworkId (Maybe OutputFile) + | QueryStakeAddressInfo AnyCardanoEra Protocol StakeAddress NetworkId (Maybe OutputFile) + | QueryUTxO AnyCardanoEra Protocol QueryFilter NetworkId (Maybe OutputFile) + | QueryLedgerState AnyCardanoEra Protocol NetworkId (Maybe OutputFile) + | QueryProtocolState AnyCardanoEra Protocol NetworkId (Maybe OutputFile) deriving (Eq, Show) renderQueryCmd :: QueryCmd -> Text diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs b/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs index 1bd1e52bea0..2115f4e3510 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs @@ -670,17 +670,22 @@ pQueryCmd = pQueryProtocolParameters :: Parser QueryCmd pQueryProtocolParameters = QueryProtocolParameters - <$> pProtocol + <$> pCardanoEra + <*> pProtocol <*> pNetworkId <*> pMaybeOutputFile pQueryTip :: Parser QueryCmd - pQueryTip = QueryTip <$> pProtocol <*> pNetworkId <*> pMaybeOutputFile + pQueryTip = QueryTip + <$> pProtocol + <*> pNetworkId + <*> pMaybeOutputFile pQueryUTxO :: Parser QueryCmd pQueryUTxO = QueryUTxO - <$> pProtocol + <$> pCardanoEra + <*> pProtocol <*> pQueryFilter <*> pNetworkId <*> pMaybeOutputFile @@ -688,23 +693,29 @@ pQueryCmd = pQueryStakeDistribution :: Parser QueryCmd pQueryStakeDistribution = QueryStakeDistribution - <$> pProtocol + <$> pCardanoEra + <*> pProtocol <*> pNetworkId <*> pMaybeOutputFile pQueryStakeAddressInfo :: Parser QueryCmd pQueryStakeAddressInfo = QueryStakeAddressInfo - <$> pProtocol + <$> pCardanoEra + <*> pProtocol <*> pFilterByStakeAddress <*> pNetworkId <*> pMaybeOutputFile pQueryLedgerState :: Parser QueryCmd - pQueryLedgerState = QueryLedgerState <$> pProtocol <*> pNetworkId <*> pMaybeOutputFile + pQueryLedgerState = QueryLedgerState <$> pCardanoEra <*> pProtocol <*> pNetworkId <*> pMaybeOutputFile pQueryProtocolState :: Parser QueryCmd - pQueryProtocolState = QueryProtocolState <$> pProtocol <*> pNetworkId <*> pMaybeOutputFile + pQueryProtocolState = QueryProtocolState + <$> pCardanoEra + <*> pProtocol + <*> pNetworkId + <*> pMaybeOutputFile pGovernanceCmd :: Parser GovernanceCmd pGovernanceCmd = @@ -2262,21 +2273,21 @@ pProtocol = ( Opt.long "shelley-mode" <> Opt.help "For talking to a node running in Shelley-only mode." ) - *> pShelley + *> pShelleyMode ) <|> ( Opt.flag' () ( Opt.long "byron-mode" <> Opt.help "For talking to a node running in Byron-only mode." ) - *> pByron + *> pByronMode ) <|> ( Opt.flag' () ( Opt.long "cardano-mode" <> Opt.help "For talking to a node running in full Cardano mode (default)." ) - *> pCardano + *> pCardanoMode ) <|> -- Default to the Cardano protocol. @@ -2284,14 +2295,14 @@ pProtocol = (CardanoProtocol (EpochSlots defaultByronEpochSlots)) where - pByron :: Parser Protocol - pByron = ByronProtocol <$> pEpochSlots + pByronMode :: Parser Protocol + pByronMode = ByronProtocol <$> pEpochSlots - pShelley :: Parser Protocol - pShelley = pure ShelleyProtocol + pShelleyMode :: Parser Protocol + pShelleyMode = pure ShelleyProtocol - pCardano :: Parser Protocol - pCardano = CardanoProtocol <$> pEpochSlots + pCardanoMode :: Parser Protocol + pCardanoMode = CardanoProtocol <$> pEpochSlots pEpochSlots :: Parser EpochSlots pEpochSlots = diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs index 70e57419c4f..e7d225a4685 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs @@ -88,28 +88,28 @@ renderShelleyQueryCmdError err = runQueryCmd :: QueryCmd -> ExceptT ShelleyQueryCmdError IO () runQueryCmd cmd = case cmd of - QueryProtocolParameters protocol network mOutFile -> - runQueryProtocolParameters protocol network mOutFile + QueryProtocolParameters era protocol network mOutFile -> + runQueryProtocolParameters era protocol network mOutFile QueryTip protocol network mOutFile -> runQueryTip protocol network mOutFile - QueryStakeDistribution protocol network mOutFile -> - runQueryStakeDistribution protocol network mOutFile - QueryStakeAddressInfo protocol addr network mOutFile -> - runQueryStakeAddressInfo protocol addr network mOutFile - QueryLedgerState protocol network mOutFile -> - runQueryLedgerState protocol network mOutFile - QueryProtocolState protocol network mOutFile -> - runQueryProtocolState protocol network mOutFile - QueryUTxO protocol qFilter networkId mOutFile -> - runQueryUTxO protocol qFilter networkId mOutFile - + QueryStakeDistribution era protocol network mOutFile -> + runQueryStakeDistribution era protocol network mOutFile + QueryStakeAddressInfo era protocol addr network mOutFile -> + runQueryStakeAddressInfo era protocol addr network mOutFile + QueryLedgerState era protocol network mOutFile -> + runQueryLedgerState era protocol network mOutFile + QueryProtocolState era protocol network mOutFile -> + runQueryProtocolState era protocol network mOutFile + QueryUTxO era protocol qFilter networkId mOutFile -> + runQueryUTxO era protocol qFilter networkId mOutFile runQueryProtocolParameters - :: Protocol + :: AnyCardanoEra + -> Protocol -> NetworkId -> Maybe OutputFile -> ExceptT ShelleyQueryCmdError IO () -runQueryProtocolParameters protocol network mOutFile = do +runQueryProtocolParameters (AnyCardanoEra _era) protocol network mOutFile = do SocketPath sockPath <- firstExceptT ShelleyQueryCmdEnvVarSocketErr readEnvSocketPath pparams <- firstExceptT ShelleyQueryCmdLocalStateQueryError $ @@ -150,23 +150,25 @@ runQueryTip protocol network mOutFile = do runQueryUTxO - :: Protocol + :: AnyCardanoEra + -> Protocol -> QueryFilter -> NetworkId -> Maybe OutputFile -> ExceptT ShelleyQueryCmdError IO () -runQueryUTxO protocol qfilter network mOutFile = do +runQueryUTxO (AnyCardanoEra _era) protocol qfilter network mOutFile = do SocketPath sockPath <- firstExceptT ShelleyQueryCmdEnvVarSocketErr readEnvSocketPath filteredUtxo <- firstExceptT ShelleyQueryCmdLocalStateQueryError $ withlocalNodeConnectInfo protocol network sockPath (queryUTxOFromLocalState qfilter) writeFilteredUTxOs mOutFile filteredUtxo runQueryLedgerState - :: Protocol + :: AnyCardanoEra + -> Protocol -> NetworkId -> Maybe OutputFile -> ExceptT ShelleyQueryCmdError IO () -runQueryLedgerState protocol network mOutFile = do +runQueryLedgerState (AnyCardanoEra _era) protocol network mOutFile = do SocketPath sockPath <- firstExceptT ShelleyQueryCmdEnvVarSocketErr readEnvSocketPath els <- firstExceptT ShelleyQueryCmdLocalStateQueryError $ withlocalNodeConnectInfo protocol network sockPath queryLocalLedgerState @@ -177,11 +179,12 @@ runQueryLedgerState protocol network mOutFile = do firstExceptT ShelleyQueryCmdHelpersError $ pPrintCBOR lbs runQueryProtocolState - :: Protocol + :: AnyCardanoEra + -> Protocol -> NetworkId -> Maybe OutputFile -> ExceptT ShelleyQueryCmdError IO () -runQueryProtocolState protocol network mOutFile = do +runQueryProtocolState (AnyCardanoEra _era) protocol network mOutFile = do SocketPath sockPath <- firstExceptT ShelleyQueryCmdEnvVarSocketErr readEnvSocketPath els <- firstExceptT ShelleyQueryCmdLocalStateQueryError $ withlocalNodeConnectInfo protocol network sockPath queryLocalProtocolState @@ -192,12 +195,13 @@ runQueryProtocolState protocol network mOutFile = do firstExceptT ShelleyQueryCmdHelpersError $ pPrintCBOR pbs runQueryStakeAddressInfo - :: Protocol + :: AnyCardanoEra + -> Protocol -> StakeAddress -> NetworkId -> Maybe OutputFile -> ExceptT ShelleyQueryCmdError IO () -runQueryStakeAddressInfo protocol addr network mOutFile = do +runQueryStakeAddressInfo (AnyCardanoEra _era) protocol addr network mOutFile = do SocketPath sockPath <- firstExceptT ShelleyQueryCmdEnvVarSocketErr readEnvSocketPath delegsAndRwds <- firstExceptT ShelleyQueryCmdLocalStateQueryError $ withlocalNodeConnectInfo @@ -288,11 +292,12 @@ printFilteredUTxOs (Ledger.UTxO utxo) = do in Text.pack $ replicate (max 1 (len - slen)) ' ' ++ str runQueryStakeDistribution - :: Protocol + :: AnyCardanoEra + -> Protocol -> NetworkId -> Maybe OutputFile -> ExceptT ShelleyQueryCmdError IO () -runQueryStakeDistribution protocol network mOutFile = do +runQueryStakeDistribution (AnyCardanoEra _era) protocol network mOutFile = do SocketPath sockPath <- firstExceptT ShelleyQueryCmdEnvVarSocketErr readEnvSocketPath stakeDist <- firstExceptT ShelleyQueryCmdLocalStateQueryError $ withlocalNodeConnectInfo From ddfe41e6d9035df498f921d700b65b38639ba743 Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Tue, 1 Dec 2020 00:47:59 +0000 Subject: [PATCH 2/5] For now all our queries need a Shelley-based era Fail if this is not the case. --- .../src/Cardano/CLI/Shelley/Run/Query.hs | 103 ++++++++++++------ 1 file changed, 69 insertions(+), 34 deletions(-) diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs index e7d225a4685..70db08bdb9a 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs @@ -109,7 +109,8 @@ runQueryProtocolParameters -> NetworkId -> Maybe OutputFile -> ExceptT ShelleyQueryCmdError IO () -runQueryProtocolParameters (AnyCardanoEra _era) protocol network mOutFile = do +runQueryProtocolParameters (AnyCardanoEra era) protocol network mOutFile + | ShelleyBasedEra _era' <- cardanoEraStyle era = do SocketPath sockPath <- firstExceptT ShelleyQueryCmdEnvVarSocketErr readEnvSocketPath pparams <- firstExceptT ShelleyQueryCmdLocalStateQueryError $ @@ -117,6 +118,10 @@ runQueryProtocolParameters (AnyCardanoEra _era) protocol network mOutFile = do queryPParamsFromLocalState writeProtocolParameters mOutFile pparams + | otherwise = throwError (ShelleyQueryCmdLocalStateQueryError + ByronProtocolNotSupportedError) + + writeProtocolParameters :: Maybe OutputFile -> PParams StandardShelley @@ -156,11 +161,17 @@ runQueryUTxO -> NetworkId -> Maybe OutputFile -> ExceptT ShelleyQueryCmdError IO () -runQueryUTxO (AnyCardanoEra _era) protocol qfilter network mOutFile = do - SocketPath sockPath <- firstExceptT ShelleyQueryCmdEnvVarSocketErr readEnvSocketPath - filteredUtxo <- firstExceptT ShelleyQueryCmdLocalStateQueryError $ - withlocalNodeConnectInfo protocol network sockPath (queryUTxOFromLocalState qfilter) - writeFilteredUTxOs mOutFile filteredUtxo +runQueryUTxO (AnyCardanoEra era) protocol qfilter network mOutFile + | ShelleyBasedEra _era' <- cardanoEraStyle era = do + + SocketPath sockPath <- firstExceptT ShelleyQueryCmdEnvVarSocketErr readEnvSocketPath + filteredUtxo <- firstExceptT ShelleyQueryCmdLocalStateQueryError $ + withlocalNodeConnectInfo protocol network sockPath (queryUTxOFromLocalState qfilter) + writeFilteredUTxOs mOutFile filteredUtxo + + | otherwise = throwError (ShelleyQueryCmdLocalStateQueryError + ByronProtocolNotSupportedError) + runQueryLedgerState :: AnyCardanoEra @@ -168,15 +179,21 @@ runQueryLedgerState -> NetworkId -> Maybe OutputFile -> ExceptT ShelleyQueryCmdError IO () -runQueryLedgerState (AnyCardanoEra _era) protocol network mOutFile = do - SocketPath sockPath <- firstExceptT ShelleyQueryCmdEnvVarSocketErr readEnvSocketPath - els <- firstExceptT ShelleyQueryCmdLocalStateQueryError $ - withlocalNodeConnectInfo protocol network sockPath queryLocalLedgerState - case els of - Right lstate -> writeLedgerState mOutFile lstate - Left lbs -> do - liftIO $ putTextLn "Version mismatch between node and consensus, so dumping this as generic CBOR." - firstExceptT ShelleyQueryCmdHelpersError $ pPrintCBOR lbs +runQueryLedgerState (AnyCardanoEra era) protocol network mOutFile + | ShelleyBasedEra _era' <- cardanoEraStyle era = do + + SocketPath sockPath <- firstExceptT ShelleyQueryCmdEnvVarSocketErr readEnvSocketPath + els <- firstExceptT ShelleyQueryCmdLocalStateQueryError $ + withlocalNodeConnectInfo protocol network sockPath queryLocalLedgerState + case els of + Right lstate -> writeLedgerState mOutFile lstate + Left lbs -> do + liftIO $ putTextLn "Version mismatch between node and consensus, so dumping this as generic CBOR." + firstExceptT ShelleyQueryCmdHelpersError $ pPrintCBOR lbs + + | otherwise = throwError (ShelleyQueryCmdLocalStateQueryError + ByronProtocolNotSupportedError) + runQueryProtocolState :: AnyCardanoEra @@ -184,15 +201,21 @@ runQueryProtocolState -> NetworkId -> Maybe OutputFile -> ExceptT ShelleyQueryCmdError IO () -runQueryProtocolState (AnyCardanoEra _era) protocol network mOutFile = do - SocketPath sockPath <- firstExceptT ShelleyQueryCmdEnvVarSocketErr readEnvSocketPath - els <- firstExceptT ShelleyQueryCmdLocalStateQueryError $ - withlocalNodeConnectInfo protocol network sockPath queryLocalProtocolState - case els of - Right protocolState -> writeProtocolState mOutFile protocolState - Left pbs -> do - liftIO $ putTextLn "Version mismatch between node and consensus, so dumping this as generic CBOR." - firstExceptT ShelleyQueryCmdHelpersError $ pPrintCBOR pbs +runQueryProtocolState (AnyCardanoEra era) protocol network mOutFile + | ShelleyBasedEra _era' <- cardanoEraStyle era = do + + SocketPath sockPath <- firstExceptT ShelleyQueryCmdEnvVarSocketErr readEnvSocketPath + els <- firstExceptT ShelleyQueryCmdLocalStateQueryError $ + withlocalNodeConnectInfo protocol network sockPath queryLocalProtocolState + case els of + Right protocolState -> writeProtocolState mOutFile protocolState + Left pbs -> do + liftIO $ putTextLn "Version mismatch between node and consensus, so dumping this as generic CBOR." + firstExceptT ShelleyQueryCmdHelpersError $ pPrintCBOR pbs + + | otherwise = throwError (ShelleyQueryCmdLocalStateQueryError + ByronProtocolNotSupportedError) + runQueryStakeAddressInfo :: AnyCardanoEra @@ -201,7 +224,9 @@ runQueryStakeAddressInfo -> NetworkId -> Maybe OutputFile -> ExceptT ShelleyQueryCmdError IO () -runQueryStakeAddressInfo (AnyCardanoEra _era) protocol addr network mOutFile = do +runQueryStakeAddressInfo (AnyCardanoEra era) protocol addr network mOutFile + | ShelleyBasedEra _era' <- cardanoEraStyle era = do + SocketPath sockPath <- firstExceptT ShelleyQueryCmdEnvVarSocketErr readEnvSocketPath delegsAndRwds <- firstExceptT ShelleyQueryCmdLocalStateQueryError $ withlocalNodeConnectInfo @@ -211,6 +236,10 @@ runQueryStakeAddressInfo (AnyCardanoEra _era) protocol addr network mOutFile = d (queryDelegationsAndRewardsFromLocalState (Set.singleton addr)) writeStakeAddressInfo mOutFile delegsAndRwds + | otherwise = throwError (ShelleyQueryCmdLocalStateQueryError + ByronProtocolNotSupportedError) + + -- ------------------------------------------------------------------------------------------------- -- | An error that can occur while querying a node's local state. @@ -297,15 +326,21 @@ runQueryStakeDistribution -> NetworkId -> Maybe OutputFile -> ExceptT ShelleyQueryCmdError IO () -runQueryStakeDistribution (AnyCardanoEra _era) protocol network mOutFile = do - SocketPath sockPath <- firstExceptT ShelleyQueryCmdEnvVarSocketErr readEnvSocketPath - stakeDist <- firstExceptT ShelleyQueryCmdLocalStateQueryError $ - withlocalNodeConnectInfo - protocol - network - sockPath - queryStakeDistributionFromLocalState - writeStakeDistribution mOutFile stakeDist +runQueryStakeDistribution (AnyCardanoEra era) protocol network mOutFile + | ShelleyBasedEra _era' <- cardanoEraStyle era = do + + SocketPath sockPath <- firstExceptT ShelleyQueryCmdEnvVarSocketErr readEnvSocketPath + stakeDist <- firstExceptT ShelleyQueryCmdLocalStateQueryError $ + withlocalNodeConnectInfo + protocol + network + sockPath + queryStakeDistributionFromLocalState + writeStakeDistribution mOutFile stakeDist + + | otherwise = throwError (ShelleyQueryCmdLocalStateQueryError + ByronProtocolNotSupportedError) + writeStakeDistribution :: Maybe OutputFile -> PoolDistr StandardCrypto From ec3d75dccfbb69a6d5df554f9a4f9d90c0866845 Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Tue, 1 Dec 2020 01:03:26 +0000 Subject: [PATCH 3/5] Generalise the runQueryUTxO impl over all eras We pass the era in where needed. Generalise various helper functions over era type classes. For now the UTxO printing code relies on the value type being coin specifically, which means we do not yet support the Mary era. Add a couple functions for obtaining required era class constraints or type equality constraints based on the era: * obtainLedgerEraClassConstraints * requireValueTypeIsCoin The latter is used for the UTxO printing part to satisfy their constraints. --- .../src/Cardano/CLI/Shelley/Run/Query.hs | 99 +++++++++++++++---- 1 file changed, 81 insertions(+), 18 deletions(-) diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs index 70db08bdb9a..cbfb51e8f1f 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} @@ -15,7 +16,7 @@ module Cardano.CLI.Shelley.Run.Query ) where import Cardano.Prelude hiding (atomically) -import Prelude (String) +import Prelude (String, error) import Data.Aeson (ToJSON (..), (.=)) import qualified Data.Aeson as Aeson @@ -46,10 +47,15 @@ import Cardano.Binary (decodeFull) import Cardano.Crypto.Hash (hashToBytesAsHex) import Ouroboros.Consensus.Cardano.Block (Either (..), EraMismatch (..), Query (..)) +import qualified Ouroboros.Consensus.Cardano.Block as Consensus import Ouroboros.Consensus.HardFork.Combinator.Degenerate (Either (DegenQueryResult), Query (DegenQuery)) import Ouroboros.Network.Block (Serialised (..), getTipPoint) +import qualified Cardano.Ledger.Core as Ledger +import qualified Cardano.Ledger.Shelley as Ledger +import qualified Ouroboros.Consensus.Shelley.Ledger as Ledger + import qualified Shelley.Spec.Ledger.Address as Ledger import qualified Shelley.Spec.Ledger.API.Protocol as Ledger import qualified Shelley.Spec.Ledger.Credential as Ledger @@ -63,7 +69,7 @@ import Shelley.Spec.Ledger.Scripts () import qualified Shelley.Spec.Ledger.TxBody as Ledger (TxId (..), TxIn (..), TxOut (..)) import qualified Shelley.Spec.Ledger.UTxO as Ledger (UTxO (..)) -import Ouroboros.Consensus.Shelley.Ledger +import Ouroboros.Consensus.Shelley.Ledger hiding (ShelleyBasedEra) import Ouroboros.Consensus.Shelley.Protocol (StandardCrypto) import Ouroboros.Network.Protocol.LocalStateQuery.Type as LocalStateQuery @@ -162,12 +168,14 @@ runQueryUTxO -> Maybe OutputFile -> ExceptT ShelleyQueryCmdError IO () runQueryUTxO (AnyCardanoEra era) protocol qfilter network mOutFile - | ShelleyBasedEra _era' <- cardanoEraStyle era = do + | ShelleyBasedEra era' <- cardanoEraStyle era = do SocketPath sockPath <- firstExceptT ShelleyQueryCmdEnvVarSocketErr readEnvSocketPath filteredUtxo <- firstExceptT ShelleyQueryCmdLocalStateQueryError $ - withlocalNodeConnectInfo protocol network sockPath (queryUTxOFromLocalState qfilter) - writeFilteredUTxOs mOutFile filteredUtxo + withlocalNodeConnectInfo protocol network sockPath $ + queryUTxOFromLocalState era' qfilter + obtainLedgerEraClassConstraints era' $ requireValueTypeIsCoin era' $ + writeFilteredUTxOs era mOutFile filteredUtxo | otherwise = throwError (ShelleyQueryCmdLocalStateQueryError ByronProtocolNotSupportedError) @@ -288,14 +296,23 @@ writeProtocolState mOutFile pstate = handleIOExceptT (ShelleyQueryCmdWriteFileError . FileIOError fpath) $ LBS.writeFile fpath (encodePretty pstate) -writeFilteredUTxOs :: Maybe OutputFile -> Ledger.UTxO StandardShelley -> ExceptT ShelleyQueryCmdError IO () -writeFilteredUTxOs mOutFile utxo = +writeFilteredUTxOs :: forall era ledgerera. + Ledger.Value ledgerera ~ Coin --TODO: support multi-asset + => Ledger.ShelleyBasedEra ledgerera + => CardanoEra era + -> Maybe OutputFile + -> Ledger.UTxO ledgerera + -> ExceptT ShelleyQueryCmdError IO () +writeFilteredUTxOs _era mOutFile utxo = case mOutFile of Nothing -> liftIO $ printFilteredUTxOs utxo Just (OutputFile fpath) -> handleIOExceptT (ShelleyQueryCmdWriteFileError . FileIOError fpath) $ LBS.writeFile fpath (encodePretty utxo) -printFilteredUTxOs :: Ledger.UTxO StandardShelley -> IO () +printFilteredUTxOs :: forall ledgerera. + Ledger.Value ledgerera ~ Coin --TODO: support multi-asset + => Ledger.ShelleyBased ledgerera + => Ledger.UTxO ledgerera -> IO () printFilteredUTxOs (Ledger.UTxO utxo) = do Text.putStrLn title putStrLn $ replicate (Text.length title + 2) '-' @@ -305,7 +322,7 @@ printFilteredUTxOs (Ledger.UTxO utxo) = do title = " TxHash TxIx Lovelace" - printUtxo :: (Ledger.TxIn StandardShelley, Ledger.TxOut StandardShelley) -> IO () + printUtxo :: (Ledger.TxIn ledgerera, Ledger.TxOut ledgerera) -> IO () printUtxo (Ledger.TxIn (Ledger.TxId txhash) txin , Ledger.TxOut _ (Coin coin)) = Text.putStrLn $ mconcat @@ -386,14 +403,21 @@ printStakeDistribution (PoolDistr stakeDist) = do -- This one is Shelley-specific because the query is Shelley-specific. -- queryUTxOFromLocalState - :: QueryFilter + :: forall era ledgerera mode block. + ShelleyLedgerEra era ~ ledgerera + => IsShelleyBasedEra era + => ShelleyBasedEra era + -> QueryFilter -> LocalNodeConnectInfo mode block - -> ExceptT ShelleyQueryCmdLocalStateQueryError IO (Ledger.UTxO StandardShelley) -queryUTxOFromLocalState qFilter connectInfo@LocalNodeConnectInfo{localNodeConsensusMode} = + -> ExceptT ShelleyQueryCmdLocalStateQueryError IO (Ledger.UTxO ledgerera) +queryUTxOFromLocalState era qFilter + connectInfo@LocalNodeConnectInfo{ + localNodeConsensusMode + } = case localNodeConsensusMode of ByronMode{} -> throwError ByronProtocolNotSupportedError - ShelleyMode{} -> do + ShelleyMode{} | ShelleyBasedEraShelley <- era -> do tip <- liftIO $ getLocalTip connectInfo DegenQueryResult result <- firstExceptT AcquireFailureError . newExceptT $ queryNodeLocalState @@ -401,25 +425,28 @@ queryUTxOFromLocalState qFilter connectInfo@LocalNodeConnectInfo{localNodeConsen (getTipPoint tip, DegenQuery (applyUTxOFilter qFilter)) return result + ShelleyMode{} | otherwise -> throwError ByronProtocolNotSupportedError + CardanoMode{} -> do tip <- liftIO $ getLocalTip connectInfo result <- firstExceptT AcquireFailureError . newExceptT $ queryNodeLocalState connectInfo - (getTipPoint tip, QueryIfCurrentShelley (applyUTxOFilter qFilter)) + (getTipPoint tip, queryIfCurrentEra era (applyUTxOFilter qFilter)) case result of QueryResultEraMismatch err -> throwError (EraMismatchError err) QueryResultSuccess utxo -> return utxo where + applyUTxOFilter :: QueryFilter + -> Query (ShelleyBlock ledgerera) + (Ledger.UTxO ledgerera) applyUTxOFilter (FilterByAddress as) = GetFilteredUTxO (toShelleyAddrs as) applyUTxOFilter NoFilter = GetUTxO - --TODO: generalise across eras - toShelleyAddrs :: Set AddressAny -> Set (Ledger.Addr StandardShelley) + toShelleyAddrs :: Set AddressAny -> Set (Ledger.Addr ledgerera) toShelleyAddrs = Set.map (toShelleyAddr . (anyAddressInShelleyBasedEra - :: AddressAny -> AddressInEra ShelleyEra)) - + :: AddressAny -> AddressInEra era)) -- | A mapping of Shelley reward accounts to both the stake pool that they -- delegate to and their reward account balance. @@ -646,3 +673,39 @@ queryDelegationsAndRewardsFromLocalState stakeaddrs toShelleyStakeCredentials :: Set StakeAddress -> Set (Ledger.StakeCredential StandardShelley) toShelleyStakeCredentials = Set.map (\(StakeAddress _ cred) -> cred) + + +-- ----------------------------------------------------------------------------- +-- Era-generic helper functions +-- + +-- | Select the appropriate query constructor based on the era +-- 'QueryIfCurrentShelley', 'QueryIfCurrentAllegra' or 'QueryIfCurrentMary'. +-- +-- +queryIfCurrentEra :: ShelleyBasedEra era + -> Query (ShelleyBlock (ShelleyLedgerEra era)) result + -> Consensus.CardanoQuery StandardCrypto + (Consensus.CardanoQueryResult StandardCrypto result) +queryIfCurrentEra ShelleyBasedEraShelley = QueryIfCurrentShelley +queryIfCurrentEra ShelleyBasedEraAllegra = QueryIfCurrentAllegra +queryIfCurrentEra ShelleyBasedEraMary = QueryIfCurrentMary + +obtainLedgerEraClassConstraints + :: ShelleyLedgerEra era ~ ledgerera + => ShelleyBasedEra era + -> (Ledger.ShelleyBasedEra ledgerera => a) -> a +obtainLedgerEraClassConstraints ShelleyBasedEraShelley f = f +obtainLedgerEraClassConstraints ShelleyBasedEraAllegra f = f +obtainLedgerEraClassConstraints ShelleyBasedEraMary f = f + +--TODO: eliminate this and support multi-asset properly +requireValueTypeIsCoin + :: ShelleyLedgerEra era ~ ledgerera + => ShelleyBasedEra era + -> (Ledger.Value ledgerera ~ Coin => a) -> a +requireValueTypeIsCoin ShelleyBasedEraShelley f = f +requireValueTypeIsCoin ShelleyBasedEraAllegra f = f +requireValueTypeIsCoin ShelleyBasedEraMary _ = + error "TODO: requireValueTypeIsCoin eliminate this and support Mary era" + From 3ae2f88622bdb9a5ed047fe88287adb8f64336da Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Tue, 1 Dec 2020 02:20:23 +0000 Subject: [PATCH 4/5] Add ToJSON instances needed for the Allegra & Mary ledger states --- .../src/Cardano/CLI/Shelley/Orphans.hs | 61 ++++++++++++++++++- 1 file changed, 58 insertions(+), 3 deletions(-) diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Orphans.hs b/cardano-cli/src/Cardano/CLI/Shelley/Orphans.hs index ef2eaea2891..47ff7764e52 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Orphans.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Orphans.hs @@ -28,7 +28,9 @@ import Cardano.Crypto.Hash.Class as Crypto import Ouroboros.Consensus.Byron.Ledger.Block (ByronHash (..)) import Ouroboros.Consensus.HardFork.Combinator (OneEraHash (..)) import Ouroboros.Consensus.Shelley.Ledger.Block (ShelleyHash (..)) -import Ouroboros.Consensus.Shelley.Eras (ShelleyBasedEra, StandardCrypto, StandardShelley) +import Ouroboros.Consensus.Shelley.Eras + (ShelleyBasedEra, StandardCrypto, + StandardShelley, StandardAllegra, StandardMary) import Ouroboros.Network.Block (BlockNo (..), HeaderHash, Tip (..)) import qualified Cardano.Ledger.Core as Core @@ -50,6 +52,8 @@ import qualified Shelley.Spec.Ledger.STS.Tickn as Ledger import Shelley.Spec.Ledger.TxBody (TxId (..), TxIn (..), TxOut (..)) import Shelley.Spec.Ledger.UTxO (UTxO (..)) +import qualified Cardano.Ledger.Mary.Value as Ledger.Mary + instance ShelleyBasedEra era => ToJSONKey (TxIn era) where toJSONKey = ToJSONKeyText txInToText (Aeson.text . txInToText) @@ -108,22 +112,33 @@ deriving newtype instance ToJSON (HashHeader era) deriving newtype instance ToJSON (MetaDataHash era) deriving newtype instance ToJSON Ledger.LogWeight deriving newtype instance ToJSON Ledger.Likelihood -deriving newtype instance ToJSON (Ledger.Stake StandardShelley) deriving newtype instance ToJSON (Ledger.PoolDistr StandardCrypto) deriving newtype instance ToJSON DeltaCoin +deriving newtype instance ToJSON (Ledger.Stake StandardShelley) +deriving newtype instance ToJSON (Ledger.Stake StandardAllegra) +deriving newtype instance ToJSON (Ledger.Stake StandardMary) + deriving anyclass instance ToJSON (Ledger.GenDelegs StandardCrypto) deriving anyclass instance ToJSON (Ledger.IndividualPoolStake StandardCrypto) + deriving anyclass instance ToJSON (Ledger.ProposedPPUpdates StandardShelley) deriving anyclass instance ToJSON (Ledger.PPUPState StandardShelley) deriving anyclass instance ToJSON (Ledger.BlocksMade StandardShelley) +deriving anyclass instance ToJSON (Ledger.ProposedPPUpdates StandardAllegra) +deriving anyclass instance ToJSON (Ledger.PPUPState StandardAllegra) +deriving anyclass instance ToJSON (Ledger.BlocksMade StandardAllegra) + +deriving anyclass instance ToJSON (Ledger.ProposedPPUpdates StandardMary) +deriving anyclass instance ToJSON (Ledger.PPUPState StandardMary) +deriving anyclass instance ToJSON (Ledger.BlocksMade StandardMary) + deriving instance ToJSON Ledger.Ptr deriving instance ToJSON Ledger.AccountState deriving instance ToJSON (Ledger.DPState StandardShelley) deriving instance ToJSON (Ledger.DState StandardShelley) -deriving instance ToJSON (Ledger.FutureGenDeleg StandardCrypto) deriving instance ToJSON (Ledger.InstantaneousRewards StandardShelley) deriving instance ToJSON (Ledger.SnapShot StandardShelley) deriving instance ToJSON (Ledger.SnapShots StandardShelley) @@ -136,6 +151,38 @@ deriving instance ToJSON (Ledger.PParams' StrictMaybe StandardShelley) deriving instance ToJSON (Ledger.PState StandardShelley) deriving instance ToJSON (Ledger.StakeReference StandardShelley) deriving instance ToJSON (Ledger.UTxOState StandardShelley) + +deriving instance ToJSON (Ledger.DPState StandardAllegra) +deriving instance ToJSON (Ledger.DState StandardAllegra) +deriving instance ToJSON (Ledger.InstantaneousRewards StandardAllegra) +deriving instance ToJSON (Ledger.SnapShot StandardAllegra) +deriving instance ToJSON (Ledger.SnapShots StandardAllegra) +deriving instance ToJSON (Ledger.NonMyopic StandardAllegra) +deriving instance ToJSON (Ledger.LedgerState StandardAllegra) +deriving instance ToJSON (Ledger.EpochState StandardAllegra) +deriving instance ToJSON (Ledger.RewardUpdate StandardAllegra) +deriving instance ToJSON (Ledger.NewEpochState StandardAllegra) +deriving instance ToJSON (Ledger.PParams' StrictMaybe StandardAllegra) +deriving instance ToJSON (Ledger.PState StandardAllegra) +deriving instance ToJSON (Ledger.StakeReference StandardAllegra) +deriving instance ToJSON (Ledger.UTxOState StandardAllegra) + +deriving instance ToJSON (Ledger.DPState StandardMary) +deriving instance ToJSON (Ledger.DState StandardMary) +deriving instance ToJSON (Ledger.InstantaneousRewards StandardMary) +deriving instance ToJSON (Ledger.SnapShot StandardMary) +deriving instance ToJSON (Ledger.SnapShots StandardMary) +deriving instance ToJSON (Ledger.NonMyopic StandardMary) +deriving instance ToJSON (Ledger.LedgerState StandardMary) +deriving instance ToJSON (Ledger.EpochState StandardMary) +deriving instance ToJSON (Ledger.RewardUpdate StandardMary) +deriving instance ToJSON (Ledger.NewEpochState StandardMary) +deriving instance ToJSON (Ledger.PParams' StrictMaybe StandardMary) +deriving instance ToJSON (Ledger.PState StandardMary) +deriving instance ToJSON (Ledger.StakeReference StandardMary) +deriving instance ToJSON (Ledger.UTxOState StandardMary) + +deriving instance ToJSON (Ledger.FutureGenDeleg StandardCrypto) deriving instance ToJSON (Ledger.PrtclState StandardCrypto) deriving instance ToJSON Ledger.TicknState deriving instance ToJSON (Ledger.ChainDepState StandardCrypto) @@ -143,5 +190,13 @@ deriving instance ToJSON (Ledger.ChainDepState StandardCrypto) deriving instance ToJSONKey Ledger.Ptr deriving instance ToJSONKey (Ledger.FutureGenDeleg StandardCrypto) +deriving anyclass instance ToJSON (Ledger.Mary.Value StandardMary) +deriving newtype instance ToJSON (Ledger.Mary.PolicyID StandardMary) +deriving anyclass instance ToJSONKey (Ledger.Mary.PolicyID StandardMary) +deriving anyclass instance ToJSONKey Ledger.Mary.AssetName + +instance ToJSON Ledger.Mary.AssetName where + toJSON (Ledger.Mary.AssetName bs) = toJSON (Text.decodeLatin1 bs) + instance (ToJSONKey k, ToJSON v) => ToJSON (SetAlgebra.BiMap v k v) where toJSON = toJSON . SetAlgebra.forwards -- to normal Map From 99ac681b2c354c145a50b52c0329aa776b872eea Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Tue, 1 Dec 2020 02:23:06 +0000 Subject: [PATCH 5/5] Generalise the remaining cli queries impl over all eras They all follow more or less the same pattern. Various helper functions become polymorphic with class and type equality constraints. We then need a couple more helper functions for obtaining the necessary constraints so they're available where we need them. --- cardano-api/src/Cardano/Api/Shelley.hs | 15 +- .../src/Cardano/CLI/Shelley/Run/Query.hs | 240 ++++++++++++------ 2 files changed, 165 insertions(+), 90 deletions(-) diff --git a/cardano-api/src/Cardano/Api/Shelley.hs b/cardano-api/src/Cardano/Api/Shelley.hs index 7515bae2f0e..055b15878a7 100644 --- a/cardano-api/src/Cardano/Api/Shelley.hs +++ b/cardano-api/src/Cardano/Api/Shelley.hs @@ -13,10 +13,10 @@ module Cardano.Api.Shelley -- * Payment addresses -- | Constructing and inspecting Shelley payment addresses Address(ShelleyAddress), - fromShelleyAddr, - fromShelleyStakeAddr, toShelleyAddr, - toShelleyStakeAddr, + fromShelleyAddr, + toShelleyStakeCredential, + fromShelleyStakeCredential, NetworkId(Mainnet, Testnet), -- * Stake addresses @@ -24,6 +24,10 @@ module Cardano.Api.Shelley StakeAddress(..), StakeAddressReference(..), StakeCredential(..), + toShelleyStakeAddr, + fromShelleyStakeAddr, + fromShelleyStakeReference, + fromShelleyPaymentCredential, -- * Building transactions -- | Constructing and inspecting transactions @@ -78,11 +82,6 @@ module Cardano.Api.Shelley EpochNo(..), NetworkMagic(..), - -- * Credentials & stake references - fromShelleyPaymentCredential, - fromShelleyStakeCredential, - fromShelleyStakeReference, - -- * Scripts toShelleyScript, toShelleyMultiSig, diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs index cbfb51e8f1f..002ea1f6bba 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs @@ -53,6 +53,7 @@ import Ouroboros.Consensus.HardFork.Combinator.Degenerate (Either (Deg import Ouroboros.Network.Block (Serialised (..), getTipPoint) import qualified Cardano.Ledger.Core as Ledger +import qualified Cardano.Ledger.Era as Ledger import qualified Cardano.Ledger.Shelley as Ledger import qualified Ouroboros.Consensus.Shelley.Ledger as Ledger @@ -116,12 +117,13 @@ runQueryProtocolParameters -> Maybe OutputFile -> ExceptT ShelleyQueryCmdError IO () runQueryProtocolParameters (AnyCardanoEra era) protocol network mOutFile - | ShelleyBasedEra _era' <- cardanoEraStyle era = do + | ShelleyBasedEra era' <- cardanoEraStyle era = do + SocketPath sockPath <- firstExceptT ShelleyQueryCmdEnvVarSocketErr readEnvSocketPath pparams <- firstExceptT ShelleyQueryCmdLocalStateQueryError $ - withlocalNodeConnectInfo protocol network sockPath - queryPParamsFromLocalState + withlocalNodeConnectInfo protocol network sockPath $ + queryPParamsFromLocalState era' writeProtocolParameters mOutFile pparams | otherwise = throwError (ShelleyQueryCmdLocalStateQueryError @@ -130,7 +132,7 @@ runQueryProtocolParameters (AnyCardanoEra era) protocol network mOutFile writeProtocolParameters :: Maybe OutputFile - -> PParams StandardShelley + -> PParams ledgerera -> ExceptT ShelleyQueryCmdError IO () writeProtocolParameters mOutFile pparams = case mOutFile of @@ -168,14 +170,17 @@ runQueryUTxO -> Maybe OutputFile -> ExceptT ShelleyQueryCmdError IO () runQueryUTxO (AnyCardanoEra era) protocol qfilter network mOutFile - | ShelleyBasedEra era' <- cardanoEraStyle era = do + | ShelleyBasedEra era' <- cardanoEraStyle era = + + -- Obtain the required type equality constaints and class constaints + requireValueTypeIsCoin era' $ + obtainLedgerEraClassConstraints era' $ do SocketPath sockPath <- firstExceptT ShelleyQueryCmdEnvVarSocketErr readEnvSocketPath filteredUtxo <- firstExceptT ShelleyQueryCmdLocalStateQueryError $ withlocalNodeConnectInfo protocol network sockPath $ queryUTxOFromLocalState era' qfilter - obtainLedgerEraClassConstraints era' $ requireValueTypeIsCoin era' $ - writeFilteredUTxOs era mOutFile filteredUtxo + writeFilteredUTxOs era mOutFile filteredUtxo | otherwise = throwError (ShelleyQueryCmdLocalStateQueryError ByronProtocolNotSupportedError) @@ -188,11 +193,16 @@ runQueryLedgerState -> Maybe OutputFile -> ExceptT ShelleyQueryCmdError IO () runQueryLedgerState (AnyCardanoEra era) protocol network mOutFile - | ShelleyBasedEra _era' <- cardanoEraStyle era = do + | ShelleyBasedEra era' <- cardanoEraStyle era = + + -- Obtain the required class constaints + obtainLedgerEraClassConstraints era' $ + obtainToJSONNewEpochState era' $ do SocketPath sockPath <- firstExceptT ShelleyQueryCmdEnvVarSocketErr readEnvSocketPath els <- firstExceptT ShelleyQueryCmdLocalStateQueryError $ - withlocalNodeConnectInfo protocol network sockPath queryLocalLedgerState + withlocalNodeConnectInfo protocol network sockPath $ + queryLocalLedgerState era' case els of Right lstate -> writeLedgerState mOutFile lstate Left lbs -> do @@ -210,11 +220,12 @@ runQueryProtocolState -> Maybe OutputFile -> ExceptT ShelleyQueryCmdError IO () runQueryProtocolState (AnyCardanoEra era) protocol network mOutFile - | ShelleyBasedEra _era' <- cardanoEraStyle era = do + | ShelleyBasedEra era' <- cardanoEraStyle era = do SocketPath sockPath <- firstExceptT ShelleyQueryCmdEnvVarSocketErr readEnvSocketPath els <- firstExceptT ShelleyQueryCmdLocalStateQueryError $ - withlocalNodeConnectInfo protocol network sockPath queryLocalProtocolState + withlocalNodeConnectInfo protocol network sockPath $ + queryLocalProtocolState era' case els of Right protocolState -> writeProtocolState mOutFile protocolState Left pbs -> do @@ -233,15 +244,15 @@ runQueryStakeAddressInfo -> Maybe OutputFile -> ExceptT ShelleyQueryCmdError IO () runQueryStakeAddressInfo (AnyCardanoEra era) protocol addr network mOutFile - | ShelleyBasedEra _era' <- cardanoEraStyle era = do + | ShelleyBasedEra era' <- cardanoEraStyle era = + + -- Obtain the required type equality constaints + obtainStandardCrypto era' $ do SocketPath sockPath <- firstExceptT ShelleyQueryCmdEnvVarSocketErr readEnvSocketPath delegsAndRwds <- firstExceptT ShelleyQueryCmdLocalStateQueryError $ - withlocalNodeConnectInfo - protocol - network - sockPath - (queryDelegationsAndRewardsFromLocalState (Set.singleton addr)) + withlocalNodeConnectInfo protocol network sockPath $ + queryDelegationsAndRewardsFromLocalState era' (Set.singleton addr) writeStakeAddressInfo mOutFile delegsAndRwds | otherwise = throwError (ShelleyQueryCmdLocalStateQueryError @@ -258,6 +269,8 @@ data ShelleyQueryCmdLocalStateQueryError -- era. | ByronProtocolNotSupportedError -- ^ The query does not support the Byron protocol. + | ShelleyProtocolEraMismatch + -- ^ The Shelley protocol only supports the Shelley era. deriving (Eq, Show) renderLocalStateQueryError :: ShelleyQueryCmdLocalStateQueryError -> Text @@ -268,10 +281,14 @@ renderLocalStateQueryError lsqErr = "A query from a certain era was applied to a ledger from a different era: " <> show err ByronProtocolNotSupportedError -> "The attempted local state query does not support the Byron protocol." + ShelleyProtocolEraMismatch -> + "The Shelley protocol mode can only be used with the Shelley era, " + <> "i.e. with --shelley-mode use --shelly-era flag" writeStakeAddressInfo - :: Maybe OutputFile - -> DelegationsAndRewards + :: Ledger.Crypto ledgerera ~ StandardCrypto + => Maybe OutputFile + -> DelegationsAndRewards ledgerera -> ExceptT ShelleyQueryCmdError IO () writeStakeAddressInfo mOutFile dr@(DelegationsAndRewards _ _delegsAndRwds) = case mOutFile of @@ -280,7 +297,10 @@ writeStakeAddressInfo mOutFile dr@(DelegationsAndRewards _ _delegsAndRwds) = handleIOExceptT (ShelleyQueryCmdWriteFileError . FileIOError fpath) $ LBS.writeFile fpath (encodePretty dr) -writeLedgerState :: Maybe OutputFile -> NewEpochState StandardShelley -> ExceptT ShelleyQueryCmdError IO () +writeLedgerState :: ToJSON (NewEpochState ledgerera) + => Maybe OutputFile + -> NewEpochState ledgerera + -> ExceptT ShelleyQueryCmdError IO () writeLedgerState mOutFile lstate = case mOutFile of Nothing -> liftIO $ LBS.putStrLn (encodePretty lstate) @@ -288,7 +308,9 @@ writeLedgerState mOutFile lstate = handleIOExceptT (ShelleyQueryCmdWriteFileError . FileIOError fpath) $ LBS.writeFile fpath (encodePretty lstate) -writeProtocolState :: Maybe OutputFile -> Ledger.ChainDepState StandardCrypto -> ExceptT ShelleyQueryCmdError IO () +writeProtocolState :: Maybe OutputFile + -> Ledger.ChainDepState StandardCrypto + -> ExceptT ShelleyQueryCmdError IO () writeProtocolState mOutFile pstate = case mOutFile of Nothing -> liftIO $ LBS.putStrLn (encodePretty pstate) @@ -344,15 +366,15 @@ runQueryStakeDistribution -> Maybe OutputFile -> ExceptT ShelleyQueryCmdError IO () runQueryStakeDistribution (AnyCardanoEra era) protocol network mOutFile - | ShelleyBasedEra _era' <- cardanoEraStyle era = do + | ShelleyBasedEra era' <- cardanoEraStyle era = + + -- Obtain the required type equality constaints + obtainStandardCrypto era' $ do SocketPath sockPath <- firstExceptT ShelleyQueryCmdEnvVarSocketErr readEnvSocketPath stakeDist <- firstExceptT ShelleyQueryCmdLocalStateQueryError $ - withlocalNodeConnectInfo - protocol - network - sockPath - queryStakeDistributionFromLocalState + withlocalNodeConnectInfo protocol network sockPath $ + queryStakeDistributionFromLocalState era' writeStakeDistribution mOutFile stakeDist | otherwise = throwError (ShelleyQueryCmdLocalStateQueryError @@ -425,7 +447,7 @@ queryUTxOFromLocalState era qFilter (getTipPoint tip, DegenQuery (applyUTxOFilter qFilter)) return result - ShelleyMode{} | otherwise -> throwError ByronProtocolNotSupportedError + ShelleyMode{} | otherwise -> throwError ShelleyProtocolEraMismatch CardanoMode{} -> do tip <- liftIO $ getLocalTip connectInfo @@ -450,19 +472,20 @@ queryUTxOFromLocalState era qFilter -- | A mapping of Shelley reward accounts to both the stake pool that they -- delegate to and their reward account balance. -data DelegationsAndRewards +data DelegationsAndRewards ledgerera = DelegationsAndRewards !NetworkId - !(Map (Ledger.Credential Ledger.Staking StandardShelley) + !(Map (Ledger.Credential Ledger.Staking ledgerera) (Maybe (Hash StakePoolKey), Coin)) -instance ToJSON DelegationsAndRewards where +instance Ledger.Crypto ledgerera ~ StandardCrypto + => ToJSON (DelegationsAndRewards ledgerera) where toJSON (DelegationsAndRewards nw delegsAndRwds) = Aeson.Array . Vector.fromList . map delegAndRwdToJson $ Map.toList delegsAndRwds where delegAndRwdToJson - :: (Ledger.Credential Ledger.Staking StandardShelley, (Maybe (Hash StakePoolKey), Coin)) + :: (Ledger.Credential Ledger.Staking ledgerera, (Maybe (Hash StakePoolKey), Coin)) -> Aeson.Value delegAndRwdToJson (k, (d, r)) = Aeson.object @@ -471,8 +494,11 @@ instance ToJSON DelegationsAndRewards where , "rewardAccountBalance" .= r ] - renderAddress :: Ledger.Credential Ledger.Staking StandardShelley -> Text - renderAddress = serialiseAddress . StakeAddress (toShelleyNetwork nw) + renderAddress :: Ledger.Credential Ledger.Staking ledgerera -> Text + renderAddress = serialiseAddress + . StakeAddress (toShelleyNetwork nw) + . toShelleyStakeCredential + . fromShelleyStakeCredential -- | Query the current protocol parameters from a Shelley node via the local @@ -481,16 +507,20 @@ instance ToJSON DelegationsAndRewards where -- This one is Shelley-specific because the query is Shelley-specific. -- queryPParamsFromLocalState - :: LocalNodeConnectInfo mode block - -> ExceptT ShelleyQueryCmdLocalStateQueryError IO (PParams StandardShelley) -queryPParamsFromLocalState LocalNodeConnectInfo{ - localNodeConsensusMode = ByronMode{} - } = + :: forall era ledgerera mode block. + ShelleyLedgerEra era ~ ledgerera + => ShelleyBasedEra era + -> LocalNodeConnectInfo mode block + -> ExceptT ShelleyQueryCmdLocalStateQueryError IO (PParams ledgerera) +queryPParamsFromLocalState _ LocalNodeConnectInfo{ + localNodeConsensusMode = ByronMode{} + } = throwError ByronProtocolNotSupportedError -queryPParamsFromLocalState connectInfo@LocalNodeConnectInfo{ - localNodeConsensusMode = ShelleyMode - } = do +queryPParamsFromLocalState era connectInfo@LocalNodeConnectInfo{ + localNodeConsensusMode = ShelleyMode + } + | ShelleyBasedEraShelley <- era = do tip <- liftIO $ getLocalTip connectInfo DegenQueryResult result <- firstExceptT AcquireFailureError . newExceptT $ queryNodeLocalState @@ -498,14 +528,16 @@ queryPParamsFromLocalState connectInfo@LocalNodeConnectInfo{ (getTipPoint tip, DegenQuery GetCurrentPParams) return result -queryPParamsFromLocalState connectInfo@LocalNodeConnectInfo{ - localNodeConsensusMode = CardanoMode{} - } = do + | otherwise = throwError ShelleyProtocolEraMismatch + +queryPParamsFromLocalState era connectInfo@LocalNodeConnectInfo{ + localNodeConsensusMode = CardanoMode{} + } = do tip <- liftIO $ getLocalTip connectInfo result <- firstExceptT AcquireFailureError . newExceptT $ queryNodeLocalState connectInfo - (getTipPoint tip, QueryIfCurrentShelley GetCurrentPParams) + (getTipPoint tip, queryIfCurrentEra era GetCurrentPParams) case result of QueryResultEraMismatch eraerr -> throwError (EraMismatchError eraerr) QueryResultSuccess pparams -> return pparams @@ -517,44 +549,55 @@ queryPParamsFromLocalState connectInfo@LocalNodeConnectInfo{ -- This one is Shelley-specific because the query is Shelley-specific. -- queryStakeDistributionFromLocalState - :: LocalNodeConnectInfo mode block + :: forall era ledgerera mode block. + ShelleyLedgerEra era ~ ledgerera + => Ledger.Crypto ledgerera ~ StandardCrypto + => ShelleyBasedEra era + -> LocalNodeConnectInfo mode block -> ExceptT ShelleyQueryCmdLocalStateQueryError IO (PoolDistr StandardCrypto) -queryStakeDistributionFromLocalState LocalNodeConnectInfo{ - localNodeConsensusMode = ByronMode{} - } = +queryStakeDistributionFromLocalState _ LocalNodeConnectInfo{ + localNodeConsensusMode = ByronMode{} + } = throwError ByronProtocolNotSupportedError -queryStakeDistributionFromLocalState connectInfo@LocalNodeConnectInfo{ - localNodeConsensusMode = ShelleyMode{} - } = do - tip <- liftIO $ getLocalTip connectInfo - DegenQueryResult result <- firstExceptT AcquireFailureError . newExceptT $ - queryNodeLocalState - connectInfo - (getTipPoint tip, DegenQuery GetStakeDistribution) - return result +queryStakeDistributionFromLocalState era connectInfo@LocalNodeConnectInfo{ + localNodeConsensusMode = ShelleyMode{} + } + | ShelleyBasedEraShelley <- era = do + tip <- liftIO $ getLocalTip connectInfo + DegenQueryResult result <- firstExceptT AcquireFailureError . newExceptT $ + queryNodeLocalState + connectInfo + (getTipPoint tip, DegenQuery GetStakeDistribution) + return result -queryStakeDistributionFromLocalState connectInfo@LocalNodeConnectInfo{ - localNodeConsensusMode = CardanoMode{} - } = do + | otherwise = throwError ShelleyProtocolEraMismatch + +queryStakeDistributionFromLocalState era connectInfo@LocalNodeConnectInfo{ + localNodeConsensusMode = CardanoMode{} + } = do tip <- liftIO $ getLocalTip connectInfo result <- firstExceptT AcquireFailureError . newExceptT $ queryNodeLocalState connectInfo - (getTipPoint tip, QueryIfCurrentShelley GetStakeDistribution) + (getTipPoint tip, queryIfCurrentEra era GetStakeDistribution) case result of QueryResultEraMismatch err -> throwError (EraMismatchError err) QueryResultSuccess stakeDist -> return stakeDist queryLocalLedgerState - :: LocalNodeConnectInfo mode blk + :: forall era ledgerera mode block. + ShelleyLedgerEra era ~ ledgerera + => Ledger.ShelleyBasedEra ledgerera + => ShelleyBasedEra era + -> LocalNodeConnectInfo mode block -> ExceptT ShelleyQueryCmdLocalStateQueryError IO - (Either LByteString (NewEpochState StandardShelley)) -queryLocalLedgerState connectInfo@LocalNodeConnectInfo{localNodeConsensusMode} = + (Either LByteString (NewEpochState ledgerera)) +queryLocalLedgerState era connectInfo@LocalNodeConnectInfo{localNodeConsensusMode} = case localNodeConsensusMode of ByronMode{} -> throwError ByronProtocolNotSupportedError - ShelleyMode{} -> do + ShelleyMode{} | ShelleyBasedEraShelley <- era -> do tip <- liftIO $ getLocalTip connectInfo DegenQueryResult result <- firstExceptT AcquireFailureError . newExceptT $ queryNodeLocalState @@ -565,12 +608,14 @@ queryLocalLedgerState connectInfo@LocalNodeConnectInfo{localNodeConsensusMode} = ) return (decodeLedgerState result) + ShelleyMode{} | otherwise -> throwError ShelleyProtocolEraMismatch + CardanoMode{} -> do tip <- liftIO $ getLocalTip connectInfo result <- firstExceptT AcquireFailureError . newExceptT $ queryNodeLocalState connectInfo - (getTipPoint tip, QueryIfCurrentShelley (GetCBOR DebugNewEpochState)) -- Get CBOR-in-CBOR version + (getTipPoint tip, queryIfCurrentEra era (GetCBOR DebugNewEpochState)) -- Get CBOR-in-CBOR version case result of QueryResultEraMismatch err -> throwError (EraMismatchError err) QueryResultSuccess ls -> return (decodeLedgerState ls) @@ -581,14 +626,17 @@ queryLocalLedgerState connectInfo@LocalNodeConnectInfo{localNodeConsensusMode} = first (const lbs) (decodeFull lbs) queryLocalProtocolState - :: LocalNodeConnectInfo mode blk + :: forall era ledgerera mode block. + ShelleyLedgerEra era ~ ledgerera + => ShelleyBasedEra era + -> LocalNodeConnectInfo mode block -> ExceptT ShelleyQueryCmdLocalStateQueryError IO (Either LByteString (Ledger.ChainDepState StandardCrypto)) -queryLocalProtocolState connectInfo@LocalNodeConnectInfo{localNodeConsensusMode} = +queryLocalProtocolState era connectInfo@LocalNodeConnectInfo{localNodeConsensusMode} = case localNodeConsensusMode of ByronMode{} -> throwError ByronProtocolNotSupportedError - ShelleyMode{} -> do + ShelleyMode{} | ShelleyBasedEraShelley <- era -> do tip <- liftIO $ getLocalTip connectInfo DegenQueryResult result <- firstExceptT AcquireFailureError . newExceptT $ queryNodeLocalState @@ -599,12 +647,14 @@ queryLocalProtocolState connectInfo@LocalNodeConnectInfo{localNodeConsensusMode} ) return (decodeProtocolState result) + ShelleyMode{} | otherwise -> throwError ShelleyProtocolEraMismatch + CardanoMode{} -> do tip <- liftIO $ getLocalTip connectInfo result <- firstExceptT AcquireFailureError . newExceptT $ queryNodeLocalState connectInfo - (getTipPoint tip, QueryIfCurrentShelley (GetCBOR DebugChainDepState)) -- Get CBOR-in-CBOR version + (getTipPoint tip, queryIfCurrentEra era (GetCBOR DebugChainDepState)) -- Get CBOR-in-CBOR version case result of QueryResultEraMismatch err -> throwError (EraMismatchError err) QueryResultSuccess ls -> return (decodeProtocolState ls) @@ -621,10 +671,15 @@ queryLocalProtocolState connectInfo@LocalNodeConnectInfo{localNodeConsensusMode} -- This one is Shelley-specific because the query is Shelley-specific. -- queryDelegationsAndRewardsFromLocalState - :: Set StakeAddress + :: forall era ledgerera mode block. + ShelleyLedgerEra era ~ ledgerera + => Ledger.Crypto ledgerera ~ StandardCrypto + => ShelleyBasedEra era + -> Set StakeAddress -> LocalNodeConnectInfo mode block - -> ExceptT ShelleyQueryCmdLocalStateQueryError IO DelegationsAndRewards -queryDelegationsAndRewardsFromLocalState stakeaddrs + -> ExceptT ShelleyQueryCmdLocalStateQueryError IO + (DelegationsAndRewards ledgerera) +queryDelegationsAndRewardsFromLocalState era stakeaddrs connectInfo@LocalNodeConnectInfo{ localNodeNetworkId, localNodeConsensusMode @@ -632,7 +687,7 @@ queryDelegationsAndRewardsFromLocalState stakeaddrs case localNodeConsensusMode of ByronMode{} -> throwError ByronProtocolNotSupportedError - ShelleyMode{} -> do + ShelleyMode{} | ShelleyBasedEraShelley <- era -> do tip <- liftIO $ getLocalTip connectInfo DegenQueryResult result <- firstExceptT AcquireFailureError . newExceptT $ @@ -645,13 +700,15 @@ queryDelegationsAndRewardsFromLocalState stakeaddrs ) return (uncurry toDelegsAndRwds result) + ShelleyMode{} | otherwise -> throwError ShelleyProtocolEraMismatch + CardanoMode{} -> do tip <- liftIO $ getLocalTip connectInfo result <- firstExceptT AcquireFailureError . newExceptT $ queryNodeLocalState connectInfo ( getTipPoint tip - , QueryIfCurrentShelley $ + , queryIfCurrentEra era $ GetFilteredDelegationsAndRewardAccounts (toShelleyStakeCredentials stakeaddrs) ) @@ -660,10 +717,10 @@ queryDelegationsAndRewardsFromLocalState stakeaddrs QueryResultSuccess drs -> return $ uncurry toDelegsAndRwds drs where toDelegsAndRwds - :: Map (Ledger.Credential Ledger.Staking StandardShelley) + :: Map (Ledger.Credential Ledger.Staking ledgerera) (Ledger.KeyHash Ledger.StakePool StandardCrypto) - -> Ledger.RewardAccounts StandardShelley - -> DelegationsAndRewards + -> Ledger.RewardAccounts ledgerera + -> DelegationsAndRewards ledgerera toDelegsAndRwds delegs rwdAcnts = DelegationsAndRewards localNodeNetworkId $ Map.mapWithKey @@ -671,8 +728,11 @@ queryDelegationsAndRewardsFromLocalState stakeaddrs rwdAcnts toShelleyStakeCredentials :: Set StakeAddress - -> Set (Ledger.StakeCredential StandardShelley) - toShelleyStakeCredentials = Set.map (\(StakeAddress _ cred) -> cred) + -> Set (Ledger.StakeCredential ledgerera) + toShelleyStakeCredentials = + Set.map (toShelleyStakeCredential + . fromShelleyStakeCredential + . (\(StakeAddress _ cred) -> cred)) -- ----------------------------------------------------------------------------- @@ -699,6 +759,22 @@ obtainLedgerEraClassConstraints ShelleyBasedEraShelley f = f obtainLedgerEraClassConstraints ShelleyBasedEraAllegra f = f obtainLedgerEraClassConstraints ShelleyBasedEraMary f = f +obtainToJSONNewEpochState + :: ShelleyLedgerEra era ~ ledgerera + => ShelleyBasedEra era + -> (ToJSON (NewEpochState ledgerera) => a) -> a +obtainToJSONNewEpochState ShelleyBasedEraShelley f = f +obtainToJSONNewEpochState ShelleyBasedEraAllegra f = f +obtainToJSONNewEpochState ShelleyBasedEraMary f = f + +obtainStandardCrypto + :: ShelleyLedgerEra era ~ ledgerera + => ShelleyBasedEra era + -> (Ledger.Crypto ledgerera ~ StandardCrypto => a) -> a +obtainStandardCrypto ShelleyBasedEraShelley f = f +obtainStandardCrypto ShelleyBasedEraAllegra f = f +obtainStandardCrypto ShelleyBasedEraMary f = f + --TODO: eliminate this and support multi-asset properly requireValueTypeIsCoin :: ShelleyLedgerEra era ~ ledgerera