From c30bba7ddf960a8c05170320d69b5401932eb91a Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Fri, 27 Jan 2023 10:32:48 -0400 Subject: [PATCH 1/8] Renmove cardano-cli's dependency on cardano-node --- cardano-cli/cardano-cli.cabal | 4 +- cardano-cli/test/Test/Cli/FilePermissions.hs | 80 +++++++++++++++++++- cardano-node/src/Cardano/Node/Run.hs | 71 +++++++++-------- 3 files changed, 121 insertions(+), 34 deletions(-) diff --git a/cardano-cli/cardano-cli.cabal b/cardano-cli/cardano-cli.cabal index 3bac5ac4097..4f51d15ecea 100644 --- a/cardano-cli/cardano-cli.cabal +++ b/cardano-cli/cardano-cli.cabal @@ -168,6 +168,8 @@ executable cardano-cli test-suite cardano-cli-test import: project-config + , maybe-Win32 + , maybe-unix hs-source-dirs: test main-is: cardano-cli-test.hs @@ -179,7 +181,6 @@ test-suite cardano-cli-test , cardano-api , cardano-api:gen , cardano-cli - , cardano-node , cardano-prelude , cardano-slotting ^>= 0.1 , containers @@ -192,6 +193,7 @@ test-suite cardano-cli-test , text , time , transformers + , transformers-except , yaml other-modules: Test.Config.Mainnet diff --git a/cardano-cli/test/Test/Cli/FilePermissions.hs b/cardano-cli/test/Test/Cli/FilePermissions.hs index 0c0c0901cce..32d6c5c17da 100644 --- a/cardano-cli/test/Test/Cli/FilePermissions.hs +++ b/cardano-cli/test/Test/Cli/FilePermissions.hs @@ -1,14 +1,31 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} +#if !defined(mingw32_HOST_OS) +#define UNIX +#endif + module Test.Cli.FilePermissions ( tests ) where -import Cardano.Prelude +import Prelude + +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Except +import Control.Monad.Trans.Except.Extra +import Data.Text (Text) +import qualified Data.Text as Text +#ifdef UNIX +import System.Posix.Files +import System.Posix.Types (FileMode) +#else +import System.Win32.File +#endif -import Cardano.Node.Run (checkVRFFilePermissions) import Hedgehog (Property, discover, success) import qualified Hedgehog import qualified Hedgehog.Extras.Test.Base as H @@ -40,6 +57,65 @@ prop_createVRFSigningKeyFilePermissions = \file with the wrong permissions: " <> show err Right () -> success +data VRFPrivateKeyFilePermissionError + = OtherPermissionsExist !FilePath + | GroupPermissionsExist !FilePath + | GenericPermissionsExist !FilePath + deriving Show + +renderVRFPrivateKeyFilePermissionError :: VRFPrivateKeyFilePermissionError -> Text +renderVRFPrivateKeyFilePermissionError err = + case err of + OtherPermissionsExist fp -> + "VRF private key file at: " <> Text.pack fp + <> " has \"other\" file permissions. Please remove all \"other\" file permissions." + + GroupPermissionsExist fp -> + "VRF private key file at: " <> Text.pack fp + <> "has \"group\" file permissions. Please remove all \"group\" file permissions." + GenericPermissionsExist fp -> + "VRF private key file at: " <> Text.pack fp + <> "has \"generic\" file permissions. Please remove all \"generic\" file permissions." + + +-- | Make sure the VRF private key file is readable only +-- by the current process owner the node is running under. +checkVRFFilePermissions :: FilePath -> ExceptT VRFPrivateKeyFilePermissionError IO () +#ifdef UNIX +checkVRFFilePermissions vrfPrivKey = do + fs <- liftIO $ getFileStatus vrfPrivKey + let fm = fileMode fs + -- Check the the VRF private key file does not give read/write/exec permissions to others. + when (hasOtherPermissions fm) + (left $ OtherPermissionsExist vrfPrivKey) + -- Check the the VRF private key file does not give read/write/exec permissions to any group. + when (hasGroupPermissions fm) + (left $ GroupPermissionsExist vrfPrivKey) + where + hasPermission :: FileMode -> FileMode -> Bool + hasPermission fModeA fModeB = fModeA `intersectFileModes` fModeB /= nullFileMode + + hasOtherPermissions :: FileMode -> Bool + hasOtherPermissions fm' = fm' `hasPermission` otherModes + + hasGroupPermissions :: FileMode -> Bool + hasGroupPermissions fm' = fm' `hasPermission` groupModes +#else +checkVRFFilePermissions vrfPrivKey = do + attribs <- liftIO $ getFileAttributes vrfPrivKey + -- https://docs.microsoft.com/en-us/windows/win32/api/fileapi/nf-fileapi-createfilea + -- https://docs.microsoft.com/en-us/windows/win32/fileio/file-access-rights-constants + -- https://docs.microsoft.com/en-us/windows/win32/secauthz/standard-access-rights + -- https://docs.microsoft.com/en-us/windows/win32/secauthz/generic-access-rights + -- https://docs.microsoft.com/en-us/windows/win32/secauthz/access-mask + when (attribs `hasPermission` genericPermissions) + (left $ GenericPermissionsExist vrfPrivKey) + where + genericPermissions = gENERIC_ALL .|. gENERIC_READ .|. gENERIC_WRITE .|. gENERIC_EXECUTE + hasPermission fModeA fModeB = fModeA .&. fModeB /= gENERIC_NONE +#endif + + -- ----------------------------------------------------------------------------- tests :: IO Bool diff --git a/cardano-node/src/Cardano/Node/Run.hs b/cardano-node/src/Cardano/Node/Run.hs index 197ab528af4..7cfc1a80107 100644 --- a/cardano-node/src/Cardano/Node/Run.hs +++ b/cardano-node/src/Cardano/Node/Run.hs @@ -19,15 +19,24 @@ module Cardano.Node.Run ) where import qualified Cardano.Api as Api -import Cardano.Prelude hiding (ByteString, STM, atomically, show, take, trace) -import Data.IP (toSockAddr) -import Prelude (String, id, show) +import Prelude +import Control.Concurrent import Control.Concurrent.Class.MonadSTM.Strict -import Control.Monad.Trans.Except.Extra (left) +import Control.Exception +import Control.Monad +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Except +import Control.Monad.Trans.Except.Extra import "contra-tracer" Control.Tracer +import Data.Either +import Data.IP (toSockAddr) +import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Text (breakOn, pack, take) +import Data.Maybe +import Data.Monoid +import Data.Proxy +import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Data.Time.Clock (getCurrentTime) @@ -37,6 +46,7 @@ import Network.HostName (getHostName) import Network.Socket (Socket) import System.Directory (canonicalizePath, createDirectoryIfMissing, makeAbsolute) import System.Environment (lookupEnv) +import System.Exit #ifdef UNIX import GHC.Weak (deRefWeak) @@ -61,12 +71,23 @@ import Cardano.Node.Configuration.NodeAddress import Cardano.Node.Configuration.POM (NodeConfiguration (..), PartialNodeConfiguration (..), SomeNetworkP2PMode (..), defaultPartialNodeConfiguration, makeNodeConfiguration, parseNodeConfigurationFP) +import Cardano.Node.Configuration.Socket (SocketOrSocketInfo (..), + gatherConfiguredSockets, getSocketOrSocketInfoAddr) +import qualified Cardano.Node.Configuration.Topology as TopologyNonP2P +import Cardano.Node.Configuration.TopologyP2P +import qualified Cardano.Node.Configuration.TopologyP2P as TopologyP2P +import Cardano.Node.Handlers.Shutdown +import Cardano.Node.Protocol (mkConsensusProtocol) +import Cardano.Node.Protocol.Types +import Cardano.Node.Queries import Cardano.Node.Startup +import Cardano.Node.TraceConstraints (TraceConstraints) import Cardano.Node.Tracing.API import Cardano.Node.Tracing.StateRep (NodeState (NodeKernelOnline)) import Cardano.Node.Tracing.Tracers.Startup (getStartupInfo) import Cardano.Node.Types import Cardano.Tracing.Config (TraceOptions (..), TraceSelection (..)) +import Cardano.Tracing.Tracers import qualified Ouroboros.Consensus.Config as Consensus import Ouroboros.Consensus.Config.SupportsNode (ConfigSupportsNode (..)) @@ -87,18 +108,6 @@ import Ouroboros.Network.PeerSelection.RelayAccessPoint (RelayAccessPo import Ouroboros.Network.Subscription (DnsSubscriptionTarget (..), IPSubscriptionTarget (..)) -import Cardano.Node.Configuration.Socket (SocketOrSocketInfo (..), - gatherConfiguredSockets, getSocketOrSocketInfoAddr) -import qualified Cardano.Node.Configuration.Topology as TopologyNonP2P -import Cardano.Node.Configuration.TopologyP2P -import qualified Cardano.Node.Configuration.TopologyP2P as TopologyP2P -import Cardano.Node.Handlers.Shutdown -import Cardano.Node.Protocol (mkConsensusProtocol) -import Cardano.Node.Protocol.Types -import Cardano.Node.Queries -import Cardano.Node.TraceConstraints (TraceConstraints) -import Cardano.Tracing.Tracers - {- HLINT ignore "Fuse concatMap/map" -} {- HLINT ignore "Redundant <$>" -} {- HLINT ignore "Use fewer imports" -} @@ -115,7 +124,7 @@ runNode cmdPc = do configYamlPc <- parseNodeConfigurationFP . getLast $ pncConfigFile cmdPc nc <- case makeNodeConfiguration $ defaultPartialNodeConfiguration <> configYamlPc <> cmdPc of - Left err -> panic $ "Error in creating the NodeConfiguration: " <> Text.pack err + Left err -> error $ "Error in creating the NodeConfiguration: " <> err Right nc' -> return nc' putStrLn $ "Node configuration: " <> show nc @@ -124,7 +133,7 @@ runNode cmdPc = do Just vrfFp -> do vrf <- runExceptT $ checkVRFFilePermissions vrfFp case vrf of Left err -> - putTextLn (renderVRFPrivateKeyFilePermissionError err) >> exitFailure + putStrLn (Text.unpack $ renderVRFPrivateKeyFilePermissionError err) >> exitFailure Right () -> pure () Nothing -> pure () @@ -214,10 +223,10 @@ handleNodeWithTracers cmdPc nc p networkMagic runP = do p loggingLayer <- case eLoggingLayer of - Left err -> putTextLn (Text.pack $ show err) >> exitFailure + Left err -> print err >> exitFailure Right res -> return res !trace <- setupTrace loggingLayer - let tracer = contramap pack $ toLogObject trace + let tracer = contramap Text.pack $ toLogObject trace logTracingVerbosity nc tracer -- Legacy logging infrastructure must trace 'nodeStartTime' and 'nodeBasicInfo'. @@ -282,14 +291,14 @@ setupTrace :: LoggingLayer -> IO (Trace IO Text) setupTrace loggingLayer = do - hn <- maybe hostname (pure . pack) =<< lookupEnv "CARDANO_NODE_LOGGING_HOSTNAME" - return $ - setHostname hn $ - llAppendName loggingLayer "node" (llBasicTrace loggingLayer) + hn <- maybe hostname (return . Text.pack) =<< lookupEnv "CARDANO_NODE_LOGGING_HOSTNAME" + return . setHostname hn $ + llAppendName loggingLayer "node" (llBasicTrace loggingLayer) where - hostname = do - hn0 <- pack <$> getHostName - return $ take 8 $ fst $ breakOn "." hn0 + hostname :: IO Text + hostname = do + hn0 <- Text.pack <$> getHostName + return $ Text.take 8 $ fst $ Text.breakOn "." hn0 {- -- TODO: needs to be finished (issue #4362) @@ -522,11 +531,11 @@ handleSimpleNode runP p2pMode tracers nc onKernel = do Signals.Catch $ do traceWith (startupTracer tracers) NetworkConfigUpdate result <- try $ TopologyP2P.readTopologyFileOrError (startupTracer tracers) nc - case result of - Left (FatalError err) -> + case result :: Either IOException NetworkTopology of + Left err -> traceWith (startupTracer tracers) $ NetworkConfigUpdateError - $ pack "Error reading topology configuration file:" <> err + $ Text.pack $ "Error reading topology configuration file:" <> show err Right nt -> do let (localRoots, publicRoots) = producerAddresses nt traceWith (startupTracer tracers) From 7299a7c74e7cdc71062c2fbb936f61cc1151a842 Mon Sep 17 00:00:00 2001 From: Jean-Baptiste Giraudeau Date: Tue, 7 Feb 2023 10:20:14 +0100 Subject: [PATCH 2/8] Bump tullia to fix ci. --- flake.lock | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/flake.lock b/flake.lock index ffbef1ddbc6..b6cdc95dc52 100644 --- a/flake.lock +++ b/flake.lock @@ -20303,11 +20303,11 @@ "std": "std_10" }, "locked": { - "lastModified": 1675092209, - "narHash": "sha256-GO7dZUqQpOSCgv+IFFhXcs1pmPjRRBD68NGfQ2Q+p6I=", + "lastModified": 1675695930, + "narHash": "sha256-B7rEZ/DBUMlK1AcJ9ajnAPPxqXY6zW2SBX+51bZV0Ac=", "owner": "input-output-hk", "repo": "tullia", - "rev": "da00892292f6a6db98ec5566e0b5f3629dd10cf2", + "rev": "621365f2c725608f381b3ad5b57afef389fd4c31", "type": "github" }, "original": { From 67fab5423f270c53558ca02f50ad0064e67d426f Mon Sep 17 00:00:00 2001 From: Ziyang Liu Date: Tue, 7 Feb 2023 09:45:58 -0800 Subject: [PATCH 3/8] Add script evaluation events to LedgerEvent --- cardano-api/src/Cardano/Api/LedgerEvent.hs | 152 ++++++++++++++++++--- 1 file changed, 134 insertions(+), 18 deletions(-) diff --git a/cardano-api/src/Cardano/Api/LedgerEvent.hs b/cardano-api/src/Cardano/Api/LedgerEvent.hs index 63cd50f4750..80a987018ba 100644 --- a/cardano-api/src/Cardano/Api/LedgerEvent.hs +++ b/cardano-api/src/Cardano/Api/LedgerEvent.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE PatternSynonyms #-} @@ -21,6 +22,18 @@ import Cardano.Api.Block (EpochNo) import Cardano.Api.Certificate (Certificate) import Cardano.Api.Keys.Shelley (Hash (StakePoolKeyHash), StakePoolKey) import Cardano.Api.Value (Lovelace, fromShelleyDeltaLovelace, fromShelleyLovelace) +import Cardano.Ledger.Alonzo (AlonzoEra) +import Cardano.Ledger.Alonzo.Rules + ( AlonzoBbodyEvent (..), + AlonzoUtxoEvent (..), + AlonzoUtxosEvent + ( FailedPlutusScriptsEvent, + SuccessfulPlutusScriptsEvent + ), + AlonzoUtxowEvent (..), + ) +import Cardano.Ledger.Alonzo.TxInfo (PlutusDebug) +import Cardano.Ledger.Babbage (BabbageEra) import qualified Cardano.Ledger.Coin as Ledger import qualified Cardano.Ledger.Core as Ledger.Core import qualified Cardano.Ledger.Credential as Ledger @@ -28,16 +41,21 @@ import Cardano.Ledger.Crypto (StandardCrypto) import Cardano.Ledger.Era (Crypto) import qualified Cardano.Ledger.Keys as Ledger import Cardano.Ledger.Shelley.API (InstantaneousRewards (InstantaneousRewards)) -import Cardano.Ledger.Shelley.Rewards - -import Cardano.Ledger.Shelley.Rules.Tick (ShelleyTickEvent (NewEpochEvent)) -import Cardano.Ledger.Shelley.Rules.NewEpoch (ShelleyNewEpochEvent (..)) +import Cardano.Ledger.Shelley.Rewards ( Reward ) +import Cardano.Ledger.Shelley.Rules.Bbody + ( ShelleyBbodyEvent (LedgersEvent), + ) import Cardano.Ledger.Shelley.Rules.Epoch (ShelleyEpochEvent (..)) -import Cardano.Ledger.Shelley.Rules.PoolReap (ShelleyPoolreapEvent (..)) +import qualified Cardano.Ledger.Shelley.Rules.Ledger as Shelley (ShelleyLedgerEvent (UtxowEvent)) +import qualified Cardano.Ledger.Shelley.Rules.Ledgers as Shelley (ShelleyLedgersEvent (LedgerEvent)) import Cardano.Ledger.Shelley.Rules.Mir (ShelleyMirEvent (..)) +import Cardano.Ledger.Shelley.Rules.NewEpoch (ShelleyNewEpochEvent (..)) +import Cardano.Ledger.Shelley.Rules.PoolReap (ShelleyPoolreapEvent (..)) import Cardano.Ledger.Shelley.Rules.Rupd (RupdEvent (..)) - +import Cardano.Ledger.Shelley.Rules.Tick (ShelleyTickEvent (NewEpochEvent)) +import Cardano.Ledger.Shelley.Rules.Utxow (ShelleyUtxowEvent (UtxoEvent)) import Control.State.Transition (Event) +import Data.List.NonEmpty (NonEmpty) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Set (Set) @@ -45,11 +63,18 @@ import Data.SOP.Strict import Ouroboros.Consensus.Byron.Ledger.Block (ByronBlock) import Ouroboros.Consensus.Cardano.Block (HardForkBlock) import Ouroboros.Consensus.HardFork.Combinator.AcrossEras (getOneEraLedgerEvent) -import Ouroboros.Consensus.Ledger.Abstract (LedgerState) import Ouroboros.Consensus.Ledger.Basics (AuxLedgerEvent) -import Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock, - ShelleyLedgerEvent (ShelleyLedgerEventTICK)) -import Ouroboros.Consensus.TypeFamilyWrappers +import Ouroboros.Consensus.Shelley.Ledger + ( LedgerState, + ShelleyBlock, + ShelleyLedgerEvent + ( ShelleyLedgerEventBBODY, + ShelleyLedgerEventTICK + ), + ) +import Ouroboros.Consensus.TypeFamilyWrappers + ( WrapLedgerEvent (unwrapLedgerEvent), + ) data LedgerEvent = -- | The given pool is being registered for the first time on chain. @@ -64,6 +89,10 @@ data LedgerEvent MIRDistribution MIRDistributionDetails | -- | Pools have been reaped and deposits refunded. PoolReap PoolReapDetails + -- | A number of succeeded Plutus script evaluations. + | SuccessfulPlutusScript (NonEmpty PlutusDebug) + -- | A number of failed Plutus script evaluations. + | FailedPlutusScript (NonEmpty PlutusDebug) class ConvertLedgerEvent blk where toLedgerEvent :: WrapLedgerEvent blk -> Maybe LedgerEvent @@ -81,16 +110,22 @@ instance Event (Ledger.Core.EraRule "RUPD" ledgerera) ~ RupdEvent (Crypto ledgerera) ) => ConvertLedgerEvent (ShelleyBlock protocol ledgerera) + where + toLedgerEvent = toLedgerEventShelley + +instance {-# OVERLAPPING #-} ConvertLedgerEvent (ShelleyBlock protocol (AlonzoEra StandardCrypto)) + where + toLedgerEvent evt = case unwrapLedgerEvent evt of + LEPlutusSuccess ds -> Just $ SuccessfulPlutusScript ds + LEPlutusFailure ds -> Just $ FailedPlutusScript ds + _ -> toLedgerEventShelley evt + +instance {-# OVERLAPPING #-} ConvertLedgerEvent (ShelleyBlock protocol (BabbageEra StandardCrypto)) where toLedgerEvent evt = case unwrapLedgerEvent evt of - LEDeltaRewardEvent e m -> Just $ IncrementalRewardsDistribution e m - LERewardEvent e m -> Just $ RewardsDistribution e m - LEMirTransfer rp rt rtt ttr -> - Just $ - MIRDistribution $ - MIRDistributionDetails rp rt rtt ttr - LERetiredPools r u e -> Just $ PoolReap $ PoolReapDetails e r u - _ -> Nothing + LEPlutusSuccess ds -> Just $ SuccessfulPlutusScript ds + LEPlutusFailure ds -> Just $ FailedPlutusScript ds + _ -> toLedgerEventShelley evt instance All ConvertLedgerEvent xs => ConvertLedgerEvent (HardForkBlock xs) where toLedgerEvent = @@ -99,6 +134,27 @@ instance All ConvertLedgerEvent xs => ConvertLedgerEvent (HardForkBlock xs) wher . getOneEraLedgerEvent . unwrapLedgerEvent +toLedgerEventShelley :: + ( Crypto ledgerera ~ StandardCrypto, + Event (Ledger.Core.EraRule "TICK" ledgerera) ~ ShelleyTickEvent ledgerera, + Event (Ledger.Core.EraRule "NEWEPOCH" ledgerera) ~ ShelleyNewEpochEvent ledgerera, + Event (Ledger.Core.EraRule "EPOCH" ledgerera) ~ ShelleyEpochEvent ledgerera, + Event (Ledger.Core.EraRule "POOLREAP" ledgerera) ~ ShelleyPoolreapEvent ledgerera, + Event (Ledger.Core.EraRule "MIR" ledgerera) ~ ShelleyMirEvent ledgerera, + Event (Ledger.Core.EraRule "RUPD" ledgerera) ~ RupdEvent (Crypto ledgerera) + ) => + WrapLedgerEvent (ShelleyBlock protocol ledgerera) -> + Maybe LedgerEvent +toLedgerEventShelley evt = case unwrapLedgerEvent evt of + LEDeltaRewardEvent e m -> Just $ IncrementalRewardsDistribution e m + LERewardEvent e m -> Just $ RewardsDistribution e m + LEMirTransfer rp rt rtt ttr -> + Just $ + MIRDistribution $ + MIRDistributionDetails rp rt rtt ttr + LERetiredPools r u e -> Just $ PoolReap $ PoolReapDetails e r u + _ -> Nothing + -------------------------------------------------------------------------------- -- Event details -------------------------------------------------------------------------------- @@ -206,6 +262,66 @@ pattern LERetiredPools r u e <- ) ) +pattern LEPlutusSuccess :: + ( Crypto ledgerera ~ StandardCrypto, + Event (Ledger.Core.EraRule "BBODY" ledgerera) ~ AlonzoBbodyEvent ledgerera, + Event (Ledger.Core.EraRule "LEDGERS" ledgerera) ~ Shelley.ShelleyLedgersEvent ledgerera, + Event (Ledger.Core.EraRule "LEDGER" ledgerera) ~ Shelley.ShelleyLedgerEvent ledgerera, + Event (Ledger.Core.EraRule "UTXOW" ledgerera) ~ AlonzoUtxowEvent ledgerera, + Event (Ledger.Core.EraRule "UTXO" ledgerera) ~ AlonzoUtxoEvent ledgerera, + Event (Ledger.Core.EraRule "UTXOS" ledgerera) ~ AlonzoUtxosEvent ledgerera + ) => + NonEmpty PlutusDebug -> + AuxLedgerEvent (LedgerState (ShelleyBlock protocol ledgerera)) +pattern LEPlutusSuccess ds <- + ShelleyLedgerEventBBODY + ( ShelleyInAlonzoEvent + ( LedgersEvent + ( Shelley.LedgerEvent + ( Shelley.UtxowEvent + ( WrappedShelleyEraEvent + ( UtxoEvent + ( UtxosEvent + ( SuccessfulPlutusScriptsEvent ds + ) + ) + ) + ) + ) + ) + ) + ) + +pattern LEPlutusFailure :: + ( Crypto ledgerera ~ StandardCrypto, + Event (Ledger.Core.EraRule "BBODY" ledgerera) ~ AlonzoBbodyEvent ledgerera, + Event (Ledger.Core.EraRule "LEDGERS" ledgerera) ~ Shelley.ShelleyLedgersEvent ledgerera, + Event (Ledger.Core.EraRule "LEDGER" ledgerera) ~ Shelley.ShelleyLedgerEvent ledgerera, + Event (Ledger.Core.EraRule "UTXOW" ledgerera) ~ AlonzoUtxowEvent ledgerera, + Event (Ledger.Core.EraRule "UTXO" ledgerera) ~ AlonzoUtxoEvent ledgerera, + Event (Ledger.Core.EraRule "UTXOS" ledgerera) ~ AlonzoUtxosEvent ledgerera + ) => + NonEmpty PlutusDebug -> + AuxLedgerEvent (LedgerState (ShelleyBlock protocol ledgerera)) +pattern LEPlutusFailure ds <- + ShelleyLedgerEventBBODY + ( ShelleyInAlonzoEvent + ( LedgersEvent + ( Shelley.LedgerEvent + ( Shelley.UtxowEvent + ( WrappedShelleyEraEvent + ( UtxoEvent + ( UtxosEvent + ( FailedPlutusScriptsEvent ds + ) + ) + ) + ) + ) + ) + ) + ) + convertRetiredPoolsMap :: Map (Ledger.StakeCredential StandardCrypto) (Map (Ledger.KeyHash Ledger.StakePool StandardCrypto) Ledger.Coin) -> Map StakeCredential (Map (Hash StakePoolKey) Lovelace) From 0e26a829f523ee8cf6d6c20527ca3f15b7a0eae0 Mon Sep 17 00:00:00 2001 From: John Ky Date: Tue, 24 Jan 2023 13:09:56 -0800 Subject: [PATCH 4/8] Simplified and straight line code using onLeft and onNothing functions. --- .../src/Cardano/CLI/Shelley/Run/Query.hs | 317 ++++++++---------- 1 file changed, 142 insertions(+), 175 deletions(-) diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs index b4360326579..cd7758b9159 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs @@ -37,7 +37,7 @@ import Cardano.Api.Shelley import Control.Monad.Trans.Except (except) import Control.Monad.Trans.Except.Extra (firstExceptT, handleIOExceptT, hoistEither, - hoistMaybe, left, newExceptT, onLeft, onNothing) + hoistMaybe, left, onLeft, onNothing) import Data.Aeson as Aeson import Data.Aeson.Encode.Pretty (encodePretty) import Data.Aeson.Types as Aeson @@ -210,8 +210,8 @@ runQueryProtocolParameters -> Maybe OutputFile -> ExceptT ShelleyQueryCmdError IO () runQueryProtocolParameters (AnyConsensusModeParams cModeParams) network mOutFile = do - SocketPath sockPath <- firstExceptT ShelleyQueryCmdEnvVarSocketErr - $ newExceptT readEnvSocketPath + SocketPath sockPath <- lift readEnvSocketPath & onLeft (left . ShelleyQueryCmdEnvVarSocketErr) + let localNodeConnInfo = LocalNodeConnectInfo cModeParams network sockPath result <- liftIO $ executeLocalStateQueryExpr localNodeConnInfo Nothing $ runExceptT $ do @@ -369,29 +369,25 @@ runQueryUTxO -> ExceptT ShelleyQueryCmdError IO () runQueryUTxO (AnyConsensusModeParams cModeParams) qfilter network mOutFile = do - SocketPath sockPath <- firstExceptT ShelleyQueryCmdEnvVarSocketErr - $ newExceptT readEnvSocketPath + SocketPath sockPath <- lift readEnvSocketPath & onLeft (left . ShelleyQueryCmdEnvVarSocketErr) + let localNodeConnInfo = LocalNodeConnectInfo cModeParams network sockPath - anyE@(AnyCardanoEra era) <- - firstExceptT ShelleyQueryCmdAcquireFailure - . newExceptT $ determineEra cModeParams localNodeConnInfo + anyE@(AnyCardanoEra era) <- lift (determineEra cModeParams localNodeConnInfo) + & onLeft (left . ShelleyQueryCmdAcquireFailure) let cMode = consensusModeOnly cModeParams sbe <- getSbe $ cardanoEraStyle era - case toEraInMode era cMode of - Just eInMode -> do - let query = QueryInShelleyBasedEra sbe (QueryUTxO qfilter) - qInMode = QueryInEra eInMode query - result <- executeQuery - era - cModeParams - localNodeConnInfo - qInMode - writeFilteredUTxOs sbe mOutFile result - Nothing -> left $ ShelleyQueryCmdEraConsensusModeMismatch (AnyConsensusMode cMode) anyE + eInMode <- pure (toEraInMode era cMode) + & onNothing (left (ShelleyQueryCmdEraConsensusModeMismatch (AnyConsensusMode cMode) anyE)) + + let query = QueryInShelleyBasedEra sbe (QueryUTxO qfilter) + qInMode = QueryInEra eInMode query + + result <- executeQuery era cModeParams localNodeConnInfo qInMode + writeFilteredUTxOs sbe mOutFile result runQueryKesPeriodInfo :: AnyConsensusModeParams @@ -402,16 +398,15 @@ runQueryKesPeriodInfo runQueryKesPeriodInfo (AnyConsensusModeParams cModeParams) network nodeOpCertFile mOutFile = do - opCert <- firstExceptT ShelleyQueryCmdOpCertCounterReadError - . newExceptT $ readFileTextEnvelope AsOperationalCertificate nodeOpCertFile + opCert <- lift (readFileTextEnvelope AsOperationalCertificate nodeOpCertFile) + & onLeft (left . ShelleyQueryCmdOpCertCounterReadError) + + SocketPath sockPath <- lift readEnvSocketPath & onLeft (left . ShelleyQueryCmdEnvVarSocketErr) - SocketPath sockPath <- firstExceptT ShelleyQueryCmdEnvVarSocketErr - $ newExceptT readEnvSocketPath let localNodeConnInfo = LocalNodeConnectInfo cModeParams network sockPath - anyE@(AnyCardanoEra era) <- - firstExceptT ShelleyQueryCmdAcquireFailure - . newExceptT $ determineEra cModeParams localNodeConnInfo + anyE@(AnyCardanoEra era) <- lift (determineEra cModeParams localNodeConnInfo) + & onLeft (left . ShelleyQueryCmdAcquireFailure) let cMode = consensusModeOnly cModeParams sbe <- getSbe $ cardanoEraStyle era @@ -433,7 +428,8 @@ runQueryKesPeriodInfo (AnyConsensusModeParams cModeParams) network nodeOpCertFil oCertEndKesPeriod = opCertEndKesPeriod gParams opCert opCertIntervalInformation = opCertIntervalInfo gParams chainTip curKesPeriod oCertStartKesPeriod oCertEndKesPeriod - eraHistory <- firstExceptT ShelleyQueryCmdAcquireFailure . newExceptT $ queryNodeLocalState localNodeConnInfo Nothing eraHistoryQuery + eraHistory <- lift (queryNodeLocalState localNodeConnInfo Nothing eraHistoryQuery) + & onLeft (left . ShelleyQueryCmdAcquireFailure) let eInfo = toEpochInfo eraHistory @@ -567,20 +563,21 @@ runQueryKesPeriodInfo (AnyConsensusModeParams cModeParams) network nodeOpCertFil -> ExceptT ShelleyQueryCmdError IO (OpCertOnDiskCounter, Maybe OpCertNodeStateCounter) opCertOnDiskAndStateCounters ptclState opCert@(OperationalCertificate _ stakePoolVKey) = do let onDiskOpCertCount = fromIntegral $ getOpCertCount opCert - case decodeProtocolState ptclState of - Left decErr -> left $ ShelleyQueryCmdProtocolStateDecodeFailure decErr - Right chainDepState -> do - -- We need the stake pool id to determine what the counter of our SPO - -- should be. - let opCertCounterMap = Consensus.getOpCertCounters (Proxy @(ConsensusProtocol era)) chainDepState - StakePoolKeyHash blockIssuerHash = verificationKeyHash stakePoolVKey - - case Map.lookup (coerce blockIssuerHash) opCertCounterMap of - -- Operational certificate exists in the protocol state - -- so our ondisk op cert counter must be greater than or - -- equal to what is in the node state - Just ptclStateCounter -> return (OpCertOnDiskCounter onDiskOpCertCount, Just $ OpCertNodeStateCounter ptclStateCounter) - Nothing -> return (OpCertOnDiskCounter onDiskOpCertCount, Nothing) + + chainDepState <- pure (decodeProtocolState ptclState) + & onLeft (left . ShelleyQueryCmdProtocolStateDecodeFailure) + + -- We need the stake pool id to determine what the counter of our SPO + -- should be. + let opCertCounterMap = Consensus.getOpCertCounters (Proxy @(ConsensusProtocol era)) chainDepState + StakePoolKeyHash blockIssuerHash = verificationKeyHash stakePoolVKey + + case Map.lookup (coerce blockIssuerHash) opCertCounterMap of + -- Operational certificate exists in the protocol state + -- so our ondisk op cert counter must be greater than or + -- equal to what is in the node state + Just ptclStateCounter -> return (OpCertOnDiskCounter onDiskOpCertCount, Just $ OpCertNodeStateCounter ptclStateCounter) + Nothing -> return (OpCertOnDiskCounter onDiskOpCertCount, Nothing) renderOpCertIntervalInformation :: FilePath -> OpCertIntervalInformation -> String @@ -613,14 +610,12 @@ runQueryPoolState -> [Hash StakePoolKey] -> ExceptT ShelleyQueryCmdError IO () runQueryPoolState (AnyConsensusModeParams cModeParams) network poolIds = do - SocketPath sockPath <- firstExceptT ShelleyQueryCmdEnvVarSocketErr - $ newExceptT readEnvSocketPath - let localNodeConnInfo = LocalNodeConnectInfo cModeParams network sockPath + SocketPath sockPath <- lift readEnvSocketPath & onLeft (left . ShelleyQueryCmdEnvVarSocketErr) + let localNodeConnInfo = LocalNodeConnectInfo cModeParams network sockPath - anyE@(AnyCardanoEra era) <- - firstExceptT ShelleyQueryCmdAcquireFailure - . newExceptT $ determineEra cModeParams localNodeConnInfo + anyE@(AnyCardanoEra era) <- lift (determineEra cModeParams localNodeConnInfo) + & onLeft (left . ShelleyQueryCmdAcquireFailure) let cMode = consensusModeOnly cModeParams sbe <- getSbe $ cardanoEraStyle era @@ -640,14 +635,14 @@ runQueryTxMempool -> Maybe OutputFile -> ExceptT ShelleyQueryCmdError IO () runQueryTxMempool (AnyConsensusModeParams cModeParams) network query mOutFile = do - SocketPath sockPath <- firstExceptT ShelleyQueryCmdEnvVarSocketErr - $ newExceptT readEnvSocketPath + SocketPath sockPath <- lift readEnvSocketPath & onLeft (left . ShelleyQueryCmdEnvVarSocketErr) + let localNodeConnInfo = LocalNodeConnectInfo cModeParams network sockPath localQuery <- case query of TxMempoolQueryTxExists tx -> do - anyE@(AnyCardanoEra era) <- firstExceptT ShelleyQueryCmdAcquireFailure - . newExceptT $ determineEra cModeParams localNodeConnInfo + anyE@(AnyCardanoEra era) <- lift (determineEra cModeParams localNodeConnInfo) + & onLeft (left . ShelleyQueryCmdAcquireFailure) let cMode = consensusModeOnly cModeParams eInMode <- toEraInMode era cMode & hoistMaybe (ShelleyQueryCmdEraConsensusModeMismatch (AnyConsensusMode cMode) anyE) @@ -673,12 +668,12 @@ runQueryStakeSnapshot -> Maybe OutputFile -> ExceptT ShelleyQueryCmdError IO () runQueryStakeSnapshot (AnyConsensusModeParams cModeParams) network allOrOnlyPoolIds mOutFile = do - SocketPath sockPath <- firstExceptT ShelleyQueryCmdEnvVarSocketErr $ newExceptT readEnvSocketPath + SocketPath sockPath <- lift readEnvSocketPath & onLeft (left . ShelleyQueryCmdEnvVarSocketErr) + let localNodeConnInfo = LocalNodeConnectInfo cModeParams network sockPath - anyE@(AnyCardanoEra era) <- - firstExceptT ShelleyQueryCmdAcquireFailure - . newExceptT $ determineEra cModeParams localNodeConnInfo + anyE@(AnyCardanoEra era) <- lift (determineEra cModeParams localNodeConnInfo) + & onLeft (left . ShelleyQueryCmdAcquireFailure) let cMode = consensusModeOnly cModeParams sbe <- getSbe $ cardanoEraStyle era @@ -701,30 +696,24 @@ runQueryLedgerState -> ExceptT ShelleyQueryCmdError IO () runQueryLedgerState (AnyConsensusModeParams cModeParams) network mOutFile = do - SocketPath sockPath <- firstExceptT ShelleyQueryCmdEnvVarSocketErr - $ newExceptT readEnvSocketPath + SocketPath sockPath <- lift readEnvSocketPath & onLeft (left . ShelleyQueryCmdEnvVarSocketErr) + let localNodeConnInfo = LocalNodeConnectInfo cModeParams network sockPath - anyE@(AnyCardanoEra era) <- - firstExceptT ShelleyQueryCmdAcquireFailure - . newExceptT $ determineEra cModeParams localNodeConnInfo + anyE@(AnyCardanoEra era) <- lift (determineEra cModeParams localNodeConnInfo) + & onLeft (left . ShelleyQueryCmdAcquireFailure) let cMode = consensusModeOnly cModeParams sbe <- getSbe $ cardanoEraStyle era - case toEraInMode era cMode of - Just eInMode -> do - let qInMode = QueryInEra eInMode - . QueryInShelleyBasedEra sbe - $ QueryDebugLedgerState - result <- executeQuery - era - cModeParams - localNodeConnInfo - qInMode - obtainLedgerEraClassConstraints sbe (writeLedgerState mOutFile) result - Nothing -> left $ ShelleyQueryCmdEraConsensusModeMismatch (AnyConsensusMode cMode) anyE + eInMode <- pure (toEraInMode era cMode) + & onNothing (left (ShelleyQueryCmdEraConsensusModeMismatch (AnyConsensusMode cMode) anyE)) + + let qInMode = QueryInEra eInMode . QueryInShelleyBasedEra sbe $ QueryDebugLedgerState + + result <- executeQuery era cModeParams localNodeConnInfo qInMode + obtainLedgerEraClassConstraints sbe (writeLedgerState mOutFile) result runQueryProtocolState :: AnyConsensusModeParams @@ -733,33 +722,26 @@ runQueryProtocolState -> ExceptT ShelleyQueryCmdError IO () runQueryProtocolState (AnyConsensusModeParams cModeParams) network mOutFile = do - SocketPath sockPath <- firstExceptT ShelleyQueryCmdEnvVarSocketErr - $ newExceptT readEnvSocketPath + SocketPath sockPath <- lift readEnvSocketPath & onLeft (left . ShelleyQueryCmdEnvVarSocketErr) + let localNodeConnInfo = LocalNodeConnectInfo cModeParams network sockPath - anyE@(AnyCardanoEra era) <- - firstExceptT ShelleyQueryCmdAcquireFailure - . newExceptT $ determineEra cModeParams localNodeConnInfo + anyE@(AnyCardanoEra era) <- lift (determineEra cModeParams localNodeConnInfo) + & onLeft (left . ShelleyQueryCmdAcquireFailure) let cMode = consensusModeOnly cModeParams sbe <- getSbe $ cardanoEraStyle era - case toEraInMode era cMode of - Just eInMode -> do - let qInMode = QueryInEra eInMode - . QueryInShelleyBasedEra sbe - $ QueryProtocolState - result <- executeQuery - era - cModeParams - localNodeConnInfo - qInMode + eInMode <- pure (toEraInMode era cMode) + & onNothing (left (ShelleyQueryCmdEraConsensusModeMismatch (AnyConsensusMode cMode) anyE)) - case cMode of - CardanoMode -> eligibleWriteProtocolStateConstaints sbe $ writeProtocolState mOutFile result - mode -> left . ShelleyQueryCmdUnsupportedMode $ AnyConsensusMode mode + let qInMode = QueryInEra eInMode . QueryInShelleyBasedEra sbe $ QueryProtocolState - Nothing -> left $ ShelleyQueryCmdEraConsensusModeMismatch (AnyConsensusMode cMode) anyE + result <- executeQuery era cModeParams localNodeConnInfo qInMode + + case cMode of + CardanoMode -> eligibleWriteProtocolStateConstaints sbe $ writeProtocolState mOutFile result + mode -> left . ShelleyQueryCmdUnsupportedMode $ AnyConsensusMode mode -- | Query the current delegations and reward accounts, filtered by a given -- set of addresses, from a Shelley node via the local state query protocol. @@ -772,31 +754,25 @@ runQueryStakeAddressInfo -> ExceptT ShelleyQueryCmdError IO () runQueryStakeAddressInfo (AnyConsensusModeParams cModeParams) (StakeAddress _ addr) network mOutFile = do - SocketPath sockPath <- firstExceptT ShelleyQueryCmdEnvVarSocketErr - $ newExceptT readEnvSocketPath + SocketPath sockPath <- lift readEnvSocketPath & onLeft (left . ShelleyQueryCmdEnvVarSocketErr) + let localNodeConnInfo = LocalNodeConnectInfo cModeParams network sockPath - anyE@(AnyCardanoEra era) <- - firstExceptT ShelleyQueryCmdAcquireFailure - . newExceptT $ determineEra cModeParams localNodeConnInfo + anyE@(AnyCardanoEra era) <- lift (determineEra cModeParams localNodeConnInfo) + & onLeft (left . ShelleyQueryCmdAcquireFailure) let cMode = consensusModeOnly cModeParams sbe <- getSbe $ cardanoEraStyle era - case toEraInMode era cMode of - Just eInMode -> do - let stakeAddr = Set.singleton $ fromShelleyStakeCredential addr - query = QueryInEra eInMode - . QueryInShelleyBasedEra sbe - $ QueryStakeAddresses stakeAddr network - - result <- executeQuery - era - cModeParams - localNodeConnInfo - query - writeStakeAddressInfo mOutFile $ DelegationsAndRewards result - Nothing -> left $ ShelleyQueryCmdEraConsensusModeMismatch (AnyConsensusMode cMode) anyE + eInMode <- pure (toEraInMode era cMode) + & onNothing (left (ShelleyQueryCmdEraConsensusModeMismatch (AnyConsensusMode cMode) anyE)) + + let stakeAddr = Set.singleton $ fromShelleyStakeCredential addr + query = QueryInEra eInMode . QueryInShelleyBasedEra sbe $ QueryStakeAddresses stakeAddr network + + result <- executeQuery era cModeParams localNodeConnInfo query + + writeStakeAddressInfo mOutFile $ DelegationsAndRewards result -- ------------------------------------------------------------------------------------------------- @@ -858,13 +834,12 @@ writeStakeSnapshots :: forall era ledgerera. () => Maybe OutputFile -> SerialisedStakeSnapshots era -> ExceptT ShelleyQueryCmdError IO () -writeStakeSnapshots mOutFile qState = - case decodeStakeSnapshot qState of - Left err -> left (ShelleyQueryCmdStakeSnapshotDecodeError err) +writeStakeSnapshots mOutFile qState = do + StakeSnapshot snapshot <- pure (decodeStakeSnapshot qState) + & onLeft (left . ShelleyQueryCmdStakeSnapshotDecodeError) - Right (StakeSnapshot snapshot) -> do - -- Calculate the three pool and active stake values for the given pool - liftIO . maybe LBS.putStrLn (LBS.writeFile . unOutputFile) mOutFile $ encodePretty snapshot + -- Calculate the three pool and active stake values for the given pool + liftIO . maybe LBS.putStrLn (LBS.writeFile . unOutputFile) mOutFile $ encodePretty snapshot -- | This function obtains the pool parameters, equivalent to the following jq query on the output of query ledger-state -- .nesEs.esLState._delegationState._pstate._pParams. @@ -874,26 +849,25 @@ writePoolState :: forall era ledgerera. () => Ledger.Era ledgerera => SerialisedPoolState era -> ExceptT ShelleyQueryCmdError IO () -writePoolState serialisedCurrentEpochState = - case decodePoolState serialisedCurrentEpochState of - Left err -> left (ShelleyQueryCmdPoolStateDecodeError err) - - Right (PoolState poolState) -> do - let hks = Set.toList $ Set.fromList $ Map.keys (_pParams poolState) <> Map.keys (_fPParams poolState) <> Map.keys (_retiring poolState) - - let poolStates :: Map (KeyHash 'StakePool StandardCrypto) (Params StandardCrypto) - poolStates = Map.fromList $ hks <&> - ( \hk -> - ( hk - , Params - { poolParameters = Map.lookup hk (SL._pParams poolState) - , futurePoolParameters = Map.lookup hk (SL._fPParams poolState) - , retiringEpoch = Map.lookup hk (SL._retiring poolState) - } - ) - ) - - liftIO . LBS.putStrLn $ encodePretty poolStates +writePoolState serialisedCurrentEpochState = do + PoolState poolState <- pure (decodePoolState serialisedCurrentEpochState) + & onLeft (left . ShelleyQueryCmdPoolStateDecodeError) + + let hks = Set.toList $ Set.fromList $ Map.keys (_pParams poolState) <> Map.keys (_fPParams poolState) <> Map.keys (_retiring poolState) + + let poolStates :: Map (KeyHash 'StakePool StandardCrypto) (Params StandardCrypto) + poolStates = Map.fromList $ hks <&> + ( \hk -> + ( hk + , Params + { poolParameters = Map.lookup hk (SL._pParams poolState) + , futurePoolParameters = Map.lookup hk (SL._fPParams poolState) + , retiringEpoch = Map.lookup hk (SL._retiring poolState) + } + ) + ) + + liftIO . LBS.putStrLn $ encodePretty poolStates writeProtocolState :: ( FromCBOR (Consensus.ChainDepState (ConsensusProtocol era)) @@ -1063,30 +1037,24 @@ runQueryStakeDistribution -> ExceptT ShelleyQueryCmdError IO () runQueryStakeDistribution (AnyConsensusModeParams cModeParams) network mOutFile = do - SocketPath sockPath <- firstExceptT ShelleyQueryCmdEnvVarSocketErr - $ newExceptT readEnvSocketPath + SocketPath sockPath <- lift readEnvSocketPath & onLeft (left . ShelleyQueryCmdEnvVarSocketErr) + let localNodeConnInfo = LocalNodeConnectInfo cModeParams network sockPath - anyE@(AnyCardanoEra era) <- - firstExceptT ShelleyQueryCmdAcquireFailure - . newExceptT $ determineEra cModeParams localNodeConnInfo + anyE@(AnyCardanoEra era) <- lift (determineEra cModeParams localNodeConnInfo) + & onLeft (left . ShelleyQueryCmdAcquireFailure) let cMode = consensusModeOnly cModeParams sbe <- getSbe $ cardanoEraStyle era - case toEraInMode era cMode of - Just eInMode -> do - let query = QueryInEra eInMode - . QueryInShelleyBasedEra sbe - $ QueryStakeDistribution - result <- executeQuery - era - cModeParams - localNodeConnInfo - query - writeStakeDistribution mOutFile result - Nothing -> left $ ShelleyQueryCmdEraConsensusModeMismatch (AnyConsensusMode cMode) anyE + eInMode <- pure (toEraInMode era cMode) + & onNothing (left (ShelleyQueryCmdEraConsensusModeMismatch (AnyConsensusMode cMode) anyE)) + + let query = QueryInEra eInMode . QueryInShelleyBasedEra sbe $ QueryStakeDistribution + + result <- executeQuery era cModeParams localNodeConnInfo query + writeStakeDistribution mOutFile result writeStakeDistribution :: Maybe OutputFile @@ -1191,24 +1159,25 @@ runQueryLeadershipSchedule runQueryLeadershipSchedule (AnyConsensusModeParams cModeParams) network (GenesisFile genFile) coldVerKeyFile (SigningKeyFile vrfSkeyFp) whichSchedule mJsonOutputFile = do - SocketPath sockPath <- firstExceptT ShelleyQueryCmdEnvVarSocketErr - $ newExceptT readEnvSocketPath + SocketPath sockPath <- lift readEnvSocketPath & onLeft (left . ShelleyQueryCmdEnvVarSocketErr) + let localNodeConnInfo = LocalNodeConnectInfo cModeParams network sockPath - anyE@(AnyCardanoEra era) <- - firstExceptT ShelleyQueryCmdAcquireFailure - . newExceptT $ determineEra cModeParams localNodeConnInfo + anyE@(AnyCardanoEra era) <- lift (determineEra cModeParams localNodeConnInfo) + & onLeft (left . ShelleyQueryCmdAcquireFailure) sbe <- getSbe $ cardanoEraStyle era let cMode = consensusModeOnly cModeParams - poolid <- firstExceptT ShelleyQueryCmdTextReadError - . newExceptT $ readVerificationKeyOrHashOrFile AsStakePoolKey coldVerKeyFile + poolid <- lift (readVerificationKeyOrHashOrFile AsStakePoolKey coldVerKeyFile) + & onLeft (left . ShelleyQueryCmdTextReadError) + + vrkSkey <- lift (readFileTextEnvelope (AsSigningKey AsVrfKey) vrfSkeyFp) + & onLeft (left . ShelleyQueryCmdTextEnvelopeReadError) + + shelleyGenesis <- lift (readAndDecodeShelleyGenesis genFile) + & onLeft (left . ShelleyQueryCmdGenesisReadError) - vrkSkey <- firstExceptT ShelleyQueryCmdTextEnvelopeReadError . newExceptT - $ readFileTextEnvelope (AsSigningKey AsVrfKey) vrfSkeyFp - shelleyGenesis <- firstExceptT ShelleyQueryCmdGenesisReadError $ - newExceptT $ readAndDecodeShelleyGenesis genFile case cMode of CardanoMode -> do eInMode <- toEraInMode era cMode @@ -1220,7 +1189,9 @@ runQueryLeadershipSchedule (AnyConsensusModeParams cModeParams) network pparams <- executeQuery era cModeParams localNodeConnInfo pparamsQuery ptclState <- executeQuery era cModeParams localNodeConnInfo ptclStateQuery - eraHistory <- firstExceptT ShelleyQueryCmdAcquireFailure . newExceptT $ queryNodeLocalState localNodeConnInfo Nothing eraHistoryQuery + eraHistory <- lift (queryNodeLocalState localNodeConnInfo Nothing eraHistoryQuery) + & onLeft (left . ShelleyQueryCmdAcquireFailure) + let eInfo = toEpochInfo eraHistory let currentEpochQuery = QueryInEra eInMode $ QueryInShelleyBasedEra sbe QueryEpoch curentEpoch <- executeQuery era cModeParams localNodeConnInfo currentEpochQuery @@ -1327,9 +1298,9 @@ calcEraInMode :: CardanoEra era -> ConsensusMode mode -> ExceptT ShelleyQueryCmdError IO (EraInMode era mode) -calcEraInMode era mode= - hoistMaybe (ShelleyQueryCmdEraConsensusModeMismatch (AnyConsensusMode mode) (anyCardanoEra era)) - $ toEraInMode era mode +calcEraInMode era mode = + pure (toEraInMode era mode) + & onNothing (left (ShelleyQueryCmdEraConsensusModeMismatch (AnyConsensusMode mode) (anyCardanoEra era))) executeQuery :: forall result era mode. CardanoEra era @@ -1353,13 +1324,9 @@ getSbe (Api.ShelleyBasedEra sbe) = return sbe queryResult :: Either AcquiringFailure (Either EraMismatch a) -> ExceptT ShelleyQueryCmdError IO a -queryResult eAcq = - case eAcq of - Left acqFailure -> left $ ShelleyQueryCmdAcquireFailure acqFailure - Right eResult -> - case eResult of - Left err -> left . ShelleyQueryCmdLocalStateQueryError $ EraMismatchError err - Right result -> return result +queryResult eAcq = pure eAcq + & onLeft (left . ShelleyQueryCmdAcquireFailure) + & onLeft (left . ShelleyQueryCmdLocalStateQueryError . EraMismatchError) toEpochInfo :: EraHistory CardanoMode -> EpochInfo (Either Text) toEpochInfo (EraHistory _ interpreter) = From f0571e9b436b3fdd630499244cb2fc93e97f7c61 Mon Sep 17 00:00:00 2001 From: John Ky Date: Tue, 7 Feb 2023 22:36:05 -0800 Subject: [PATCH 5/8] Fix hlint warnings --- trace-dispatcher/src/Cardano/Logging/Tracer/Composed.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/trace-dispatcher/src/Cardano/Logging/Tracer/Composed.hs b/trace-dispatcher/src/Cardano/Logging/Tracer/Composed.hs index 7ac6d2661e5..01f2b400873 100644 --- a/trace-dispatcher/src/Cardano/Logging/Tracer/Composed.hs +++ b/trace-dispatcher/src/Cardano/Logging/Tracer/Composed.hs @@ -1,5 +1,7 @@ {-# LANGUAGE ScopedTypeVariables #-} +{- HLINT ignore "Monad law, left identity" -} + module Cardano.Logging.Tracer.Composed ( mkCardanoTracer , mkCardanoTracer' From e014054315c6049ee132f9db4388ab859e1558ac Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Wed, 8 Feb 2023 08:26:27 -0400 Subject: [PATCH 6/8] Revert "Merge pull request #4855 from input-output-hk/jordan/remove-cli-node-dependency" This reverts commit 75dfd530387023249e5e1563650b6cf3223dccad, reversing changes made to c8862fe0501029d1b3b5469e4bfd6f975aa97256. --- cardano-cli/cardano-cli.cabal | 4 +- cardano-cli/test/Test/Cli/FilePermissions.hs | 80 +------------------- cardano-node/src/Cardano/Node/Run.hs | 71 ++++++++--------- 3 files changed, 34 insertions(+), 121 deletions(-) diff --git a/cardano-cli/cardano-cli.cabal b/cardano-cli/cardano-cli.cabal index 28331903cc5..26a763a9aa0 100644 --- a/cardano-cli/cardano-cli.cabal +++ b/cardano-cli/cardano-cli.cabal @@ -163,8 +163,6 @@ executable cardano-cli test-suite cardano-cli-test import: project-config - , maybe-Win32 - , maybe-unix hs-source-dirs: test main-is: cardano-cli-test.hs @@ -176,6 +174,7 @@ test-suite cardano-cli-test , cardano-api , cardano-api:gen , cardano-cli + , cardano-node , cardano-prelude , cardano-slotting ^>= 0.1 , containers @@ -188,7 +187,6 @@ test-suite cardano-cli-test , text , time , transformers - , transformers-except , yaml other-modules: Test.Config.Mainnet diff --git a/cardano-cli/test/Test/Cli/FilePermissions.hs b/cardano-cli/test/Test/Cli/FilePermissions.hs index 32d6c5c17da..0c0c0901cce 100644 --- a/cardano-cli/test/Test/Cli/FilePermissions.hs +++ b/cardano-cli/test/Test/Cli/FilePermissions.hs @@ -1,31 +1,14 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} -#if !defined(mingw32_HOST_OS) -#define UNIX -#endif - module Test.Cli.FilePermissions ( tests ) where -import Prelude - -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Trans.Except -import Control.Monad.Trans.Except.Extra -import Data.Text (Text) -import qualified Data.Text as Text +import Cardano.Prelude -#ifdef UNIX -import System.Posix.Files -import System.Posix.Types (FileMode) -#else -import System.Win32.File -#endif +import Cardano.Node.Run (checkVRFFilePermissions) import Hedgehog (Property, discover, success) import qualified Hedgehog import qualified Hedgehog.Extras.Test.Base as H @@ -57,65 +40,6 @@ prop_createVRFSigningKeyFilePermissions = \file with the wrong permissions: " <> show err Right () -> success -data VRFPrivateKeyFilePermissionError - = OtherPermissionsExist !FilePath - | GroupPermissionsExist !FilePath - | GenericPermissionsExist !FilePath - deriving Show - -renderVRFPrivateKeyFilePermissionError :: VRFPrivateKeyFilePermissionError -> Text -renderVRFPrivateKeyFilePermissionError err = - case err of - OtherPermissionsExist fp -> - "VRF private key file at: " <> Text.pack fp - <> " has \"other\" file permissions. Please remove all \"other\" file permissions." - - GroupPermissionsExist fp -> - "VRF private key file at: " <> Text.pack fp - <> "has \"group\" file permissions. Please remove all \"group\" file permissions." - GenericPermissionsExist fp -> - "VRF private key file at: " <> Text.pack fp - <> "has \"generic\" file permissions. Please remove all \"generic\" file permissions." - - --- | Make sure the VRF private key file is readable only --- by the current process owner the node is running under. -checkVRFFilePermissions :: FilePath -> ExceptT VRFPrivateKeyFilePermissionError IO () -#ifdef UNIX -checkVRFFilePermissions vrfPrivKey = do - fs <- liftIO $ getFileStatus vrfPrivKey - let fm = fileMode fs - -- Check the the VRF private key file does not give read/write/exec permissions to others. - when (hasOtherPermissions fm) - (left $ OtherPermissionsExist vrfPrivKey) - -- Check the the VRF private key file does not give read/write/exec permissions to any group. - when (hasGroupPermissions fm) - (left $ GroupPermissionsExist vrfPrivKey) - where - hasPermission :: FileMode -> FileMode -> Bool - hasPermission fModeA fModeB = fModeA `intersectFileModes` fModeB /= nullFileMode - - hasOtherPermissions :: FileMode -> Bool - hasOtherPermissions fm' = fm' `hasPermission` otherModes - - hasGroupPermissions :: FileMode -> Bool - hasGroupPermissions fm' = fm' `hasPermission` groupModes -#else -checkVRFFilePermissions vrfPrivKey = do - attribs <- liftIO $ getFileAttributes vrfPrivKey - -- https://docs.microsoft.com/en-us/windows/win32/api/fileapi/nf-fileapi-createfilea - -- https://docs.microsoft.com/en-us/windows/win32/fileio/file-access-rights-constants - -- https://docs.microsoft.com/en-us/windows/win32/secauthz/standard-access-rights - -- https://docs.microsoft.com/en-us/windows/win32/secauthz/generic-access-rights - -- https://docs.microsoft.com/en-us/windows/win32/secauthz/access-mask - when (attribs `hasPermission` genericPermissions) - (left $ GenericPermissionsExist vrfPrivKey) - where - genericPermissions = gENERIC_ALL .|. gENERIC_READ .|. gENERIC_WRITE .|. gENERIC_EXECUTE - hasPermission fModeA fModeB = fModeA .&. fModeB /= gENERIC_NONE -#endif - - -- ----------------------------------------------------------------------------- tests :: IO Bool diff --git a/cardano-node/src/Cardano/Node/Run.hs b/cardano-node/src/Cardano/Node/Run.hs index 42cb4e06aaa..00a7a0a9d39 100644 --- a/cardano-node/src/Cardano/Node/Run.hs +++ b/cardano-node/src/Cardano/Node/Run.hs @@ -19,24 +19,15 @@ module Cardano.Node.Run ) where import qualified Cardano.Api as Api -import Prelude +import Cardano.Prelude hiding (ByteString, STM, atomically, show, take, trace) +import Data.IP (toSockAddr) +import Prelude (String, id, show) -import Control.Concurrent import Control.Concurrent.Class.MonadSTM.Strict -import Control.Exception -import Control.Monad -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.Except -import Control.Monad.Trans.Except.Extra +import Control.Monad.Trans.Except.Extra (left) import "contra-tracer" Control.Tracer -import Data.Either -import Data.IP (toSockAddr) -import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Maybe -import Data.Monoid -import Data.Proxy -import Data.Text (Text) +import Data.Text (breakOn, pack, take) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Data.Time.Clock (getCurrentTime) @@ -46,7 +37,6 @@ import Network.HostName (getHostName) import Network.Socket (Socket) import System.Directory (canonicalizePath, createDirectoryIfMissing, makeAbsolute) import System.Environment (lookupEnv) -import System.Exit #ifdef UNIX import GHC.Weak (deRefWeak) @@ -71,23 +61,12 @@ import Cardano.Node.Configuration.NodeAddress import Cardano.Node.Configuration.POM (NodeConfiguration (..), PartialNodeConfiguration (..), SomeNetworkP2PMode (..), defaultPartialNodeConfiguration, makeNodeConfiguration, parseNodeConfigurationFP) -import Cardano.Node.Configuration.Socket (SocketOrSocketInfo (..), - gatherConfiguredSockets, getSocketOrSocketInfoAddr) -import qualified Cardano.Node.Configuration.Topology as TopologyNonP2P -import Cardano.Node.Configuration.TopologyP2P -import qualified Cardano.Node.Configuration.TopologyP2P as TopologyP2P -import Cardano.Node.Handlers.Shutdown -import Cardano.Node.Protocol (mkConsensusProtocol) -import Cardano.Node.Protocol.Types -import Cardano.Node.Queries import Cardano.Node.Startup -import Cardano.Node.TraceConstraints (TraceConstraints) import Cardano.Node.Tracing.API import Cardano.Node.Tracing.StateRep (NodeState (NodeKernelOnline)) import Cardano.Node.Tracing.Tracers.Startup (getStartupInfo) import Cardano.Node.Types import Cardano.Tracing.Config (TraceOptions (..), TraceSelection (..)) -import Cardano.Tracing.Tracers import qualified Ouroboros.Consensus.Config as Consensus import Ouroboros.Consensus.Config.SupportsNode (ConfigSupportsNode (..)) @@ -108,6 +87,18 @@ import Ouroboros.Network.PeerSelection.RelayAccessPoint (RelayAccessPo import Ouroboros.Network.Subscription (DnsSubscriptionTarget (..), IPSubscriptionTarget (..)) +import Cardano.Node.Configuration.Socket (SocketOrSocketInfo (..), + gatherConfiguredSockets, getSocketOrSocketInfoAddr) +import qualified Cardano.Node.Configuration.Topology as TopologyNonP2P +import Cardano.Node.Configuration.TopologyP2P +import qualified Cardano.Node.Configuration.TopologyP2P as TopologyP2P +import Cardano.Node.Handlers.Shutdown +import Cardano.Node.Protocol (mkConsensusProtocol) +import Cardano.Node.Protocol.Types +import Cardano.Node.Queries +import Cardano.Node.TraceConstraints (TraceConstraints) +import Cardano.Tracing.Tracers + {- HLINT ignore "Fuse concatMap/map" -} {- HLINT ignore "Redundant <$>" -} {- HLINT ignore "Use fewer imports" -} @@ -124,7 +115,7 @@ runNode cmdPc = do configYamlPc <- parseNodeConfigurationFP . getLast $ pncConfigFile cmdPc nc <- case makeNodeConfiguration $ defaultPartialNodeConfiguration <> configYamlPc <> cmdPc of - Left err -> error $ "Error in creating the NodeConfiguration: " <> err + Left err -> panic $ "Error in creating the NodeConfiguration: " <> Text.pack err Right nc' -> return nc' putStrLn $ "Node configuration: " <> show nc @@ -133,7 +124,7 @@ runNode cmdPc = do Just vrfFp -> do vrf <- runExceptT $ checkVRFFilePermissions vrfFp case vrf of Left err -> - putStrLn (Text.unpack $ renderVRFPrivateKeyFilePermissionError err) >> exitFailure + putTextLn (renderVRFPrivateKeyFilePermissionError err) >> exitFailure Right () -> pure () Nothing -> pure () @@ -223,10 +214,10 @@ handleNodeWithTracers cmdPc nc p networkMagic runP = do p loggingLayer <- case eLoggingLayer of - Left err -> print err >> exitFailure + Left err -> putTextLn (Text.pack $ show err) >> exitFailure Right res -> return res !trace <- setupTrace loggingLayer - let tracer = contramap Text.pack $ toLogObject trace + let tracer = contramap pack $ toLogObject trace logTracingVerbosity nc tracer -- Legacy logging infrastructure must trace 'nodeStartTime' and 'nodeBasicInfo'. @@ -291,14 +282,14 @@ setupTrace :: LoggingLayer -> IO (Trace IO Text) setupTrace loggingLayer = do - hn <- maybe hostname (return . Text.pack) =<< lookupEnv "CARDANO_NODE_LOGGING_HOSTNAME" - return . setHostname hn $ - llAppendName loggingLayer "node" (llBasicTrace loggingLayer) + hn <- maybe hostname (pure . pack) =<< lookupEnv "CARDANO_NODE_LOGGING_HOSTNAME" + return $ + setHostname hn $ + llAppendName loggingLayer "node" (llBasicTrace loggingLayer) where - hostname :: IO Text - hostname = do - hn0 <- Text.pack <$> getHostName - return $ Text.take 8 $ fst $ Text.breakOn "." hn0 + hostname = do + hn0 <- pack <$> getHostName + return $ take 8 $ fst $ breakOn "." hn0 {- -- TODO: needs to be finished (issue #4362) @@ -528,11 +519,11 @@ handleSimpleNode runP p2pMode tracers nc onKernel = do Signals.Catch $ do traceWith (startupTracer tracers) NetworkConfigUpdate result <- try $ TopologyP2P.readTopologyFileOrError (startupTracer tracers) nc - case result :: Either IOException NetworkTopology of - Left err -> + case result of + Left (FatalError err) -> traceWith (startupTracer tracers) $ NetworkConfigUpdateError - $ Text.pack $ "Error reading topology configuration file:" <> show err + $ pack "Error reading topology configuration file:" <> err Right nt -> do let (localRoots, publicRoots) = producerAddresses nt traceWith (startupTracer tracers) From 1896e34f9fbba94a7594250603e51a6434561537 Mon Sep 17 00:00:00 2001 From: Ziyang Liu Date: Tue, 7 Feb 2023 13:19:10 -0800 Subject: [PATCH 7/8] Add encoder and decoder for `LedgerState` --- cardano-api/src/Cardano/Api.hs | 2 ++ cardano-api/src/Cardano/Api/LedgerState.hs | 32 +++++++++++++++++++++- 2 files changed, 33 insertions(+), 1 deletion(-) diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index 22cf67b4c44..a04e6009050 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -541,6 +541,8 @@ module Cardano.Api ( envSecurityParam, LedgerState(..), initialLedgerState, + encodeLedgerState, + decodeLedgerState, applyBlock, ValidationMode(..), diff --git a/cardano-api/src/Cardano/Api/LedgerState.hs b/cardano-api/src/Cardano/Api/LedgerState.hs index 601c07d197c..5364a382a26 100644 --- a/cardano-api/src/Cardano/Api/LedgerState.hs +++ b/cardano-api/src/Cardano/Api/LedgerState.hs @@ -24,6 +24,8 @@ module Cardano.Api.LedgerState , LedgerStateMary , LedgerStateAlonzo ) + , encodeLedgerState + , decodeLedgerState , initialLedgerState , applyBlock , ValidationMode(..) @@ -52,6 +54,7 @@ module Cardano.Api.LedgerState ) where +import qualified Cardano.Binary as CBOR import Control.Exception import Control.Monad (when) import Control.Monad.Trans.Class @@ -78,7 +81,7 @@ import qualified Data.Sequence as Seq import Data.Set (Set) import qualified Data.Set as Set import Data.Sharing (FromSharedCBOR, Interns, Share) -import Data.SOP.Strict (NP (..)) +import Data.SOP.Strict (K (..), NP (..), fn, (:.:) (Comp)) import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text @@ -142,6 +145,7 @@ import Cardano.Slotting.Slot (WithOrigin (At, Origin)) import qualified Cardano.Slotting.Slot as Slot import qualified Ouroboros.Consensus.Block.Abstract as Consensus import qualified Ouroboros.Consensus.Byron.Ledger.Block as Byron +import qualified Ouroboros.Consensus.Byron.Ledger.Ledger as Byron import qualified Ouroboros.Consensus.Cardano as Consensus import qualified Ouroboros.Consensus.Cardano.Block as Consensus import qualified Ouroboros.Consensus.Cardano.CanHardFork as Consensus @@ -150,6 +154,7 @@ import qualified Ouroboros.Consensus.Config as Consensus import qualified Ouroboros.Consensus.HardFork.Combinator as Consensus import qualified Ouroboros.Consensus.HardFork.Combinator.AcrossEras as HFC import qualified Ouroboros.Consensus.HardFork.Combinator.Basics as HFC +import qualified Ouroboros.Consensus.HardFork.Combinator.Serialisation.Common as HFC import qualified Ouroboros.Consensus.Ledger.Abstract as Ledger import Ouroboros.Consensus.Ledger.Basics (LedgerResult (lrEvents), lrResult) import qualified Ouroboros.Consensus.Ledger.Extended as Ledger @@ -866,6 +871,31 @@ newtype LedgerState = LedgerState (Consensus.CardanoEras Consensus.StandardCrypto)) } +encodeLedgerState :: LedgerState -> CBOR.Encoding +encodeLedgerState (LedgerState (HFC.HardForkLedgerState st)) = + HFC.encodeTelescope + (byron :* shelley :* allegra :* mary :* alonzo :* babbage :* Nil) + st + where + byron = fn (K . Byron.encodeByronLedgerState) + shelley = fn (K . Shelley.encodeShelleyLedgerState) + allegra = fn (K . Shelley.encodeShelleyLedgerState) + mary = fn (K . Shelley.encodeShelleyLedgerState) + alonzo = fn (K . Shelley.encodeShelleyLedgerState) + babbage = fn (K . Shelley.encodeShelleyLedgerState) + +decodeLedgerState :: forall s. CBOR.Decoder s LedgerState +decodeLedgerState = + LedgerState . HFC.HardForkLedgerState + <$> HFC.decodeTelescope (byron :* shelley :* allegra :* mary :* alonzo :* babbage :* Nil) + where + byron = Comp Byron.decodeByronLedgerState + shelley = Comp Shelley.decodeShelleyLedgerState + allegra = Comp Shelley.decodeShelleyLedgerState + mary = Comp Shelley.decodeShelleyLedgerState + alonzo = Comp Shelley.decodeShelleyLedgerState + babbage = Comp Shelley.decodeShelleyLedgerState + type LedgerStateEvents = (LedgerState, [LedgerEvent]) toLedgerStateEvents :: From 872d6002b41ed8c6db12bdcda1d8e8ab9d916ff6 Mon Sep 17 00:00:00 2001 From: Kosyrev Serge Date: Thu, 9 Feb 2023 14:00:10 +0800 Subject: [PATCH 8/8] workbench: make workbench-nix use Nix-built binaries --- Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile b/Makefile index 3a729d13aef..8c9fcb36828 100644 --- a/Makefile +++ b/Makefile @@ -52,7 +52,7 @@ ci-targets: $(CI_TARGETS) shell: ## Nix shell, (workbench from /nix/store), vars: PROFILE, CMD, RUN nix-shell -A 'workbench-shell' --max-jobs 8 --cores 0 --show-trace --argstr profileName ${PROFILE} --argstr backendName ${BACKEND} ${ARGS} ${if ${CMD},--command "${CMD}"} ${if ${RUN},--run "${RUN}"} shell-dev shell-prof shell-nix: shell -shell-nix: ARGS += --arg 'workbenchDevMode' false ## Nix shell, (workbench from Nix store), vars: PROFILE, CMD, RUN +shell-nix: ARGS += --arg 'useCabalRun' false ## Nix shell, (workbench from Nix store), vars: PROFILE, CMD, RUN shell-prof: ARGS += --arg 'profiled' true ## Nix shell, everything Haskell built profiled analyse: RUN := wb analyse std ${TAG}