diff --git a/cardano-api/src/Cardano/Api/LocalChainSync.hs b/cardano-api/src/Cardano/Api/LocalChainSync.hs index 20e5e450762..eb8defe36f6 100644 --- a/cardano-api/src/Cardano/Api/LocalChainSync.hs +++ b/cardano-api/src/Cardano/Api/LocalChainSync.hs @@ -8,7 +8,6 @@ module Cardano.Api.LocalChainSync import Cardano.Prelude hiding (atomically, catch) import Control.Concurrent.STM - import Cardano.Api.Typed import Ouroboros.Network.Block (Tip) diff --git a/cardano-api/src/Cardano/Api/Protocol.hs b/cardano-api/src/Cardano/Api/Protocol.hs index 3eaa6c4e6f7..e1cf774561e 100644 --- a/cardano-api/src/Cardano/Api/Protocol.hs +++ b/cardano-api/src/Cardano/Api/Protocol.hs @@ -19,66 +19,57 @@ module Cardano.Api.Protocol -- * Node client support -- | Support for the context needed to run a client of a node that is using -- a protocol. - , mkNodeClientProtocol - , SomeNodeClientProtocol(..) + , localNodeConnectInfo + , withlocalNodeConnectInfo + , LocalNodeConnectInfoForSomeMode(..) ) where import Cardano.Prelude -import Control.Monad.Fail (fail) -import Data.Aeson - import Cardano.Chain.Slotting (EpochSlots(..)) -import Cardano.Api.Protocol.Types -import Cardano.Api.Protocol.Byron -import Cardano.Api.Protocol.Cardano -import Cardano.Api.Protocol.Shelley +import Cardano.Api.Typed import qualified Ouroboros.Consensus.Cardano as Consensus +import Ouroboros.Consensus.Node.Run (RunNode) + data Protocol = MockProtocol !MockProtocol - | ByronProtocol + | ByronProtocol !EpochSlots !Consensus.SecurityParam | ShelleyProtocol - | CardanoProtocol - deriving (Eq, Show, Generic) - -instance FromJSON Protocol where - parseJSON = - withText "Protocol" $ \str -> case str of - - -- The new names - "MockBFT" -> pure (MockProtocol MockBFT) - "MockPBFT" -> pure (MockProtocol MockPBFT) - "MockPraos" -> pure (MockProtocol MockPraos) - "Byron" -> pure ByronProtocol - "Shelley" -> pure ShelleyProtocol - "Cardano" -> pure CardanoProtocol - - -- The old names - "BFT" -> pure (MockProtocol MockBFT) - --"MockPBFT" -- same as new name - "Praos" -> pure (MockProtocol MockPraos) - "RealPBFT" -> pure ByronProtocol - "TPraos" -> pure ShelleyProtocol - - _ -> fail $ "Parsing of Protocol failed. " - <> show str <> " is not a valid protocol" - - -deriving instance NFData Protocol -deriving instance NoUnexpectedThunks Protocol + | CardanoProtocol !EpochSlots !Consensus.SecurityParam + deriving (Eq, Show) data MockProtocol = MockBFT | MockPBFT | MockPraos - deriving (Eq, Show, Generic) - -deriving instance NFData MockProtocol -deriving instance NoUnexpectedThunks MockProtocol - -mkNodeClientProtocol :: Protocol -> SomeNodeClientProtocol -mkNodeClientProtocol protocol = + deriving (Eq, Show) + + +data LocalNodeConnectInfoForSomeMode where + + LocalNodeConnectInfoForSomeMode + :: RunNode block + => LocalNodeConnectInfo mode block + -> LocalNodeConnectInfoForSomeMode + +withlocalNodeConnectInfo :: Protocol + -> NetworkId + -> FilePath + -> (forall mode block. + RunNode block + => LocalNodeConnectInfo mode block + -> a) + -> a +withlocalNodeConnectInfo protocol network socketPath f = + case localNodeConnectInfo protocol network socketPath of + LocalNodeConnectInfoForSomeMode connctInfo -> f connctInfo + +localNodeConnectInfo :: Protocol + -> NetworkId + -> FilePath + -> LocalNodeConnectInfoForSomeMode +localNodeConnectInfo protocol network socketPath = case protocol of {- --TODO @@ -93,27 +84,21 @@ mkNodeClientProtocol protocol = panic "TODO: mkNodeClientProtocol NodeProtocolConfigurationMock" -- Real protocols - ByronProtocol -> - mkSomeNodeClientProtocolByron - --TODO: this is only the correct value for mainnet - -- not for Byron testnets. This value is needed because - -- to decode legacy EBBs one needs to know how many - -- slots there are per-epoch. This info comes from - -- the genesis file, but we don't have that in the - -- client case. - (EpochSlots 21600) - (Consensus.SecurityParam 2160) + ByronProtocol epSlots secParam -> + LocalNodeConnectInfoForSomeMode $ + LocalNodeConnectInfo + socketPath network + (ByronMode epSlots secParam) ShelleyProtocol -> - mkSomeNodeClientProtocolShelley - - CardanoProtocol -> - mkSomeNodeClientProtocolCardano - --TODO: this is only the correct value for mainnet - -- not for Byron testnets. This value is needed because - -- to decode legacy EBBs one needs to know how many - -- slots there are per-epoch. This info comes from - -- the genesis file, but we don't have that in the - -- client case. - (EpochSlots 21600) - (Consensus.SecurityParam 2160) + LocalNodeConnectInfoForSomeMode $ + LocalNodeConnectInfo + socketPath network + ShelleyMode + + CardanoProtocol epSlots secParam -> + LocalNodeConnectInfoForSomeMode $ + LocalNodeConnectInfo + socketPath network + (CardanoMode epSlots secParam) + diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Commands.hs b/cardano-cli/src/Cardano/CLI/Shelley/Commands.hs index d2e39f4726c..b445f9c3da8 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Commands.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Commands.hs @@ -44,6 +44,7 @@ import Prelude import Data.Set (Set) import Data.Text (Text) +import Cardano.Api.Protocol (Protocol) import Cardano.Api.Typed hiding (PoolId, Hash) import Ouroboros.Consensus.BlockchainTime (SystemStart (..)) @@ -112,7 +113,7 @@ data TransactionCmd | TxWitness -- { transaction :: Transaction, key :: PrivKeyFile, nodeAddr :: NodeAddress } | TxSignWitness -- { transaction :: Transaction, witnesses :: [Witness], nodeAddr :: NodeAddress } | TxCheck -- { transaction :: Transaction, nodeAddr :: NodeAddress } - | TxSubmit FilePath NetworkId + | TxSubmit Protocol NetworkId FilePath | TxCalculateMinFee TxBodyFile (Maybe NetworkId) @@ -172,13 +173,13 @@ data PoolCmd data QueryCmd = QueryPoolId NodeAddress - | QueryProtocolParameters NetworkId (Maybe OutputFile) - | QueryTip NetworkId (Maybe OutputFile) - | QueryStakeDistribution NetworkId (Maybe OutputFile) - | QueryStakeAddressInfo StakeAddress NetworkId (Maybe OutputFile) - | QueryUTxO QueryFilter NetworkId (Maybe OutputFile) + | QueryProtocolParameters 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) | QueryVersion NodeAddress - | QueryLedgerState NetworkId (Maybe OutputFile) + | QueryLedgerState Protocol NetworkId (Maybe OutputFile) | QueryStatus NodeAddress deriving (Eq, Show) diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs b/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs index 97201aaa87a..2efb8933cec 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs @@ -31,12 +31,16 @@ import qualified Data.Attoparsec.ByteString.Char8 as Atto import Network.Socket (PortNumber) import Network.URI (URI, parseURI) +import Cardano.Chain.Slotting (EpochSlots(..)) import Cardano.Slotting.Slot (SlotNo(..)) import Ouroboros.Consensus.BlockchainTime (SystemStart (..)) +import Ouroboros.Consensus.Cardano (SecurityParam (..)) + import qualified Shelley.Spec.Ledger.BaseTypes as Shelley import qualified Shelley.Spec.Ledger.TxData as Shelley +import Cardano.Api.Protocol (Protocol (..)) import Cardano.Api.Typed hiding (PoolId) import Cardano.Slotting.Slot (EpochNo (..)) @@ -315,8 +319,9 @@ pTransaction = pTransactionCheck = pure TxCheck pTransactionSubmit :: Parser TransactionCmd - pTransactionSubmit = TxSubmit <$> pTxSubmitFile + pTransactionSubmit = TxSubmit <$> pProtocol <*> pNetworkId + <*> pTxSubmitFile pTransactionCalculateMinFee :: Parser TransactionCmd pTransactionCalculateMinFee = @@ -452,29 +457,33 @@ pQueryCmd = pQueryProtocolParameters :: Parser QueryCmd pQueryProtocolParameters = QueryProtocolParameters - <$> pNetworkId + <$> pProtocol + <*> pNetworkId <*> pMaybeOutputFile pQueryTip :: Parser QueryCmd - pQueryTip = QueryTip <$> pNetworkId <*> pMaybeOutputFile + pQueryTip = QueryTip <$> pProtocol <*> pNetworkId <*> pMaybeOutputFile pQueryUTxO :: Parser QueryCmd pQueryUTxO = QueryUTxO - <$> pQueryFilter + <$> pProtocol + <*> pQueryFilter <*> pNetworkId <*> pMaybeOutputFile pQueryStakeDistribution :: Parser QueryCmd pQueryStakeDistribution = QueryStakeDistribution - <$> pNetworkId + <$> pProtocol + <*> pNetworkId <*> pMaybeOutputFile pQueryStakeAddressInfo :: Parser QueryCmd pQueryStakeAddressInfo = QueryStakeAddressInfo - <$> pFilterByStakeAddress + <$> pProtocol + <*> pFilterByStakeAddress <*> pNetworkId <*> pMaybeOutputFile @@ -482,7 +491,7 @@ pQueryCmd = pQueryVersion = QueryVersion <$> parseNodeAddress pQueryLedgerState :: Parser QueryCmd - pQueryLedgerState = QueryLedgerState <$> pNetworkId <*> pMaybeOutputFile + pQueryLedgerState = QueryLedgerState <$> pProtocol <*> pNetworkId <*> pMaybeOutputFile pQueryStatus :: Parser QueryCmd pQueryStatus = QueryStatus <$> parseNodeAddress @@ -1648,6 +1657,68 @@ pExtraEntropy = parseEntropyBytes = (fst . Base16.decode) <$> Atto.takeWhile1 Char.isHexDigit + +pProtocol :: Parser Protocol +pProtocol = + ( Opt.flag' () + ( Opt.long "shelley-mode" + <> Opt.help "For talking to a node running in Shelley-only mode (default)." + ) + *> pShelley + ) + <|> + ( Opt.flag' () + ( Opt.long "byron-mode" + <> Opt.help "For talking to a node running in Byron-only mode." + ) + *> pByron + ) + <|> + ( Opt.flag' () + ( Opt.long "cardano-mode" + <> Opt.help "For talking to a node running in full Cardano mode." + ) + *> pCardano + ) + <|> + -- Default to the Shelley protocol for now, due to the testnet. + pure ShelleyProtocol + where + pByron :: Parser Protocol + pByron = ByronProtocol <$> pEpochSlots <*> pSecurityParam + + pShelley :: Parser Protocol + pShelley = pure ShelleyProtocol + + pCardano :: Parser Protocol + pCardano = CardanoProtocol <$> pEpochSlots <*> pSecurityParam + + pEpochSlots :: Parser EpochSlots + pEpochSlots = + EpochSlots <$> + ( Opt.option Opt.auto + ( Opt.long "epoch-slots" + <> Opt.metavar "NATURAL" + <> Opt.help "The number of slots per epoch (default is 21600)." + ) + <|> + -- Default to the mainnet value. + pure 21600 + ) + + pSecurityParam :: Parser SecurityParam + pSecurityParam = + SecurityParam <$> + ( Opt.option Opt.auto + ( Opt.long "security-param" + <> Opt.metavar "NATURAL" + <> Opt.help "The security parameter (default is 2160)." + ) + <|> + -- Default to the mainnet value. + pure 2160 + ) + pProtocolVersion :: Parser (Natural, Natural) pProtocolVersion = (,) <$> pProtocolMajorVersion <*> pProtocolMinorVersion diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs index 3298babe420..4c9583607ca 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs @@ -41,6 +41,7 @@ import Control.Monad.Trans.Except.Extra (firstExceptT, handleIOExceptT newExceptT) import Cardano.Api.Typed +import Cardano.Api.Protocol import Cardano.Api.LocalChainSync (getLocalTip) import Cardano.CLI.Shelley.Commands (QueryFilter(..)) @@ -52,9 +53,9 @@ import Cardano.Config.Shelley.Orphans () import Cardano.Config.Types (SocketPath(..)) import Cardano.Binary (decodeFull) -import Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock) +import Ouroboros.Consensus.Cardano.Block (Either (..), EraMismatch (..), Query (..)) import Ouroboros.Consensus.Shelley.Protocol.Crypto (TPraosStandardCrypto) -import Ouroboros.Network.Block (Point, getTipPoint) +import Ouroboros.Network.Block (getTipPoint) import qualified Shelley.Spec.Ledger.Address as Ledger @@ -78,7 +79,7 @@ import Ouroboros.Network.Protocol.LocalStateQuery.Type as LocalStateQu data ShelleyQueryCmdError = ShelleyQueryEnvVarSocketErr !EnvSocketError - | NodeLocalStateQueryError !LocalStateQuery.AcquireFailure + | ShelleyQueryNodeLocalStateQueryError !LocalStateQueryError | ShelleyQueryWriteProtocolParamsError !FilePath !IOException | ShelleyQueryWriteFilteredUTxOsError !FilePath !IOException | ShelleyQueryWriteStakeDistributionError !FilePath !IOException @@ -91,8 +92,7 @@ renderShelleyQueryCmdError :: ShelleyQueryCmdError -> Text renderShelleyQueryCmdError err = case err of ShelleyQueryEnvVarSocketErr envSockErr -> renderEnvSocketError envSockErr - NodeLocalStateQueryError lsqErr -> - "Local state query acquire failure: " <> show lsqErr + ShelleyQueryNodeLocalStateQueryError lsqErr -> renderLocalStateQueryError lsqErr ShelleyQueryWriteProtocolParamsError fp ioException -> "Error writing protocol parameters at: " <> show fp <> " Error: " <> show ioException ShelleyQueryWriteFilteredUTxOsError fp ioException -> @@ -108,36 +108,33 @@ renderShelleyQueryCmdError err = runQueryCmd :: QueryCmd -> ExceptT ShelleyQueryCmdError IO () runQueryCmd cmd = case cmd of - QueryProtocolParameters network mOutFile -> - runQueryProtocolParameters network mOutFile - QueryTip network mOutFile -> - runQueryTip network mOutFile - QueryStakeDistribution network mOutFile -> - runQueryStakeDistribution network mOutFile - QueryStakeAddressInfo addr network mOutFile -> - runQueryStakeAddressInfo addr network mOutFile - QueryLedgerState network mOutFile -> - runQueryLedgerState network mOutFile - QueryUTxO qFilter networkId mOutFile -> - runQueryUTxO qFilter networkId mOutFile + QueryProtocolParameters protocol network mOutFile -> + runQueryProtocolParameters 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 + QueryUTxO protocol qFilter networkId mOutFile -> + runQueryUTxO protocol qFilter networkId mOutFile _ -> liftIO $ putStrLn $ "runQueryCmd: " ++ show cmd + runQueryProtocolParameters - :: NetworkId + :: Protocol + -> NetworkId -> Maybe OutputFile -> ExceptT ShelleyQueryCmdError IO () -runQueryProtocolParameters network mOutFile = do - SocketPath sockPath <- firstExceptT ShelleyQueryEnvVarSocketErr readEnvSocketPath - let connectInfo = - LocalNodeConnectInfo { - localNodeSocketPath = sockPath, - localNodeNetworkId = network, - localNodeConsensusMode = ShelleyMode - } - tip <- liftIO $ getLocalTip connectInfo - pparams <- firstExceptT NodeLocalStateQueryError $ - queryPParamsFromLocalState connectInfo (getTipPoint tip) - writeProtocolParameters mOutFile pparams +runQueryProtocolParameters protocol network mOutFile = do + SocketPath sockPath <- firstExceptT ShelleyQueryEnvVarSocketErr + readEnvSocketPath + pparams <- firstExceptT ShelleyQueryNodeLocalStateQueryError $ + withlocalNodeConnectInfo protocol network sockPath $ + queryPParamsFromLocalState + writeProtocolParameters mOutFile pparams writeProtocolParameters :: Maybe OutputFile -> PParams -> ExceptT ShelleyQueryCmdError IO () writeProtocolParameters mOutFile pparams = @@ -148,56 +145,47 @@ writeProtocolParameters mOutFile pparams = LBS.writeFile fpath (encodePretty pparams) runQueryTip - :: NetworkId + :: Protocol + -> NetworkId -> Maybe OutputFile -> ExceptT ShelleyQueryCmdError IO () -runQueryTip network mOutFile = do - SocketPath sockPath <- firstExceptT ShelleyQueryEnvVarSocketErr readEnvSocketPath - let connectInfo = - LocalNodeConnectInfo { - localNodeSocketPath = sockPath, - localNodeNetworkId = network, - localNodeConsensusMode = ShelleyMode - } - tip <- liftIO $ getLocalTip connectInfo - case mOutFile of - Just (OutputFile fpath) -> liftIO . LBS.writeFile fpath $ encodePretty tip - Nothing -> liftIO $ LBS.putStrLn (encodePretty tip) +runQueryTip protocol network mOutFile = do + SocketPath sockPath <- firstExceptT ShelleyQueryEnvVarSocketErr readEnvSocketPath + output <- + firstExceptT ShelleyQueryNodeLocalStateQueryError $ + withlocalNodeConnectInfo protocol network sockPath $ \connectInfo -> do + tip <- liftIO $ getLocalTip connectInfo + let output = case localNodeConsensusMode connectInfo of + ByronMode{} -> encodePretty tip + ShelleyMode{} -> encodePretty tip + CardanoMode{} -> encodePretty tip + return output + case mOutFile of + Just (OutputFile fpath) -> liftIO $ LBS.writeFile fpath output + Nothing -> liftIO $ LBS.putStrLn output runQueryUTxO - :: QueryFilter + :: Protocol + -> QueryFilter -> NetworkId -> Maybe OutputFile -> ExceptT ShelleyQueryCmdError IO () -runQueryUTxO qfilter network mOutFile = do +runQueryUTxO protocol qfilter network mOutFile = do SocketPath sockPath <- firstExceptT ShelleyQueryEnvVarSocketErr readEnvSocketPath - let connectInfo = - LocalNodeConnectInfo { - localNodeSocketPath = sockPath, - localNodeNetworkId = network, - localNodeConsensusMode = ShelleyMode - } - tip <- liftIO $ getLocalTip connectInfo - filteredUtxo <- firstExceptT NodeLocalStateQueryError $ - queryUTxOFromLocalState connectInfo qfilter (getTipPoint tip) + filteredUtxo <- firstExceptT ShelleyQueryNodeLocalStateQueryError $ + withlocalNodeConnectInfo protocol network sockPath (queryUTxOFromLocalState qfilter) writeFilteredUTxOs mOutFile filteredUtxo runQueryLedgerState - :: NetworkId + :: Protocol + -> NetworkId -> Maybe OutputFile -> ExceptT ShelleyQueryCmdError IO () -runQueryLedgerState network mOutFile = do +runQueryLedgerState protocol network mOutFile = do SocketPath sockPath <- firstExceptT ShelleyQueryEnvVarSocketErr readEnvSocketPath - let connectInfo = - LocalNodeConnectInfo { - localNodeSocketPath = sockPath, - localNodeNetworkId = network, - localNodeConsensusMode = ShelleyMode - } - tip <- liftIO $ getLocalTip connectInfo - els <- firstExceptT NodeLocalStateQueryError $ - queryLocalLedgerState connectInfo (getTipPoint tip) + els <- firstExceptT ShelleyQueryNodeLocalStateQueryError $ + withlocalNodeConnectInfo protocol network sockPath queryLocalLedgerState case els of Right lstate -> writeLedgerState mOutFile lstate Left lbs -> do @@ -205,24 +193,19 @@ runQueryLedgerState network mOutFile = do firstExceptT ShelleyHelpersError $ pPrintCBOR lbs runQueryStakeAddressInfo - :: StakeAddress + :: Protocol + -> StakeAddress -> NetworkId -> Maybe OutputFile -> ExceptT ShelleyQueryCmdError IO () -runQueryStakeAddressInfo addr network mOutFile = do +runQueryStakeAddressInfo protocol addr network mOutFile = do SocketPath sockPath <- firstExceptT ShelleyQueryEnvVarSocketErr readEnvSocketPath - let connectInfo = - LocalNodeConnectInfo { - localNodeSocketPath = sockPath, - localNodeNetworkId = network, - localNodeConsensusMode = ShelleyMode - } - tip <- liftIO $ getLocalTip connectInfo - delegsAndRwds <- firstExceptT NodeLocalStateQueryError $ - queryDelegationsAndRewardsFromLocalState - connectInfo - (Set.singleton addr) - (getTipPoint tip) + delegsAndRwds <- firstExceptT ShelleyQueryNodeLocalStateQueryError $ + withlocalNodeConnectInfo + protocol + network + sockPath + (queryDelegationsAndRewardsFromLocalState (Set.singleton addr)) writeStakeAddressInfo mOutFile delegsAndRwds -- ------------------------------------------------------------------------------------------------- @@ -230,8 +213,22 @@ runQueryStakeAddressInfo addr network mOutFile = do -- | An error that can occur while querying a node's local state. data LocalStateQueryError = AcquireFailureError !LocalStateQuery.AcquireFailure + | EraMismatchError !EraMismatch + -- ^ A query from a certain era was applied to a ledger from a different + -- era. + | ByronProtocolNotSupportedError + -- ^ The query does not support the Byron protocol. deriving (Eq, Show) +renderLocalStateQueryError :: LocalStateQueryError -> Text +renderLocalStateQueryError lsqErr = + case lsqErr of + AcquireFailureError err -> "Local state query acquire failure: " <> show err + EraMismatchError err -> + "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." + writeStakeAddressInfo :: Maybe OutputFile -> DelegationsAndRewards @@ -284,20 +281,18 @@ printFilteredUTxOs (Ledger.UTxO utxo) = do in Text.pack $ replicate (max 1 (len - slen)) ' ' ++ str runQueryStakeDistribution - :: NetworkId + :: Protocol + -> NetworkId -> Maybe OutputFile -> ExceptT ShelleyQueryCmdError IO () -runQueryStakeDistribution network mOutFile = do +runQueryStakeDistribution protocol network mOutFile = do SocketPath sockPath <- firstExceptT ShelleyQueryEnvVarSocketErr readEnvSocketPath - let connectInfo = - LocalNodeConnectInfo { - localNodeSocketPath = sockPath, - localNodeNetworkId = network, - localNodeConsensusMode = ShelleyMode - } - tip <- liftIO $ getLocalTip connectInfo - stakeDist <- firstExceptT NodeLocalStateQueryError $ - queryStakeDistributionFromLocalState connectInfo (getTipPoint tip) + stakeDist <- firstExceptT ShelleyQueryNodeLocalStateQueryError $ + withlocalNodeConnectInfo + protocol + network + sockPath + queryStakeDistributionFromLocalState writeStakeDistribution mOutFile stakeDist writeStakeDistribution :: Maybe OutputFile @@ -344,15 +339,29 @@ printStakeDistribution (PoolDistr stakeDist) = do -- This one is Shelley-specific because the query is Shelley-specific. -- queryUTxOFromLocalState - :: LocalNodeConnectInfo ShelleyMode (ShelleyBlock TPraosStandardCrypto) - -> QueryFilter - -> Point (ShelleyBlock TPraosStandardCrypto) - -> ExceptT LocalStateQuery.AcquireFailure IO (Ledger.UTxO TPraosStandardCrypto) -queryUTxOFromLocalState connctInfo qFilter point = - newExceptT $ - queryNodeLocalState - connctInfo - (point, applyUTxOFilter qFilter) + :: QueryFilter + -> LocalNodeConnectInfo mode block + -> ExceptT LocalStateQueryError IO (Ledger.UTxO TPraosStandardCrypto) +queryUTxOFromLocalState qFilter connectInfo@LocalNodeConnectInfo{localNodeConsensusMode} = + case localNodeConsensusMode of + ByronMode{} -> throwError ByronProtocolNotSupportedError + + ShelleyMode{} -> do + tip <- liftIO $ getLocalTip connectInfo + firstExceptT AcquireFailureError . newExceptT $ + queryNodeLocalState + connectInfo + (getTipPoint tip, applyUTxOFilter qFilter) + + CardanoMode{} -> do + tip <- liftIO $ getLocalTip connectInfo + result <- firstExceptT AcquireFailureError . newExceptT $ + queryNodeLocalState + connectInfo + (getTipPoint tip, QueryIfCurrentShelley (applyUTxOFilter qFilter)) + case result of + QueryResultEraMismatch err -> throwError (EraMismatchError err) + QueryResultSuccess utxo -> return utxo where applyUTxOFilter (FilterByAddress as) = GetFilteredUTxO (toShelleyAddrs as) applyUTxOFilter NoFilter = GetUTxO @@ -400,16 +409,34 @@ instance ToJSON DelegationsAndRewards where -- This one is Shelley-specific because the query is Shelley-specific. -- queryPParamsFromLocalState - :: blk ~ ShelleyBlock TPraosStandardCrypto - => LocalNodeConnectInfo ShelleyMode blk - -> Point blk - -> ExceptT LocalStateQuery.AcquireFailure IO PParams -queryPParamsFromLocalState connctInfo point = do - let pointAndQuery = (point, GetCurrentPParams) - newExceptT $ liftIO $ - queryNodeLocalState - connctInfo - pointAndQuery + :: LocalNodeConnectInfo mode block + -> ExceptT LocalStateQueryError IO PParams +queryPParamsFromLocalState LocalNodeConnectInfo{ + localNodeConsensusMode = ByronMode{} + } = + throwError ByronProtocolNotSupportedError + +queryPParamsFromLocalState connectInfo@LocalNodeConnectInfo{ + localNodeConsensusMode = ShelleyMode + } = do + tip <- liftIO $ getLocalTip connectInfo + firstExceptT AcquireFailureError . newExceptT $ + queryNodeLocalState + connectInfo + (getTipPoint tip, GetCurrentPParams) + +queryPParamsFromLocalState connectInfo@LocalNodeConnectInfo{ + localNodeConsensusMode = CardanoMode{} + } = do + tip <- liftIO $ getLocalTip connectInfo + result <- firstExceptT AcquireFailureError . newExceptT $ + queryNodeLocalState + connectInfo + (getTipPoint tip, QueryIfCurrentShelley GetCurrentPParams) + case result of + QueryResultEraMismatch eraerr -> throwError (EraMismatchError eraerr) + QueryResultSuccess pparams -> return pparams + -- | Query the current stake distribution from a Shelley node via the local -- state query protocol. @@ -417,29 +444,59 @@ queryPParamsFromLocalState connctInfo point = do -- This one is Shelley-specific because the query is Shelley-specific. -- queryStakeDistributionFromLocalState - :: blk ~ ShelleyBlock TPraosStandardCrypto - => LocalNodeConnectInfo ShelleyMode blk - -> Point blk - -> ExceptT LocalStateQuery.AcquireFailure IO (Ledger.PoolDistr TPraosStandardCrypto) -queryStakeDistributionFromLocalState connctInfo point = do - let pointAndQuery = (point, GetStakeDistribution) - newExceptT $ liftIO $ + :: LocalNodeConnectInfo mode block + -> ExceptT LocalStateQueryError IO (Ledger.PoolDistr TPraosStandardCrypto) +queryStakeDistributionFromLocalState LocalNodeConnectInfo{ + localNodeConsensusMode = ByronMode{} + } = + throwError ByronProtocolNotSupportedError + +queryStakeDistributionFromLocalState connectInfo@LocalNodeConnectInfo{ + localNodeConsensusMode = ShelleyMode{} + } = do + tip <- liftIO $ getLocalTip connectInfo + firstExceptT AcquireFailureError . newExceptT $ queryNodeLocalState - connctInfo - pointAndQuery + connectInfo + (getTipPoint tip, GetStakeDistribution) + +queryStakeDistributionFromLocalState connectInfo@LocalNodeConnectInfo{ + localNodeConsensusMode = CardanoMode{} + } = do + tip <- liftIO $ getLocalTip connectInfo + result <- firstExceptT AcquireFailureError . newExceptT $ + queryNodeLocalState + connectInfo + (getTipPoint tip, QueryIfCurrentShelley GetStakeDistribution) + case result of + QueryResultEraMismatch err -> throwError (EraMismatchError err) + QueryResultSuccess stakeDist -> return stakeDist queryLocalLedgerState - :: blk ~ ShelleyBlock TPraosStandardCrypto - => LocalNodeConnectInfo ShelleyMode blk - -> Point blk - -> ExceptT LocalStateQuery.AcquireFailure IO + :: LocalNodeConnectInfo mode blk + -> ExceptT LocalStateQueryError IO (Either LByteString (Ledger.EpochState TPraosStandardCrypto)) -queryLocalLedgerState connctInfo point = - fmap decodeLedgerState $ - newExceptT . liftIO $ - queryNodeLocalState - connctInfo - (point, GetCBOR GetCurrentEpochState) -- Get CBOR-in-CBOR version +queryLocalLedgerState connectInfo@LocalNodeConnectInfo{localNodeConsensusMode} = + case localNodeConsensusMode of + ByronMode{} -> throwError ByronProtocolNotSupportedError + + ShelleyMode{} -> do + tip <- liftIO $ getLocalTip connectInfo + fmap decodeLedgerState $ + firstExceptT AcquireFailureError . newExceptT $ + queryNodeLocalState + connectInfo + (getTipPoint tip, GetCBOR GetCurrentEpochState) -- Get CBOR-in-CBOR version + + CardanoMode{} -> do + tip <- liftIO $ getLocalTip connectInfo + result <- firstExceptT AcquireFailureError . newExceptT $ + queryNodeLocalState + connectInfo + (getTipPoint tip, QueryIfCurrentShelley (GetCBOR GetCurrentEpochState)) -- Get CBOR-in-CBOR version + case result of + QueryResultEraMismatch err -> throwError (EraMismatchError err) + QueryResultSuccess ls -> return (decodeLedgerState ls) where -- If decode as a LedgerState fails we return the ByteString so we can do a generic -- CBOR decode. @@ -453,17 +510,38 @@ queryLocalLedgerState connctInfo point = -- This one is Shelley-specific because the query is Shelley-specific. -- queryDelegationsAndRewardsFromLocalState - :: LocalNodeConnectInfo ShelleyMode (ShelleyBlock TPraosStandardCrypto) - -> Set StakeAddress - -> Point (ShelleyBlock TPraosStandardCrypto) - -> ExceptT LocalStateQuery.AcquireFailure IO DelegationsAndRewards -queryDelegationsAndRewardsFromLocalState connctInfo stakeaddrs point = - fmap (uncurry toDelegsAndRwds) $ - newExceptT $ liftIO $ - queryNodeLocalState - connctInfo - (point, GetFilteredDelegationsAndRewardAccounts - (toShelleyStakeCredentials stakeaddrs)) + :: Set StakeAddress + -> LocalNodeConnectInfo mode block + -> ExceptT LocalStateQueryError IO DelegationsAndRewards +queryDelegationsAndRewardsFromLocalState stakeaddrs + connectInfo@LocalNodeConnectInfo{ + localNodeConsensusMode + } = + case localNodeConsensusMode of + ByronMode{} -> throwError ByronProtocolNotSupportedError + + ShelleyMode{} -> do + tip <- liftIO $ getLocalTip connectInfo + fmap (uncurry toDelegsAndRwds) $ + firstExceptT AcquireFailureError . newExceptT $ + queryNodeLocalState + connectInfo + (getTipPoint tip, GetFilteredDelegationsAndRewardAccounts + (toShelleyStakeCredentials stakeaddrs)) + + CardanoMode{} -> do + tip <- liftIO $ getLocalTip connectInfo + result <- firstExceptT AcquireFailureError . newExceptT $ + queryNodeLocalState + connectInfo + ( getTipPoint tip + , QueryIfCurrentShelley $ + GetFilteredDelegationsAndRewardAccounts + (toShelleyStakeCredentials stakeaddrs) + ) + case result of + QueryResultEraMismatch err -> throwError (EraMismatchError err) + QueryResultSuccess drs -> return $ (uncurry toDelegsAndRwds) drs where toDelegsAndRwds :: Map (Ledger.Credential Ledger.Staking TPraosStandardCrypto) @@ -479,4 +557,3 @@ queryDelegationsAndRewardsFromLocalState connctInfo stakeaddrs point = toShelleyStakeCredentials :: Set StakeAddress -> Set (Ledger.StakeCredential TPraosStandardCrypto) toShelleyStakeCredentials = Set.map (\(StakeAddress _ cred) -> cred) - diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs index 955d5a9cd08..36727ede5df 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs @@ -1,4 +1,6 @@ {-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} + {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module Cardano.CLI.Shelley.Run.Transaction @@ -21,25 +23,31 @@ import qualified Data.Map.Strict as Map import qualified Data.HashMap.Strict as HashMap import qualified Data.Vector as Vector -import Cardano.Api.Typed as Api -import Cardano.Api.TxSubmit as Api +import Control.Monad.Trans.Except (ExceptT) +import Control.Monad.Trans.Except.Extra + (firstExceptT, left, newExceptT, hoistEither, handleIOExceptT) --TODO: do this nicely via the API too: import qualified Cardano.Binary as CBOR -import Cardano.CLI.Environment (EnvSocketError, readEnvSocketPath, - renderEnvSocketError) +import qualified Shelley.Spec.Ledger.PParams as Shelley -import Cardano.Config.Types +import Ouroboros.Consensus.Ledger.SupportsMempool (ApplyTxErr) +import Ouroboros.Consensus.Byron.Ledger (ByronBlock) +import Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock) +import Ouroboros.Consensus.Shelley.Protocol.Crypto (TPraosStandardCrypto) +import Ouroboros.Consensus.Cardano.Block + (HardForkApplyTxErr (ApplyTxErrByron, + ApplyTxErrShelley, ApplyTxErrWrongEra), EraMismatch (..)) +import Cardano.Config.Types import Cardano.CLI.Shelley.Parsers -import Cardano.Config.Types (CertificateFile (..)) - -import qualified Shelley.Spec.Ledger.PParams as Shelley +import Cardano.CLI.Environment (EnvSocketError, readEnvSocketPath, + renderEnvSocketError) -import Control.Monad.Trans.Except (ExceptT) -import Control.Monad.Trans.Except.Extra - (firstExceptT, left, newExceptT, hoistEither, handleIOExceptT) +import Cardano.Api.Typed as Api +import Cardano.Api.Protocol +import Cardano.Api.TxSubmit as Api data ShelleyTxCmdError @@ -55,7 +63,9 @@ data ShelleyTxCmdError | ShelleyTxCertReadError !(Api.FileError Api.TextEnvelopeError) | ShelleyTxWriteSignedTxError !(Api.FileError ()) | ShelleyTxWriteUnsignedTxError !(Api.FileError ()) - | ShelleyTxSubmitError !(TxSubmitResultForMode ShelleyMode) + | ShelleyTxSubmitErrorByron !(ApplyTxErr ByronBlock) + | ShelleyTxSubmitErrorShelley !(ApplyTxErr (ShelleyBlock TPraosStandardCrypto)) + | ShelleyTxSubmitErrorEraMismatch !EraMismatch | ShelleyTxReadFileError !(Api.FileError Api.TextEnvelopeError) deriving Show @@ -87,8 +97,14 @@ renderShelleyTxCmdError err = "Error while writing signed shelley tx: " <> Text.pack (Api.displayError err') ShelleyTxWriteUnsignedTxError err' -> "Error while writing unsigned shelley tx: " <> Text.pack (Api.displayError err') - ShelleyTxSubmitError res -> + ShelleyTxSubmitErrorByron res -> + "Error while submitting tx: " <> Text.pack (show res) + ShelleyTxSubmitErrorShelley res -> "Error while submitting tx: " <> Text.pack (show res) + ShelleyTxSubmitErrorEraMismatch EraMismatch{ledgerEraName, otherEraName} -> + "The era of the node and the tx do not match. " <> + "The node is running in the " <> ledgerEraName <> + " era, but the transaction is for the " <> otherEraName <> " era." ShelleyTxReadFileError fileErr -> Text.pack (Api.displayError fileErr) ShelleyTxMissingNetworkId -> "Please enter network id with your byron transaction" @@ -99,8 +115,8 @@ runTransactionCmd cmd = runTxBuildRaw txins txouts ttl fee certs wdrls mMetaData mUpProp out TxSign txinfile skfiles network txoutfile -> runTxSign txinfile skfiles network txoutfile - TxSubmit txFp network -> - runTxSubmit txFp network + TxSubmit protocol network txFp -> + runTxSubmit protocol network txFp TxCalculateMinFee txbody mnw pParamsFile nInputs nOutputs nShelleyKeyWitnesses nByronKeyWitnesses -> runTxCalculateMinFee txbody mnw pParamsFile nInputs nOutputs @@ -205,22 +221,55 @@ runTxSign (TxBodyFile txbodyFile) skFiles mnw (TxFile txFile) = do AGenesisDelegateSigningKey sk -> Right (Api.WitnessGenesisDelegateKey sk) AGenesisUTxOSigningKey sk -> Right (Api.WitnessGenesisUTxOKey sk) -runTxSubmit :: FilePath -> NetworkId -> ExceptT ShelleyTxCmdError IO () -runTxSubmit txFp network = do - SocketPath sktFp <- firstExceptT ShelleyTxSocketEnvError $ readEnvSocketPath - signedTx <- firstExceptT ShelleyTxReadFileError +runTxSubmit :: Protocol -> NetworkId -> FilePath + -> ExceptT ShelleyTxCmdError IO () +runTxSubmit protocol network txFile = do + SocketPath sockPath <- firstExceptT ShelleyTxSocketEnvError $ readEnvSocketPath + tx <- firstExceptT ShelleyTxReadFileError . newExceptT - $ Api.readFileTextEnvelope Api.AsShelleyTx txFp - let connectInfo = - LocalNodeConnectInfo { - localNodeSocketPath = sktFp, - localNodeNetworkId = network, - localNodeConsensusMode = ShelleyMode - } - result <- liftIO $ Api.submitTx connectInfo (TxForShelleyMode signedTx) - case result of - TxSubmitSuccess -> return () - TxSubmitFailureShelleyMode{} -> left (ShelleyTxSubmitError result) + $ Api.readFileTextEnvelopeAnyOf + [ Api.FromSomeType Api.AsByronTx Left + , Api.FromSomeType Api.AsShelleyTx Right ] + txFile + + withlocalNodeConnectInfo protocol network sockPath $ \connectInfo -> + case (localNodeConsensusMode connectInfo, tx) of + (ByronMode{}, Left tx') -> do + result <- liftIO $ Api.submitTx connectInfo (TxForByronMode tx') + case result of + TxSubmitSuccess -> return () + TxSubmitFailureByronMode err -> + left (ShelleyTxSubmitErrorByron err) + + (ByronMode{}, Right{}) -> + left $ ShelleyTxSubmitErrorEraMismatch EraMismatch { + ledgerEraName = "Byron", + otherEraName = "Shelley" + } + + (ShelleyMode{}, Right tx') -> do + result <- liftIO $ Api.submitTx connectInfo (TxForShelleyMode tx') + case result of + TxSubmitSuccess -> return () + TxSubmitFailureShelleyMode err -> + left (ShelleyTxSubmitErrorShelley err) + + (ShelleyMode{}, Left{}) -> + left $ ShelleyTxSubmitErrorEraMismatch EraMismatch { + ledgerEraName = "Shelley", + otherEraName = "Byron" + } + + (CardanoMode{}, tx') -> do + result <- liftIO $ Api.submitTx connectInfo (TxForCardanoMode tx') + case result of + TxSubmitSuccess -> return () + TxSubmitFailureCardanoMode (ApplyTxErrByron err) -> + left (ShelleyTxSubmitErrorByron err) + TxSubmitFailureCardanoMode (ApplyTxErrShelley err) -> + left (ShelleyTxSubmitErrorShelley err) + TxSubmitFailureCardanoMode (ApplyTxErrWrongEra mismatch) -> + left (ShelleyTxSubmitErrorEraMismatch mismatch) runTxCalculateMinFee diff --git a/cardano-config/src/Cardano/Config/Orphanage.hs b/cardano-config/src/Cardano/Config/Orphanage.hs index 3d48aea8b08..70ba9b76a05 100644 --- a/cardano-config/src/Cardano/Config/Orphanage.hs +++ b/cardano-config/src/Cardano/Config/Orphanage.hs @@ -14,13 +14,17 @@ import Cardano.Prelude import qualified Prelude import Data.Aeson +import qualified Data.ByteString.Base16 as B16 import Data.Scientific (coefficient) import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text import Network.Socket (PortNumber) import Cardano.BM.Data.Tracer (TracingVerbosity(..)) import qualified Cardano.Chain.Update as Update import Cardano.Slotting.Block (BlockNo (..)) +import Ouroboros.Consensus.Byron.Ledger.Block (ByronHash(..)) +import Ouroboros.Consensus.HardFork.Combinator (OneEraHash (..)) import Ouroboros.Consensus.NodeId (CoreNodeId (..)) import Ouroboros.Network.Block (HeaderHash, Tip (..)) @@ -64,4 +68,8 @@ instance ToJSON (HeaderHash blk) => ToJSON (Tip blk) where , "blockNo" .= blockNo ] +instance ToJSON (OneEraHash xs) where + toJSON (OneEraHash bs) = toJSON . Text.decodeLatin1 . B16.encode $ bs + +deriving newtype instance ToJSON ByronHash deriving newtype instance ToJSON BlockNo diff --git a/cardano-node/cardano-node.cabal b/cardano-node/cardano-node.cabal index 26c9926d076..e46858631d3 100644 --- a/cardano-node/cardano-node.cabal +++ b/cardano-node/cardano-node.cabal @@ -202,6 +202,7 @@ executable chairman , containers , cardano-api , cardano-config + , cardano-ledger , cardano-prelude , contra-tracer , cardano-prelude diff --git a/cardano-node/chairman/chairman.hs b/cardano-node/chairman/chairman.hs index 04d41413909..41760b6d662 100644 --- a/cardano-node/chairman/chairman.hs +++ b/cardano-node/chairman/chairman.hs @@ -15,12 +15,17 @@ import qualified Options.Applicative as Opt import Ouroboros.Consensus.BlockchainTime (SlotLength, slotLengthFromSec) import Ouroboros.Consensus.Cardano (SecurityParam(..)) import Ouroboros.Network.Block (BlockNo) +import Cardano.Chain.Slotting (EpochSlots(..)) import Cardano.Api.Typed (NetworkMagic(..)) -import Cardano.Api.Protocol (mkNodeClientProtocol) +import Cardano.Api.Protocol.Types +import Cardano.Api.Protocol.Byron +import Cardano.Api.Protocol.Cardano +import Cardano.Api.Protocol.Shelley import Cardano.Config.Types (SocketPath(..)) -import Cardano.Node.Types (ConfigYamlFilePath(..), - ncProtocol, parseNodeConfigurationFP) +import Cardano.Node.Types + (ConfigYamlFilePath(..), parseNodeConfigurationFP, + Protocol(..), ncProtocol) import Cardano.Config.Parsers import Cardano.Chairman (chairmanTest) @@ -49,6 +54,25 @@ main = do someNodeClientProtocol caNetworkMagic +--TODO: replace this with the new stuff from Cardano.Api.Protocol +mkNodeClientProtocol :: Protocol -> SomeNodeClientProtocol +mkNodeClientProtocol protocol = + case protocol of + MockProtocol _ -> + panic "TODO: mkNodeClientProtocol NodeProtocolConfigurationMock" + + -- Real protocols + ByronProtocol -> + mkSomeNodeClientProtocolByron + (EpochSlots 21600) (SecurityParam 2160) + + ShelleyProtocol -> + mkSomeNodeClientProtocolShelley + + CardanoProtocol -> + mkSomeNodeClientProtocolCardano + (EpochSlots 21600) (SecurityParam 2160) + data ChairmanArgs = ChairmanArgs { -- | Stop the test after given number of seconds. The chairman will -- observe only for the given period of time, and check the consensus diff --git a/cardano-node/src/Cardano/Node/Protocol.hs b/cardano-node/src/Cardano/Node/Protocol.hs index 018a6ce5428..a3e4e968a39 100644 --- a/cardano-node/src/Cardano/Node/Protocol.hs +++ b/cardano-node/src/Cardano/Node/Protocol.hs @@ -12,9 +12,8 @@ import Cardano.Prelude import Control.Monad.Trans.Except (ExceptT) import Control.Monad.Trans.Except.Extra (firstExceptT) -import Cardano.Api.Protocol (MockProtocol(..)) import Cardano.Node.Types (NodeConfiguration(..), NodeProtocolConfiguration(..), - NodeMockProtocolConfiguration(..)) + NodeMockProtocolConfiguration(..), MockProtocol(..)) import Cardano.Config.Types (ProtocolFilepaths(..)) import Cardano.Node.Protocol.Types (SomeConsensusProtocol(..)) diff --git a/cardano-node/src/Cardano/Node/TUI/Drawing.hs b/cardano-node/src/Cardano/Node/TUI/Drawing.hs index 199872aff92..5f953d34dbd 100644 --- a/cardano-node/src/Cardano/Node/TUI/Drawing.hs +++ b/cardano-node/src/Cardano/Node/TUI/Drawing.hs @@ -41,7 +41,7 @@ import qualified Graphics.Vty as Vty import Numeric (showFFloat) import Text.Printf (printf) -import Cardano.Api.Protocol(Protocol(..)) +import Cardano.Node.Types (Protocol(..)) import Cardano.Tracing.Peer (Peer(..), ppPeer) data ColorTheme diff --git a/cardano-node/src/Cardano/Node/TUI/EventHandler.hs b/cardano-node/src/Cardano/Node/TUI/EventHandler.hs index c6c80cd42b5..03ab2ddc0c3 100644 --- a/cardano-node/src/Cardano/Node/TUI/EventHandler.hs +++ b/cardano-node/src/Cardano/Node/TUI/EventHandler.hs @@ -24,12 +24,12 @@ import Data.Time.Clock (diffUTCTime, getCurrentTime) import Data.Version (showVersion) import qualified Graphics.Vty as Vty -import Cardano.Api.Protocol (Protocol(..), MockProtocol(..)) import Cardano.BM.Data.Aggregated (Measurable(..)) import Cardano.BM.Data.Backend (BackendKind(..), IsBackend(..), IsEffectuator(..)) import Cardano.BM.Data.Counter (Platform(..)) import Cardano.BM.Data.LogItem (LogObject(..), LOContent(..), LOMeta(..), utc2ns) import Cardano.Config.GitRev (gitRev) +import Cardano.Node.Types (Protocol(..), MockProtocol(..)) import Cardano.Node.TUI.Drawing (ColorTheme(..), LiveViewState(..), LiveViewThread(..), Screen(..), darkTheme, drawUI, lightTheme) diff --git a/cardano-node/src/Cardano/Node/Types.hs b/cardano-node/src/Cardano/Node/Types.hs index 26e1313389c..f95faa9c889 100644 --- a/cardano-node/src/Cardano/Node/Types.hs +++ b/cardano-node/src/Cardano/Node/Types.hs @@ -1,11 +1,16 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralisedNewtypeDeriving #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE StandaloneDeriving #-} module Cardano.Node.Types ( ConfigYamlFilePath(..) , NodeCLI(..) , NodeConfiguration(..) + , Protocol(..) + , MockProtocol(..) , NodeByronProtocolConfiguration(..) , NodeHardForkProtocolConfiguration(..) , NodeProtocolConfiguration(..) @@ -28,7 +33,7 @@ import System.FilePath ((), takeDirectory) import System.Posix.Types (Fd) import Cardano.Api.Typed (EpochNo) -import Cardano.Api.Protocol +--import Cardano.Api.Protocol import Cardano.Config.Types import Cardano.Crypto (RequiresNetworkMagic(..)) import qualified Cardano.Chain.Update as Byron @@ -205,6 +210,45 @@ instance FromJSON NodeConfiguration where npcTestShelleyHardForkAtVersion } +data Protocol = MockProtocol !MockProtocol + | ByronProtocol + | ShelleyProtocol + | CardanoProtocol + deriving (Eq, Show, Generic) + +instance FromJSON Protocol where + parseJSON = + withText "Protocol" $ \str -> case str of + + -- The new names + "MockBFT" -> pure (MockProtocol MockBFT) + "MockPBFT" -> pure (MockProtocol MockPBFT) + "MockPraos" -> pure (MockProtocol MockPraos) + "Byron" -> pure ByronProtocol + "Shelley" -> pure ShelleyProtocol + "Cardano" -> pure CardanoProtocol + + -- The old names + "BFT" -> pure (MockProtocol MockBFT) + --"MockPBFT" -- same as new name + "Praos" -> pure (MockProtocol MockPraos) + "RealPBFT" -> pure ByronProtocol + "TPraos" -> pure ShelleyProtocol + + _ -> fail $ "Parsing of Protocol failed. " + <> show str <> " is not a valid protocol" + +deriving instance NFData Protocol +deriving instance NoUnexpectedThunks Protocol + +data MockProtocol = MockBFT + | MockPBFT + | MockPraos + deriving (Eq, Show, Generic) + +deriving instance NFData MockProtocol +deriving instance NoUnexpectedThunks MockProtocol + data NodeProtocolConfiguration = NodeProtocolConfigurationMock NodeMockProtocolConfiguration | NodeProtocolConfigurationByron NodeByronProtocolConfiguration