diff --git a/cabal.project b/cabal.project
index 3bb37cdadf..b967214d0c 100644
--- a/cabal.project
+++ b/cabal.project
@@ -16,10 +16,6 @@ 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
-
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: 500e283a93fcb4c82b03febf243cb976431a613f
+ --sha256: sha256-aHpjdMQhjRpe0w5Fb9a5LeVGcO44VAl928CS7HoYB0Q=
+ subdir:
+ cardano-api
+
+source-repository-package
+ type: git
+ location: https://github.com/IntersectMBO/cardano-ledger.git
+ tag: 3f879bb37df4738ed8211e500c7d180443cfcbe4
+ --sha256: sha256-uLjiIHiU1SzAmoKs+rynQphc3FUYXKeJLlOnp87uNdg=
+ 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: fdb4f4db05e3744ed413f83477020fdf43cf32a2
+ --sha256: sha256-eyQc8Dk7+upSRQvH5eXZuj6asYhOLsH59ABJZDyvQ6I=
+ subdir:
+ kes-agent
+ kes-agent-crypto
+
+source-repository-package
+ type: git
+ location: https://github.com/IntersectMBO/ouroboros-consensus.git
+ tag: 0411b4d50dc62cab07bbbf75805cf585a7a1f8e7
+ --sha256: sha256-DNnGHdo+oQDBbHzAl6UZ/VcPoS4TxGrC9eCOiMxgc8A=
+ subdir:
+ .
+
+source-repository-package
+ type: git
+ location: https://github.com/IntersectMBO/ouroboros-network.git
+ tag: 1881340e26ca98b3ee2b89ea536348406b79e051
+ --sha256: sha256-O1Th+YI6LZqCLM6n75tVV+3InA4W8sC0yHEi09u8Fyw=
+ 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..416746deca 100644
--- a/cardano-cli/cardano-cli.cabal
+++ b/cardano-cli/cardano-cli.cabal
@@ -245,15 +245,15 @@ 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-prelude,
cardano-protocol-tpraos,
cardano-slotting ^>=0.2.0.0,
@@ -267,20 +267,20 @@ 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,
mtl,
network,
network-uri,
- optparse-applicative-fork,
+ optparse-applicative,
ordered-containers,
prettyprinter,
prettyprinter-ansi-terminal,
@@ -292,7 +292,7 @@ library
transformers,
unliftio-core,
utf8-string,
- validation,
+ validation ^>=1.2,
vary ^>=0.1.1.2,
vector,
yaml,
@@ -310,7 +310,7 @@ executable cardano-cli
cardano-api,
cardano-cli,
cardano-crypto-class,
- optparse-applicative-fork,
+ optparse-applicative,
rio,
terminal-size,
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/Transaction/Option.hs b/cardano-cli/src/Cardano/CLI/EraBased/Transaction/Option.hs
index 424a55915d..f290aea1f6 100644
--- a/cardano-cli/src/Cardano/CLI/EraBased/Transaction/Option.hs
+++ b/cardano-cli/src/Cardano/CLI/EraBased/Transaction/Option.hs
@@ -30,7 +30,7 @@ import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import Data.Universe (Some)
import Options.Applicative hiding (help, str)
import Options.Applicative qualified as Opt
-import Options.Applicative.Help qualified as H
+-- import Options.Applicative.Help qualified as H
import Prettyprinter (line)
pTransactionCmds
@@ -55,13 +55,13 @@ pTransactionCmds envCli =
[ pretty @String "Build a transaction (low-level, inconvenient)"
, line
, line
- , H.yellow $
- mconcat
- [ "Please note "
- , H.underline "the order"
- , " of some cmd options is crucial. If used incorrectly may produce "
- , "undesired tx body. See nested [] notation above for details."
- ]
+ -- , H.yellow $
+ -- mconcat
+ -- [ "Please note "
+ -- , H.underline "the order"
+ -- , " of some cmd options is crucial. If used incorrectly may produce "
+ -- , "undesired tx body. See nested [] notation above for details."
+ -- ]
]
, pTransactionBuildCmd envCli
, pTransactionBuildEstimateCmd envCli
@@ -179,13 +179,13 @@ pTransactionBuildCmd envCli = do
[ pretty @String "Build a balanced transaction (automatically calculates fees)"
, line
, line
- , H.yellow $
- mconcat
- [ "Please note "
- , H.underline "the order"
- , " of some cmd options is crucial. If used incorrectly may produce "
- , "undesired tx body. See nested [] notation above for details."
- ]
+ -- , H.yellow $
+ -- mconcat
+ -- [ "Please note "
+ -- , H.underline "the order"
+ -- , " of some cmd options is crucial. If used incorrectly may produce "
+ -- , "undesired tx body. See nested [] notation above for details."
+ -- ]
]
where
pCmd era' = do
@@ -243,13 +243,13 @@ pTransactionBuildEstimateCmd _envCli = do
"Build a balanced transaction without access to a live node (automatically estimates fees)"
, line
, line
- , H.yellow $
- mconcat
- [ "Please note "
- , H.underline "the order"
- , " of some cmd options is crucial. If used incorrectly may produce "
- , "undesired tx body. See nested [] notation above for details."
- ]
+ -- , H.yellow $
+ -- mconcat
+ -- [ "Please note "
+ -- , H.underline "the order"
+ -- , " of some cmd options is crucial. If used incorrectly may produce "
+ -- , "undesired tx body. See nested [] notation above for details."
+ -- ]
]
where
pCmd :: Parser (TransactionCmds era)
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/Option.hs b/cardano-cli/src/Cardano/CLI/Option.hs
index 328f78722f..0c491c0f4d 100644
--- a/cardano-cli/src/Cardano/CLI/Option.hs
+++ b/cardano-cli/src/Cardano/CLI/Option.hs
@@ -25,13 +25,14 @@ import Cardano.CLI.EraIndependent.Node.Option
import Cardano.CLI.EraIndependent.Ping.Option (parsePingCmd)
import Cardano.CLI.Legacy.Option (parseLegacyCmds)
import Cardano.CLI.Parser
-import Cardano.CLI.Render (customRenderHelp)
+-- import Cardano.CLI.Render (customRenderHelp)
import Cardano.CLI.Run (ClientCommand (..))
import Data.Foldable
import Options.Applicative
import Options.Applicative qualified as Opt
-import Prettyprinter qualified as PP
+
+-- import Prettyprinter qualified as PP
opts :: EnvCli -> ParserInfo ClientCommand
opts envCli =
@@ -51,8 +52,8 @@ pref =
Opt.prefs $
mconcat
[ showHelpOnEmpty
- , helpEmbedBriefDesc PP.align
- , helpRenderHelp customRenderHelp
+ -- , helpEmbedBriefDesc PP.align
+ -- , helpRenderHelp customRenderHelp
]
addressCmdsTopLevel :: EnvCli -> Parser ClientCommand
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/src/Cardano/CLI/Render.hs b/cardano-cli/src/Cardano/CLI/Render.hs
index d3043fd4ae..69c8b2a563 100644
--- a/cardano-cli/src/Cardano/CLI/Render.hs
+++ b/cardano-cli/src/Cardano/CLI/Render.hs
@@ -4,61 +4,59 @@ module Cardano.CLI.Render
)
where
-import Cardano.Api (textShow)
-
import Data.Text (Text)
-import Data.Text qualified as T
import Options.Applicative
-import Options.Applicative.Help.Ann
-import Options.Applicative.Help.Types (helpText, renderHelp)
+import Options.Applicative.Help.Types (renderHelp)
import Prettyprinter
-import Prettyprinter.Render.Util.SimpleDocTree
-import System.Environment qualified as IO
-import System.IO.Unsafe qualified as IO
-cliHelpTraceEnabled :: Bool
-cliHelpTraceEnabled = IO.unsafePerformIO $ do
- mValue <- IO.lookupEnv "CLI_HELP_TRACE"
- return $ mValue == Just "1"
-{-# NOINLINE cliHelpTraceEnabled #-}
+-- import Cardano.Api (textShow)
+-- import Data.Text qualified as T
+-- import Options.Applicative.Help.Ann
+-- import Options.Applicative.Help.Types (helpText)
+-- import Prettyprinter.Render.Util.SimpleDocTree
+-- import System.Environment qualified as IO
+-- import System.IO.Unsafe qualified as IO
+--
+-- cliHelpTraceEnabled :: Bool
+-- cliHelpTraceEnabled = IO.unsafePerformIO $ do
+-- mValue <- IO.lookupEnv "CLI_HELP_TRACE"
+-- return $ mValue == Just "1"
+-- {-# NOINLINE cliHelpTraceEnabled #-}
+--
-- | Convert a help text to 'String'. When the CLI_HELP_TRACE environment variable is set
-- to '1', the output will be in HTML so that it can be viewed in a browser where developer
-- tools can be used to inspect tracing that aids in describing the structure of the output
-- document.
+-- customRenderHelpAsHtml :: Int -> ParserHelp -> String
+-- customRenderHelpAsHtml cols =
+-- T.unpack
+-- . wrapper
+-- . renderSimplyDecorated id renderElement
+-- . treeForm
+-- . layoutSmart (LayoutOptions (AvailablePerLine cols 1.0))
+-- . helpText
+-- where
+-- renderElement :: Ann -> Text -> Text
+-- renderElement ann x =
+-- if cliHelpTraceEnabled
+-- then case ann of
+-- AnnTrace _ name -> "" <> x <> ""
+-- AnnStyle _ -> x
+-- else x
+-- wrapper =
+-- if cliHelpTraceEnabled
+-- then
+-- id
+-- . ("\n" <>)
+-- . ("\n" <>)
+-- . ("\n" <>)
+-- . (<> "\n")
+-- . (<> "\n")
+-- . (<> "\n
")
+-- else id
customRenderHelp :: Int -> ParserHelp -> String
-customRenderHelp =
- if cliHelpTraceEnabled
- then customRenderHelpAsHtml
- else customRenderHelpAsAnsi
-
-customRenderHelpAsHtml :: Int -> ParserHelp -> String
-customRenderHelpAsHtml cols =
- T.unpack
- . wrapper
- . renderSimplyDecorated id renderElement
- . treeForm
- . layoutSmart (LayoutOptions (AvailablePerLine cols 1.0))
- . helpText
- where
- renderElement :: Ann -> Text -> Text
- renderElement ann x =
- if cliHelpTraceEnabled
- then case ann of
- AnnTrace _ name -> "" <> x <> ""
- AnnStyle _ -> x
- else x
- wrapper =
- if cliHelpTraceEnabled
- then
- id
- . ("\n" <>)
- . ("\n" <>)
- . ("\n" <>)
- . (<> "\n")
- . (<> "\n")
- . (<> "\n
")
- else id
+customRenderHelp = customRenderHelpAsAnsi
customRenderHelpAsAnsi :: Int -> ParserHelp -> String
customRenderHelpAsAnsi = renderHelp