diff --git a/cabal.project b/cabal.project index 3bb37cdadf..b36a69d24a 100644 --- a/cabal.project +++ b/cabal.project @@ -14,11 +14,7 @@ repository cardano-haskell-packages -- you need to run if you change them index-state: , hackage.haskell.org 2026-06-02T21:49:32Z - , cardano-haskell-packages 2026-06-02T21:14:32Z - -active-repositories: - , :rest - , cardano-haskell-packages:override + , cardano-haskell-packages 2026-06-23T21:17:32Z packages: cardano-cli @@ -100,3 +96,66 @@ if impl(ghc >= 9.14) , with-utf8:base -- cabal-allow-newer end +source-repository-package + type: git + location: https://github.com/IntersectMBO/cardano-api.git + tag: a775a6a9d581e2216ebc31f27572f4ae1c499e48 + --sha256: sha256-U0UDIuhsDfJ4PDV1BqDTY7/2gWpf8c/Z2IVqUGMNhKQ= + subdir: + cardano-api + +source-repository-package + type: git + location: https://github.com/IntersectMBO/cardano-ledger.git + tag: 8dc1c431e06db2c8b5d44fb4b3cca6419197d763 + --sha256: sha256-xKtgNFxjbJE6UWGvTioGX81NgvlKH3mHEaYMWDm8/UA= + subdir: + eras/allegra/impl + eras/alonzo/impl + eras/babbage/impl + eras/byron/chain/executable-spec + eras/byron/crypto + eras/byron/ledger/executable-spec + eras/byron/ledger/impl + eras/conway/impl + eras/dijkstra/impl + eras/mary/impl + eras/shelley-ma/test-suite + eras/shelley/impl + eras/shelley/test-suite + libs/cardano-data + libs/cardano-ledger-api + libs/cardano-ledger-binary + libs/cardano-ledger-core + libs/cardano-protocol-tpraos + libs/non-integral + libs/small-steps + libs/vector-map + +source-repository-package + type: git + location: https://github.com/f-f/kes-agent.git + tag: 32c1ed675d22a30735d9f22f7afa436a3ef3e64a + --sha256: sha256-o7hFX1JnraS6Xq0WoXQwd9Z8GsPPv0Ls2DWvZ08o0ZU= + subdir: + kes-agent + kes-agent-crypto + +source-repository-package + type: git + location: https://github.com/IntersectMBO/ouroboros-consensus.git + tag: e6fad063078894cefece2a535a2e2b4d9a092e73 + --sha256: sha256-SPtbQ1+zN4uYiVx3rej2kMasbpfhSAyjRD5bdrnK3Rs= + subdir: + . + +source-repository-package + type: git + location: https://github.com/IntersectMBO/ouroboros-network.git + tag: d7736b7c4c51f7328bd9462dc75df0c04a7b06d0 + --sha256: sha256-9sWmBNESHApZmwOi0CpSwn619NIw6/msvV5vH57eqx8= + subdir: + ./cardano-diffusion + ./monoidal-synchronisation + ./network-mux + ./ouroboros-network diff --git a/cardano-cli/cardano-cli.cabal b/cardano-cli/cardano-cli.cabal index 2e24f66059..add22cacac 100644 --- a/cardano-cli/cardano-cli.cabal +++ b/cardano-cli/cardano-cli.cabal @@ -245,15 +245,16 @@ library cardano-api ^>=11.3, cardano-binary, cardano-crypto, - cardano-crypto-class ^>=2.3, + cardano-crypto-class ^>=2.5, cardano-crypto-wrapper ^>=1.7, cardano-data >=1.1, + cardano-diffusion:ping ^>=1.0, cardano-git-rev ^>=0.2.2, cardano-ledger-api, cardano-ledger-conway, cardano-ledger-core, cardano-ledger-dijkstra, - cardano-ping ^>=0.10, + cardano-ledger-shelley, cardano-prelude, cardano-protocol-tpraos, cardano-slotting ^>=0.2.0.0, @@ -267,13 +268,13 @@ library exceptions, filepath, formatting, + fs-api, generic-lens, haskeline, http-client, http-client-tls, http-types, io-classes, - io-classes:strict-stm, iproute, microlens, mmorph, @@ -292,7 +293,7 @@ library transformers, unliftio-core, utf8-string, - validation, + validation ^>=1.2, vary ^>=0.1.1.2, vector, yaml, @@ -440,6 +441,8 @@ test-suite cardano-cli-golden cardano-cli, cardano-cli:cardano-cli-test-lib, cardano-crypto-wrapper, + cardano-ledger-conway, + cardano-ledger-shelley, cardano-strict-containers ^>=0.1, cborg, directory, diff --git a/cardano-cli/src/Cardano/CLI/Byron/UpdateProposal.hs b/cardano-cli/src/Cardano/CLI/Byron/UpdateProposal.hs index 79a3b7e146..d929c2a0cd 100644 --- a/cardano-cli/src/Cardano/CLI/Byron/UpdateProposal.hs +++ b/cardano-cli/src/Cardano/CLI/Byron/UpdateProposal.hs @@ -69,5 +69,5 @@ submitByronUpdateProposal submitByronUpdateProposal nodeSocketPath network proposalFp = do proposal <- readByronUpdateProposal proposalFp let genTx = toByronLedgerUpdateProposal proposal - traceWith stdoutTracer $ "Update proposal TxId: " ++ condense (txId genTx) + liftIO $ traceWith stdoutTracer $ "Update proposal TxId: " ++ condense (txId genTx) fromExceptTCli $ nodeSubmitTx nodeSocketPath network genTx diff --git a/cardano-cli/src/Cardano/CLI/Byron/Vote.hs b/cardano-cli/src/Cardano/CLI/Byron/Vote.hs index 10c99d15b2..6dea978de1 100644 --- a/cardano-cli/src/Cardano/CLI/Byron/Vote.hs +++ b/cardano-cli/src/Cardano/CLI/Byron/Vote.hs @@ -52,7 +52,7 @@ submitByronVote submitByronVote nodeSocketPath network voteFp = do vote <- readByronVote voteFp let genTx = toByronLedgertoByronVote vote - traceWith stdoutTracer ("Vote TxId: " ++ condense (txId genTx)) + liftIO $ traceWith stdoutTracer ("Vote TxId: " ++ condense (txId genTx)) fromExceptTCli $ nodeSubmitTx nodeSocketPath network genTx readByronVote :: FilePath -> CIO e ByronVote diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Genesis/CreateTestnetData/Run.hs b/cardano-cli/src/Cardano/CLI/EraBased/Genesis/CreateTestnetData/Run.hs index 9da22e9bf4..76a778f50d 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Genesis/CreateTestnetData/Run.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Genesis/CreateTestnetData/Run.hs @@ -60,6 +60,8 @@ import Cardano.CLI.Type.Error.NodeCmdError import Cardano.CLI.Type.Error.StakePoolCmdError import Cardano.CLI.Type.Key import Cardano.Crypto.Hash qualified as Crypto +import Cardano.Ledger.Conway.Genesis (ConwayExtraConfig (..)) +import Cardano.Ledger.Shelley.Genesis (InjectionData (..), ShelleyExtraConfig (..)) import Cardano.Prelude (canonicalEncodePretty) import Cardano.Protocol.Crypto qualified as C @@ -488,8 +490,16 @@ runGenesisCreateTestNetDataCmd cgInitialDReps <- initialDReps (L.ucppDRepDeposit $ L.cgUpgradePParams conwayGenesis) dRepKeys pure $ conwayGenesis - { L.cgDelegs = delegs (zip stakingKeys (case dRepKeys of [] -> []; _ -> cycle dRepKeys)) - , L.cgInitialDReps + { L.cgDelegs = mempty + , L.cgInitialDReps = mempty + , L.cgExtraConfig = + L.SJust + ConwayExtraConfig + { cecDelegs = + EmbeddedInjection $ + delegs (zip stakingKeys (case dRepKeys of [] -> []; _ -> cycle dRepKeys)) + , cecInitialDReps = EmbeddedInjection cgInitialDReps + } } where delegs @@ -523,7 +533,7 @@ runGenesisCreateTestNetDataCmd , L.drepAnchor = SNothing , L.drepDeposit , L.drepDelegs = Set.empty -- We don't need to populate this field (field "initialDReps"."keyHash-*"."delegators" in the JSON) - -- because its content is derived from the "delegs" field ("cgDelegs" above). In other words, when the Conway genesis is applied, + -- because its content is derived from the "delegs" field ("cecDelegs" above). In other words, when the Conway genesis is applied, -- DRep delegations are computed from the "delegs" field. In the future the "delegators" field may -- be omitted altogether from the JSON representation, but it remains in the Haskell type. -- More details are provided here: https://github.com/IntersectMBO/cardano-ledger/issues/4782 @@ -875,20 +885,24 @@ updateOutputTemplate { sgSystemStart , sgMaxLovelaceSupply = totalSupply , sgGenDelegs = shelleyDelKeys - , sgInitialFunds = - fromList - [ (toShelleyAddr addr, v) - | (addr, v) <- - distribute nonDelegCoin nUtxoAddrsNonDeleg utxoAddrsNonDeleg - ++ distribute delegCoin nUtxoAddrsDeleg utxoAddrsDeleg - ++ mkStuffedUtxo stuffedUtxoAddrs - ] - , sgStaking = - ShelleyGenesisStaking - { sgsPools = ListMap pools - , sgsStake = ListMap stake - } + , sgInitialFunds = mempty + , sgStaking = mempty , sgProtocolParams + , sgExtraConfig = + L.SJust + ShelleyExtraConfig + { secInitialFunds = + EmbeddedInjection $ + fromList + [ (toShelleyAddr addr, v) + | (addr, v) <- + distribute nonDelegCoin nUtxoAddrsNonDeleg utxoAddrsNonDeleg + ++ distribute delegCoin nUtxoAddrsDeleg utxoAddrsDeleg + ++ mkStuffedUtxo stuffedUtxoAddrs + ] + , secStakePools = EmbeddedInjection (ListMap pools) + , secStakeCredentials = EmbeddedInjection (ListMap stake) + } } where nonDelegCoin = getCoinForDistribution nonDelegCoinRaw diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Genesis/Run.hs b/cardano-cli/src/Cardano/CLI/EraBased/Genesis/Run.hs index 5ee356a133..093c768e38 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Genesis/Run.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Genesis/Run.hs @@ -69,6 +69,7 @@ import Cardano.Crypto qualified as CC import Cardano.Crypto.Hash qualified as Crypto import Cardano.Crypto.Signing qualified as Byron import Cardano.Ledger.BaseTypes (unNonZero) +import Cardano.Ledger.Shelley.Genesis (InjectionData (..), ShelleyExtraConfig (..)) import Cardano.Protocol.Crypto qualified as C import Control.DeepSeq (NFData, force) @@ -795,20 +796,24 @@ updateOutputTemplate { sgSystemStart , sgMaxLovelaceSupply = fromIntegral $ nonDelegCoin + delegCoin , sgGenDelegs = shelleyDelKeys - , sgInitialFunds = - fromList - [ (toShelleyAddr addr, v) - | (addr, v) <- - distribute (nonDelegCoin - subtractForTreasury) nUtxoAddrsNonDeleg utxoAddrsNonDeleg - ++ distribute (delegCoin - subtractForTreasury) nUtxoAddrsDeleg utxoAddrsDeleg - ++ mkStuffedUtxo stuffedUtxoAddrs - ] - , sgStaking = - ShelleyGenesisStaking - { sgsPools = ListMap pools - , sgsStake = ListMap stake - } + , sgInitialFunds = mempty + , sgStaking = mempty , sgProtocolParams + , sgExtraConfig = + L.SJust + ShelleyExtraConfig + { secInitialFunds = + EmbeddedInjection $ + fromList + [ (toShelleyAddr addr, v) + | (addr, v) <- + distribute (nonDelegCoin - subtractForTreasury) nUtxoAddrsNonDeleg utxoAddrsNonDeleg + ++ distribute (delegCoin - subtractForTreasury) nUtxoAddrsDeleg utxoAddrsDeleg + ++ mkStuffedUtxo stuffedUtxoAddrs + ] + , secStakePools = EmbeddedInjection (ListMap pools) + , secStakeCredentials = EmbeddedInjection (ListMap stake) + } } where maximumLovelaceSupply :: Word64 @@ -1114,24 +1119,30 @@ updateTemplate { sgSystemStart = start , sgMaxLovelaceSupply = fromIntegral $ nonDelegCoin + delegCoin , sgGenDelegs = shelleyDelKeys - , sgInitialFunds = - fromList - [ (toShelleyAddr addr, v) - | (addr, v) <- - distribute (nonDelegCoin - subtractForTreasury) utxoAddrsNonDeleg - ++ distribute (delegCoin - subtractForTreasury) utxoAddrsDeleg - ++ mkStuffedUtxo stuffedUtxoAddrs - ] - , sgStaking = - ShelleyGenesisStaking - { sgsPools = - fromList - [ (L.sppId poolParams, poolParams) - | poolParams <- Map.elems poolSpecs - ] - , sgsStake = ListMap.fromMap $ L.sppId <$> poolSpecs - } + , sgInitialFunds = mempty + , sgStaking = mempty , sgProtocolParams = pparamsFromTemplate + , sgExtraConfig = + L.SJust + ShelleyExtraConfig + { secInitialFunds = + EmbeddedInjection $ + fromList + [ (toShelleyAddr addr, v) + | (addr, v) <- + distribute (nonDelegCoin - subtractForTreasury) utxoAddrsNonDeleg + ++ distribute (delegCoin - subtractForTreasury) utxoAddrsDeleg + ++ mkStuffedUtxo stuffedUtxoAddrs + ] + , secStakePools = + EmbeddedInjection $ + fromList + [ (L.sppId poolParams, poolParams) + | poolParams <- Map.elems poolSpecs + ] + , secStakeCredentials = + EmbeddedInjection (ListMap.fromMap $ L.sppId <$> poolSpecs) + } } shelleyGenesis where diff --git a/cardano-cli/src/Cardano/CLI/EraIndependent/Cip/Cip129/Run.hs b/cardano-cli/src/Cardano/CLI/EraIndependent/Cip/Cip129/Run.hs index 2c231cc6b3..78c5b6635c 100644 --- a/cardano-cli/src/Cardano/CLI/EraIndependent/Cip/Cip129/Run.hs +++ b/cardano-cli/src/Cardano/CLI/EraIndependent/Cip/Cip129/Run.hs @@ -22,7 +22,6 @@ import Data.ByteString (ByteString) import Data.ByteString qualified as BS import Data.ByteString.Char8 qualified as BSC import Data.Text.Encoding qualified as Text -import Data.Validation qualified as Valid import System.IO runCip129 :: Cip129 -> CIO e () @@ -32,9 +31,9 @@ runCip129 (Cip129DRep inp out) = do f <- liftIO $ fileOrPipe textEnvFp fromEitherIOCli $ readDrepVerificationKeyFile f InputHexText t -> do - fromEitherCli . Valid.toEither $ readDRepHexVerificationKeyText t + fromEitherCli . toEither $ readDRepHexVerificationKeyText t InputBech32Text t -> do - fromEitherCli . Valid.toEither $ readDRepBech32VerificationKeyText t + fromEitherCli . toEither $ readDRepBech32VerificationKeyText t let cip129Output = Text.encodeUtf8 $ encodeCip129DrepVerficationKeyText k renderOutput cip129Output out runCip129 (Cip129CommitteeHotKey inp out) = do @@ -43,9 +42,9 @@ runCip129 (Cip129CommitteeHotKey inp out) = do f <- liftIO $ fileOrPipe textEnvFp fromEitherIOCli $ readCommitteeHotVerificationKeyFile f InputHexText t -> - fromEitherCli . Valid.toEither $ readCommitteeHotHexVerificationKeyText t + fromEitherCli . toEither $ readCommitteeHotHexVerificationKeyText t InputBech32Text t -> - fromEitherCli . Valid.toEither $ readCommitteeHotBech32VerificationKeyText t + fromEitherCli . toEither $ readCommitteeHotBech32VerificationKeyText t let cip129Output = Text.encodeUtf8 $ encodeCip129CommitteeHotVerficationKeyText k renderOutput cip129Output out runCip129 (Cip129CommitteeColdKey inp out) = do @@ -54,9 +53,9 @@ runCip129 (Cip129CommitteeColdKey inp out) = do f <- liftIO $ fileOrPipe textEnvFp fromEitherIOCli $ readCommitteeColdVerificationKeyFile f InputHexText t -> - fromEitherCli . Valid.toEither $ readCommitteeColdHexVerificationKeyText t + fromEitherCli . toEither $ readCommitteeColdHexVerificationKeyText t InputBech32Text t -> - fromEitherCli . Valid.toEither $ readCommitteeColdBech32VerificationKeyText t + fromEitherCli . toEither $ readCommitteeColdBech32VerificationKeyText t let cip129Output = Text.encodeUtf8 $ encodeCip129CommitteeColdVerficationKeyText k renderOutput cip129Output out runCip129 (Cip129GovernanceAction inp out) = diff --git a/cardano-cli/src/Cardano/CLI/EraIndependent/Debug/LogEpochState/Run.hs b/cardano-cli/src/Cardano/CLI/EraIndependent/Debug/LogEpochState/Run.hs index 61093b9505..a786fbc52d 100644 --- a/cardano-cli/src/Cardano/CLI/EraIndependent/Debug/LogEpochState/Run.hs +++ b/cardano-cli/src/Cardano/CLI/EraIndependent/Debug/LogEpochState/Run.hs @@ -15,6 +15,11 @@ import Cardano.CLI.Orphan () import Data.Aeson qualified as Aeson import Data.ByteString.Lazy qualified as LBS +import System.Directory (makeAbsolute) +import System.FS.API (SomeHasFS (..)) +import System.FS.API.Types (MountPoint (MountPoint)) +import System.FS.IO (ioHasFS) +import System.FilePath (takeDirectory) import System.IO qualified as IO runLogEpochStateCmd @@ -28,9 +33,13 @@ runLogEpochStateCmd } = do LBS.appendFile outputFilePath "" + configDir <- takeDirectory <$> makeAbsolute (unFile configurationFile) + let fs = SomeHasFS (ioHasFS (MountPoint configDir)) + result <- runExceptT $ foldEpochState + fs configurationFile nodeSocketPath Api.QuickValidation diff --git a/cardano-cli/src/Cardano/CLI/EraIndependent/Ping/Option.hs b/cardano-cli/src/Cardano/CLI/EraIndependent/Ping/Option.hs index 5ec4a81d58..6743ebaddf 100644 --- a/cardano-cli/src/Cardano/CLI/EraIndependent/Ping/Option.hs +++ b/cardano-cli/src/Cardano/CLI/EraIndependent/Ping/Option.hs @@ -80,7 +80,7 @@ pPing = , Opt.short 'm' , Opt.metavar "MAGIC" , Opt.help "Network magic." - , Opt.value CNP.mainnetMagic + , Opt.value (CNP.unNetworkMagic CNP.mainnetMagic) ] ) <*> ( Opt.switch $ diff --git a/cardano-cli/src/Cardano/CLI/EraIndependent/Ping/Run.hs b/cardano-cli/src/Cardano/CLI/EraIndependent/Ping/Run.hs index de66b74651..8c0e8127ab 100644 --- a/cardano-cli/src/Cardano/CLI/EraIndependent/Ping/Run.hs +++ b/cardano-cli/src/Cardano/CLI/EraIndependent/Ping/Run.hs @@ -14,18 +14,21 @@ import Cardano.CLI.Compatible.Exception import Cardano.CLI.EraIndependent.Ping.Command import Cardano.Network.Ping qualified as CNP -import Control.Concurrent.Class.MonadSTM.Strict (StrictTMVar) -import Control.Concurrent.Class.MonadSTM.Strict qualified as STM -import Control.Exception (SomeException) -import Control.Monad (forM, unless) -import Control.Monad.Class.MonadAsync (MonadAsync (async, wait, waitCatch)) -import Control.Tracer (Tracer (..)) +import Control.Exception (SomeException, toException) +import Control.Monad (unless) +import Control.Monad.Class.MonadAsync (mapConcurrently) +import Control.Tracer (mkTracer) +import Data.Aeson qualified as Aeson +import Data.Aeson.Text (encodeToLazyText) import Data.List qualified as L import Data.List qualified as List +import Data.Text qualified as T +import Data.Text.Lazy qualified as TL +import Data.Text.Lazy.IO qualified as TLIO import Network.Socket (AddrInfo) import Network.Socket qualified as Socket -import System.Exit qualified as IO import System.IO qualified as IO +import Text.Printf (printf) data PingClientCmdError = PingClientCmdError [(AddrInfo, SomeException)] @@ -35,33 +38,6 @@ data PingClientCmdError instance Error PingClientCmdError where prettyError = renderPingClientCmdError -maybeHostEndPoint :: EndPoint -> Maybe String -maybeHostEndPoint = \case - HostEndPoint host -> Just host - UnixSockEndPoint _ -> Nothing - -maybeUnixSockEndPoint :: EndPoint -> Maybe String -maybeUnixSockEndPoint = \case - HostEndPoint _ -> Nothing - UnixSockEndPoint sock -> Just sock - -pingClient - :: Tracer IO CNP.LogMsg -> Tracer IO String -> PingCmd -> [CNP.NodeVersion] -> AddrInfo -> IO () -pingClient stdout stderr cmd = CNP.pingClient stdout stderr opts - where - opts = - CNP.PingOpts - { CNP.pingOptsQuiet = pingCmdQuiet cmd - , CNP.pingOptsJson = pingCmdJson cmd - , CNP.pingOptsCount = pingCmdCount cmd - , CNP.pingOptsHost = maybeHostEndPoint (pingCmdEndPoint cmd) - , CNP.pingOptsUnixSock = maybeUnixSockEndPoint (pingCmdEndPoint cmd) - , CNP.pingOptsPort = pingCmdPort cmd - , CNP.pingOptsMagic = pingCmdMagic cmd - , CNP.pingOptsHandshakeQuery = pingOptsHandshakeQuery cmd - , CNP.pingOptsGetTip = pingOptsGetTip cmd - } - runPingCmd :: PingCmd -> CIO e () runPingCmd options | Just err <- getConfigurationError options = @@ -69,61 +45,87 @@ runPingCmd options runPingCmd options = do let hints = Socket.defaultHints{Socket.addrSocketType = Socket.Stream} - msgQueue <- liftIO STM.newEmptyTMVarIO - - -- 'addresses' are all the endpoints to connect to and 'versions' are the node protocol versions - -- to ping with. - (addresses, versions) <- case pingCmdEndPoint options of - HostEndPoint host -> do - addrs <- liftIO $ Socket.getAddrInfo (Just hints) (Just host) (Just (pingCmdPort options)) - return (addrs, CNP.supportedNodeToNodeVersions $ pingCmdMagic options) - UnixSockEndPoint fname -> do - let addr = - Socket.AddrInfo - [] - Socket.AF_UNIX - Socket.Stream - Socket.defaultProtocol - (Socket.SockAddrUnix fname) - Nothing - return ([addr], CNP.supportedNodeToClientVersions $ pingCmdMagic options) - - -- Logger async thread handle - laid <- - liftIO . async $ - CNP.logger msgQueue (pingCmdJson options) (pingOptsHandshakeQuery options) (pingOptsGetTip options) - - -- Ping client thread handles - caids <- - forM addresses $ - liftIO . async . pingClient (Tracer $ doLog msgQueue) (Tracer doErrLog) options versions - res <- L.zip addresses <$> mapM (liftIO . waitCatch) caids - liftIO $ doLog msgQueue CNP.LogEnd - liftIO $ wait laid - - -- Collect errors 'es' from failed pings and 'addrs' from successful pings. - let (es, addrs) = L.foldl' partition ([], []) res - - -- Report any errors - case (es, addrs) of - ([], _) -> liftIO IO.exitSuccess - (_, []) -> throwCliError $ PingClientCmdError es - (_, _) -> do - unless (pingCmdQuiet options) $ mapM_ (liftIO . IO.hPrint IO.stderr) es - liftIO IO.exitSuccess + addresses <- case pingCmdEndPoint options of + HostEndPoint host -> + liftIO $ Socket.getAddrInfo (Just hints) (Just host) (Just (pingCmdPort options)) + UnixSockEndPoint fname -> + pure + [ Socket.AddrInfo + [] + Socket.AF_UNIX + Socket.Stream + Socket.defaultProtocol + (Socket.SockAddrUnix fname) + Nothing + ] + + let stdout = mkTracer (TLIO.putStrLn . renderLogMsg (pingCmdJson options)) + stderr = mkTracer (IO.hPutStrLn IO.stderr . renderPingWarning) + + res <- + liftIO $ + mapConcurrently + (\addr -> (,) addr <$> CNP.pingClient stdout stderr (toPingOpts options) addr) + addresses + + case L.foldl' partition ([], []) res of + ([], _) -> pure () + (es, []) -> throwCliError $ PingClientCmdError es + (es, _) -> unless (pingCmdQuiet options) $ mapM_ (liftIO . IO.hPrint IO.stderr) es where partition :: ([(AddrInfo, SomeException)], [AddrInfo]) - -> (AddrInfo, Either SomeException ()) + -> (AddrInfo, Either CNP.PingClientException ()) -> ([(AddrInfo, SomeException)], [AddrInfo]) - partition (es, as) (a, Left e) = ((a, e) : es, as) + partition (es, as) (a, Left e) = ((a, toException e) : es, as) partition (es, as) (a, Right _) = (es, a : as) - doLog :: StrictTMVar IO CNP.LogMsg -> CNP.LogMsg -> IO () - doLog msgQueue msg = STM.atomically $ STM.putTMVar msgQueue msg - - doErrLog :: String -> IO () - doErrLog = IO.hPutStrLn IO.stderr +toPingOpts :: PingCmd -> CNP.PingOpts +toPingOpts cmd = + CNP.PingOpts + { CNP.pingOptsCount = pingCmdCount cmd + , CNP.pingOptsMagic = CNP.NetworkMagic (pingCmdMagic cmd) + , CNP.pingOptsJson = if pingCmdJson cmd then CNP.AsJSON else CNP.AsText + , CNP.pingOptsQuiet = pingCmdQuiet cmd + , CNP.pingOptsMode = + if pingOptsGetTip cmd + then CNP.TipMode + else + if pingOptsHandshakeQuery cmd + then CNP.QueryMode + else CNP.PingMode + , -- cardano-cli has no flags for these yet, so use network's own defaults. + CNP.pingOptsSRVPrefix = "_cardano._tcp" + , CNP.pingOptsColor = CNP.ColorAuto + } + +-- | Format a ping log message. Mirrors the network library's internal +-- @format@/@ToText@ helpers, which are not exported. +renderLogMsg :: Bool -> CNP.WithHost CNP.LogMsg -> TL.Text +renderLogMsg True msg = encodeToLazyText (Aeson.toJSON msg) +renderLogMsg False (CNP.WithHost host logMsg) = + TL.pack (printf "%-47s" (show host <> ", ")) <> renderLogMsgText logMsg + +renderLogMsgText :: CNP.LogMsg -> TL.Text +renderLogMsgText = \case + CNP.LogChainSyncTip tip -> TL.pack (show tip) + CNP.LogStatPoint point -> TL.pack (show point) + CNP.LogNodeToClientVersionData version versionData -> + TL.pack (unwords [show version, either T.unpack show versionData]) + CNP.LogNodeToNodeVersionData version versionData -> + TL.pack (unwords [show version, either T.unpack show versionData]) + +-- | Format a ping warning. Mirrors the network library's internal +-- @formatPingWarning@, which is not exported. +renderPingWarning :: CNP.PingWarning -> String +renderPingWarning = \case + CNP.FilePathDoesNotExist path -> "WARNING: file path " <> show path <> " does not exist" + CNP.DNSError domain err -> "WARNING: dns: " <> show domain <> " " <> show err + CNP.DNSResolution domain ips port -> + show domain <> ": " <> List.intercalate ", " [show ip <> ":" <> show port | ip <- ips] + CNP.MissingPort ip -> "WARNING: missing port for " <> show ip + CNP.Error err -> "WARNING: " <> show err + CNP.ConnectError sockAddr err -> "WARNING: " <> show sockAddr <> " " <> show err renderPingClientCmdError :: PingClientCmdError -> Doc ann renderPingClientCmdError = \case diff --git a/cardano-cli/src/Cardano/CLI/Orphan.hs b/cardano-cli/src/Cardano/CLI/Orphan.hs index 4a81e7c75c..ec8a8112c7 100644 --- a/cardano-cli/src/Cardano/CLI/Orphan.hs +++ b/cardano-cli/src/Cardano/CLI/Orphan.hs @@ -15,7 +15,6 @@ import Cardano.Api.Experimental as Exp import Cardano.Api.Ledger qualified as L import Cardano.CLI.Type.Error.ScriptDecodeError -import Cardano.Ledger.Conway.Governance qualified as L import Cardano.Ledger.Conway.State qualified as L import Control.Exception @@ -24,13 +23,6 @@ import Data.List qualified as List import Data.Typeable import Data.Word -instance ToJSON L.DefaultVote where - toJSON defaultVote = - case defaultVote of - L.DefaultNo -> String "DefaultNo" - L.DefaultAbstain -> String "DefaultAbstain" - L.DefaultNoConfidence -> String "DefaultNoConfidence" - instance Error [Bech32DecodeError] where prettyError errs = vsep $ map prettyError errs diff --git a/cardano-cli/src/Cardano/CLI/Read.hs b/cardano-cli/src/Cardano/CLI/Read.hs index 93d64b2605..7e11c21e51 100644 --- a/cardano-cli/src/Cardano/CLI/Read.hs +++ b/cardano-cli/src/Cardano/CLI/Read.hs @@ -91,6 +91,8 @@ module Cardano.CLI.Read -- * utilities , readerFromParsecParser + , liftError + , toEither ) where @@ -134,6 +136,7 @@ import Data.Text qualified as T import Data.Text qualified as Text import Data.Text.Encoding qualified as Text import Data.Text.Encoding.Error qualified as Text +import Data.Validation (Validation (Failure, Success)) import GHC.IO.Handle (hClose, hIsSeekable) import GHC.IO.Handle.FD (openFileBlocking) import GHC.Stack @@ -819,6 +822,16 @@ readFileCli = withFrozenCallStack . readFileBinary readerFromParsecParser :: P.Parser a -> Opt.ReadM a readerFromParsecParser p = Opt.eitherReader (P.runParser p . T.pack) +liftError :: (e -> e') -> Either e a -> Validation e' a +liftError f = \case + Left e -> Failure (f e) + Right a -> Success a + +toEither :: Validation e a -> Either e a +toEither = \case + Failure e -> Left e + Success a -> Right a + -- TODO: Update to handle hex script bytes directly as well! readFilePlutusScript :: forall e era diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/CreateStaked.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/CreateStaked.hs index 154fb83563..b12cb3b66b 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/CreateStaked.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/CreateStaked.hs @@ -3,11 +3,15 @@ module Test.Golden.CreateStaked where import Cardano.Api +import Cardano.Api.Ledger (StrictMaybe (..)) + +import Cardano.Ledger.Shelley.Genesis (InjectionData (..), ShelleyExtraConfig (..)) import Control.Monad (filterM, void) import Data.Aeson qualified as Aeson import Data.ByteString.Lazy qualified as LBS import Data.List (intercalate, sort) +import GHC.Exts (IsList (..)) import System.Directory import System.FilePath @@ -29,6 +33,10 @@ tree root = do subTrees <- mapM tree subs return $ files ++ concat subTrees +injectionToList :: InjectionData k v -> [(k, v)] +injectionToList (EmbeddedInjection lm) = toList lm +injectionToList _ = [] + hprop_golden_create_staked :: Property hprop_golden_create_staked = watchdogProp . propertyOnce $ moduleWorkspace "tmp" $ \tempDir -> do @@ -88,5 +96,9 @@ hprop_golden_create_staked = genesis :: ShelleyGenesis <- Aeson.throwDecode bs H.assert (sgNetworkMagic genesis == networkMagic) - H.assert ((length . sgsPools . sgStaking $ genesis) == numPools) - H.assert ((length . sgsStake . sgStaking $ genesis) == numStake) + + extraConfig <- case sgExtraConfig genesis of + SJust ec -> pure ec + SNothing -> H.failure + H.assert (length (injectionToList (secStakePools extraConfig)) == numPools) + H.assert (length (injectionToList (secStakeCredentials extraConfig)) == numStake) diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/CreateTestnetData.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/CreateTestnetData.hs index dcdc01cd4b..8a7c53ac91 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/CreateTestnetData.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/CreateTestnetData.hs @@ -8,6 +8,9 @@ import Cardano.Api import Cardano.Api.Ledger (ConwayGenesis (..)) import Cardano.Api.Ledger qualified as L +import Cardano.Ledger.Conway.Genesis (ConwayExtraConfig (..)) +import Cardano.Ledger.Shelley.Genesis (InjectionData (..), ShelleyExtraConfig (..)) + import Control.Monad import Data.List (intercalate, sort) import Data.Sequence.Strict qualified as Seq @@ -77,6 +80,10 @@ tree root = do subTrees <- mapM tree subs return $ files ++ concat subTrees +injectionToList :: InjectionData k v -> [(k, v)] +injectionToList (EmbeddedInjection lm) = toList lm +injectionToList _ = [] + -- Execute this test with: -- @cabal test cardano-cli-golden --test-options '-p "/golden create testnet data/"'@ hprop_golden_create_testnet_data :: Property @@ -128,9 +135,14 @@ golden_create_testnet_data mShelleyTemplate = H.readJsonFileOk $ outputDir "shelley-genesis.json" sgNetworkMagic shelleyGenesis H.=== networkMagic - length (L.sgsPools $ sgStaking shelleyGenesis) H.=== numPools - forM_ (L.sgsPools $ sgStaking shelleyGenesis) $ \pool -> + shelleyExtraConfig <- case sgExtraConfig shelleyGenesis of + L.SJust ec -> pure ec + L.SNothing -> H.failure + let pools = injectionToList (secStakePools shelleyExtraConfig) + length pools H.=== numPools + + forM_ pools $ \(_, pool) -> Seq.length (L.sppRelays pool) H.=== 1 actualNumCCs <- liftIO $ listDirectories $ outputDir "cc-keys" @@ -147,9 +159,13 @@ golden_create_testnet_data mShelleyTemplate = length (L.committeeMembers $ cgCommittee conwayGenesis) H.=== numCommitteeKeys - length (cgInitialDReps conwayGenesis) H.=== numDReps + conwayExtraConfig <- case cgExtraConfig conwayGenesis of + L.SJust ec -> pure ec + L.SNothing -> H.failure + + length (injectionToList (cecInitialDReps conwayExtraConfig)) H.=== numDReps - length (cgDelegs conwayGenesis) H.=== numStakeDelegs + length (injectionToList (cecDelegs conwayExtraConfig)) H.=== numStakeDelegs -- Execute this test with: -- @cabal test cardano-cli-golden --test-options '-p "/golden create testnet data deleg non deleg/"'@ @@ -179,7 +195,10 @@ hprop_golden_create_testnet_data_deleg_non_deleg = -- Because we don't test this elsewhere in this file: sgMaxLovelaceSupply genesis H.=== fromIntegral totalSupply - let initialFunds = toList $ sgInitialFunds genesis + extraConfig <- case sgExtraConfig genesis of + L.SJust ec -> pure ec + L.SNothing -> H.failure + let initialFunds = injectionToList (secInitialFunds extraConfig) -- This checks that there is actually only one funded address length initialFunds H.=== 1 diff --git a/cardano-cli/test/cardano-cli-golden/files/golden/conway/custom-lovelace-supply-shelley-genesis.json b/cardano-cli/test/cardano-cli-golden/files/golden/conway/custom-lovelace-supply-shelley-genesis.json index 4a80e5579c..9016b27cec 100644 --- a/cardano-cli/test/cardano-cli-golden/files/golden/conway/custom-lovelace-supply-shelley-genesis.json +++ b/cardano-cli/test/cardano-cli-golden/files/golden/conway/custom-lovelace-supply-shelley-genesis.json @@ -1,6 +1,17 @@ { "activeSlotsCoeff": 0.99, "epochLength": 21600, + "extraConfig": { + "initialFunds": { + "data": {} + }, + "stakeCredentials": { + "data": {} + }, + "stakePools": { + "data": {} + } + }, "genDelegs": "", "initialFunds": {}, "maxKESEvolutions": 1080000, diff --git a/flake.lock b/flake.lock index 6d0ead243c..ad241ec27c 100644 --- a/flake.lock +++ b/flake.lock @@ -3,11 +3,11 @@ "CHaP": { "flake": false, "locked": { - "lastModified": 1780436322, - "narHash": "sha256-3YDsDhjAcm5QatdluTKuQ9WeDdwrxZMnKH587pVyv9o=", + "lastModified": 1782403175, + "narHash": "sha256-vlajHUGiEHUMmWQyJQI3ziq5faST+oIG88ZfGs1qHNE=", "owner": "intersectmbo", "repo": "cardano-haskell-packages", - "rev": "bc93f1caabfdc4d38c5b44e6eea8f5b8f535775a", + "rev": "8a35d09d5f3f43da9caf8b53285c26108e64045e", "type": "github" }, "original": {