diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index 1c76c5d7c3f..759647fe672 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -60,8 +60,9 @@ module Cardano.Api -- * Node local state queries , LocalStateQueryError (..) + , QueryFilter (..) , renderLocalStateQueryError - , queryFilteredUTxOFromLocalState + , queryUTxOFromLocalState , queryLocalLedgerState , queryPParamsFromLocalState , queryStakeDistributionFromLocalState diff --git a/cardano-api/src/Cardano/Api/LocalStateQuery.hs b/cardano-api/src/Cardano/Api/LocalStateQuery.hs index e5b2e6b9406..14a4af89955 100644 --- a/cardano-api/src/Cardano/Api/LocalStateQuery.hs +++ b/cardano-api/src/Cardano/Api/LocalStateQuery.hs @@ -6,9 +6,10 @@ module Cardano.Api.LocalStateQuery ( LocalStateQueryError (..) + , QueryFilter (..) , renderLocalStateQueryError , queryLocalLedgerState - , queryFilteredUTxOFromLocalState + , queryUTxOFromLocalState , Ledger.UTxO(..) , queryPParamsFromLocalState , Ledger.PParams @@ -32,7 +33,7 @@ import qualified Codec.CBOR.Term as CBOR import Control.Monad.Class.MonadSTM.Strict (MonadSTM, StrictTMVar, atomically, newEmptyTMVarM, tryPutTMVar, takeTMVar) -import Control.Monad.Trans.Except.Extra (left, newExceptT) +import Control.Monad.Trans.Except.Extra (hoistEither, newExceptT) import Control.Tracer (Tracer) import Data.Functor.Contravariant (contramap) @@ -80,6 +81,12 @@ data LocalStateQueryError -- ^ The query does not support Byron addresses. deriving (Eq, Show) +-- | UTxO query filtering options. +data QueryFilter + = FilterByAddress !(Set Address) + | NoFilter + deriving (Eq, Show) + renderLocalStateQueryError :: LocalStateQueryError -> Text renderLocalStateQueryError lsqErr = case lsqErr of @@ -92,22 +99,21 @@ renderLocalStateQueryError lsqErr = -- -- This one is Shelley-specific because the query is Shelley-specific. -- -queryFilteredUTxOFromLocalState +queryUTxOFromLocalState :: Network -> SocketPath - -> Set Address + -> QueryFilter -> Point (ShelleyBlock TPraosStandardCrypto) -> ExceptT LocalStateQueryError IO (Ledger.UTxO TPraosStandardCrypto) -queryFilteredUTxOFromLocalState network socketPath addrs point = - whenAllShelleyAddresses addrs $ \shelleyAddrs -> do - let pointAndQuery = (point, GetFilteredUTxO shelleyAddrs) - newExceptT $ liftIO $ - queryNodeLocalState - nullTracer - (pClientInfoCodecConfig . protocolClientInfo $ mkNodeClientProtocolTPraos) - network - socketPath - pointAndQuery +queryUTxOFromLocalState network socketPath qFilter point = do + utxoFilter <- hoistEither $ applyUTxOFilter qFilter + let pointAndQuery = (point, utxoFilter) + newExceptT $ queryNodeLocalState + nullTracer + (pClientInfoCodecConfig . protocolClientInfo $ mkNodeClientProtocolTPraos) + network + socketPath + pointAndQuery -- | Query the current protocol parameters from a Shelley node via the local -- state query protocol. @@ -288,17 +294,21 @@ localStateQueryClient (point, query) resultVar = pure $ SendMsgDone (Left $ AcquireFailureError failure) } -whenAllShelleyAddresses - :: Monad m - => Set Address - -> (Set ShelleyAddress -> ExceptT LocalStateQueryError m a) - -> ExceptT LocalStateQueryError m a -whenAllShelleyAddresses addrs fn = - if Set.null byronAddrs - then fn shelleyAddrs - else left $ ByronAddressesNotSupportedError byronAddrs +applyUTxOFilter + :: (blk ~ ShelleyBlock TPraosStandardCrypto, c ~ TPraosStandardCrypto) + => QueryFilter + -> Either LocalStateQueryError (Query blk (Ledger.UTxO c)) +applyUTxOFilter qFilter = + case qFilter of + FilterByAddress addrs -> do shelleyAddrs <- checkAddresses $ partitionAddresses addrs + Right $ GetFilteredUTxO shelleyAddrs + NoFilter -> Right GetUTxO where - (byronAddrs, shelleyAddrs) = partitionAddresses addrs + checkAddresses :: (Set ByronAddress, Set ShelleyAddress) -> Either LocalStateQueryError (Set ShelleyAddress) + checkAddresses (byronAddrs, shelleyAddrs) = if Set.null byronAddrs + then Right $ shelleyAddrs + else Left $ ByronAddressesNotSupportedError byronAddrs + -- | Partitions a 'Set' of addresses such that Byron addresses are on the left -- and Shelley on the right. diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Commands.hs b/cardano-cli/src/Cardano/CLI/Shelley/Commands.hs index 79087d08bbc..5554af558a9 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Commands.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Commands.hs @@ -149,8 +149,8 @@ data QueryCmd = QueryPoolId NodeAddress | QueryProtocolParameters Network (Maybe OutputFile) | QueryTip Network - | QueryFilteredUTxO Address Network (Maybe OutputFile) | QueryStakeDistribution Network (Maybe OutputFile) + | QueryUTxO QueryFilter Network (Maybe OutputFile) | QueryVersion NodeAddress | QueryLedgerState Network (Maybe OutputFile) | QueryStatus NodeAddress diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs b/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs index d2ab4af7b61..149bbdbbde1 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs @@ -13,6 +13,7 @@ import Control.Monad.Fail (fail) import qualified Data.ByteString.Char8 as C8 import qualified Data.IP as IP import Data.Ratio (approxRational) +import qualified Data.Set as Set import qualified Data.Text as Text import Data.Time.Clock (UTCTime) import Data.Time.Format (defaultTimeLocale, iso8601DateFormat, parseTimeOrError) @@ -352,10 +353,11 @@ pQueryCmd = (Opt.info pQueryProtocolParameters $ Opt.progDesc "Get the node's current protocol parameters") , Opt.command "tip" (Opt.info pQueryTip $ Opt.progDesc "Get the node's current tip (slot no, hash, block no)") - , Opt.command "filtered-utxo" - (Opt.info pQueryFilteredUTxO $ Opt.progDesc "Get the node's current UTxO filtered by address") , Opt.command "stake-distribution" (Opt.info pQueryStakeDistribution $ Opt.progDesc "Get the node's current aggregated stake distribution") + , Opt.command "utxo" + (Opt.info pQueryUTxO $ Opt.progDesc "Get the node's current UTxO with the option of \ + \filtering by address(es)") , Opt.command "version" (Opt.info pQueryVersion $ Opt.progDesc "Get the node version") , Opt.command "ledger-state" @@ -376,10 +378,10 @@ pQueryCmd = pQueryTip :: Parser QueryCmd pQueryTip = QueryTip <$> pNetwork - pQueryFilteredUTxO :: Parser QueryCmd - pQueryFilteredUTxO = - QueryFilteredUTxO - <$> pHexEncodedAddress + pQueryUTxO :: Parser QueryCmd + pQueryUTxO = + QueryUTxO + <$> pQueryFilter <*> pNetwork <*> pMaybeOutputFile @@ -894,14 +896,23 @@ pTxOutCount = <> Opt.help "The number of transaction outputs." ) -pHexEncodedAddress :: Parser Address -pHexEncodedAddress = - Opt.option (Opt.maybeReader (addressFromHex . Text.pack)) +pQueryFilter :: Parser QueryFilter +pQueryFilter = pAddresses <|> pure NoFilter + where + pAddresses :: Parser QueryFilter + pAddresses = FilterByAddress . Set.fromList <$> some pFilterByHexEncodedAddress + +pFilterByHexEncodedAddress :: Parser Address +pFilterByHexEncodedAddress = + Opt.option maybeHexEncodedAddressReader ( Opt.long "address" <> Opt.metavar "ADDRESS" - <> Opt.help "A hex-encoded Cardano address." + <> Opt.help "Filter by Cardano address(es) (hex-encoded)." ) +maybeHexEncodedAddressReader :: Opt.ReadM Address +maybeHexEncodedAddressReader = Opt.maybeReader (addressFromHex . Text.pack) + pAddress :: Parser Text pAddress = Text.pack <$> diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs index b24585769c3..beac1c3e185 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs @@ -12,7 +12,6 @@ import Data.Aeson.Encode.Pretty (encodePretty) import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as LBS import qualified Data.Map as Map -import qualified Data.Set as Set import qualified Data.Text as Text import qualified Data.Text.IO as Text import Numeric (showEFloat) @@ -21,9 +20,9 @@ import Control.Monad.Trans.Except (ExceptT) import Control.Monad.Trans.Except.Extra (firstExceptT, handleIOExceptT) import Cardano.Api - (Address, LocalStateQueryError, Network(..), getLocalTip, - queryFilteredUTxOFromLocalState, queryLocalLedgerState, - queryPParamsFromLocalState, queryStakeDistributionFromLocalState) + (LocalStateQueryError, Network(..), QueryFilter, getLocalTip, + queryLocalLedgerState, queryPParamsFromLocalState, + queryStakeDistributionFromLocalState, queryUTxOFromLocalState) import Cardano.CLI.Environment (EnvSocketError, readEnvSocketPath) import Cardano.CLI.Helpers @@ -65,12 +64,12 @@ runQueryCmd cmd = runQueryProtocolParameters network mOutFile QueryTip network -> runQueryTip network - QueryFilteredUTxO addr network mOutFile -> - runQueryFilteredUTxO addr network mOutFile QueryStakeDistribution network mOutFile -> runQueryStakeDistribution network mOutFile QueryLedgerState network mOutFile -> runQueryLedgerState network mOutFile + QueryUTxO qFilter network mOutFile -> + runQueryUTxO qFilter network mOutFile _ -> liftIO $ putStrLn $ "runQueryCmd: " ++ show cmd runQueryProtocolParameters @@ -104,18 +103,19 @@ runQueryTip network = do getLocalTip iomgr ptclClientInfo network sockPath liftIO $ putTextLn (show tip) -runQueryFilteredUTxO - :: Address + +runQueryUTxO + :: QueryFilter -> Network -> Maybe OutputFile -> ExceptT ShelleyQueryCmdError IO () -runQueryFilteredUTxO addr network mOutFile = do +runQueryUTxO qfilter network mOutFile = do sockPath <- firstExceptT ShelleyQueryEnvVarSocketErr readEnvSocketPath let ptclClientInfo = pClientInfoCodecConfig . protocolClientInfo $ mkNodeClientProtocolTPraos tip <- liftIO $ withIOManager $ \iomgr -> getLocalTip iomgr ptclClientInfo network sockPath filteredUtxo <- firstExceptT NodeLocalStateQueryError $ - queryFilteredUTxOFromLocalState network sockPath (Set.singleton addr) (getTipPoint tip) + queryUTxOFromLocalState network sockPath qfilter (getTipPoint tip) writeFilteredUTxOs mOutFile filteredUtxo runQueryLedgerState @@ -226,4 +226,3 @@ printStakeDistribution (PoolDistr stakeDist) = do -- TODO: we could show the VRF id, but it will then not fit in 80 cols -- , show vrfKeyId ] - diff --git a/cardano-config/src/Cardano/TracingOrphanInstances/Shelley.hs b/cardano-config/src/Cardano/TracingOrphanInstances/Shelley.hs index 2ef51ed3c4b..623fb7000b8 100644 --- a/cardano-config/src/Cardano/TracingOrphanInstances/Shelley.hs +++ b/cardano-config/src/Cardano/TracingOrphanInstances/Shelley.hs @@ -14,6 +14,7 @@ module Cardano.TracingOrphanInstances.Shelley () where import Cardano.Prelude +import Data.Set (Set) import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as Text @@ -34,6 +35,7 @@ import Ouroboros.Consensus.Shelley.Ledger -- TODO: this should be exposed via Cardano.Api import Shelley.Spec.Ledger.API import Shelley.Spec.Ledger.BlockChain (LastAppliedBlock(..)) +import Shelley.Spec.Ledger.Coin import Shelley.Spec.Ledger.Keys (KeyHash(..)) import Shelley.Spec.Ledger.OCert import Shelley.Spec.Ledger.STS.Bbody @@ -59,6 +61,7 @@ import Shelley.Spec.Ledger.STS.Tick import Shelley.Spec.Ledger.STS.Updn import Shelley.Spec.Ledger.STS.Utxo import Shelley.Spec.Ledger.STS.Utxow +import Shelley.Spec.Ledger.TxData (TxIn(..)) -- @@ -215,7 +218,8 @@ instance Crypto c => ToObject (PredicateFailure (UTXOW c)) where instance Crypto c => ToObject (PredicateFailure (UTXO c)) where toObject _verb (BadInputsUTxO badInputs) = mkObject [ "kind" .= String "BadInputsUTxO" - , "badInputs" .= badInputs + , "error" .= renderBadInputsUTxOErr badInputs + ] toObject _verb (ExpiredUTxO ttl slot) = mkObject [ "kind" .= String "ExpiredUTxO" @@ -241,9 +245,25 @@ instance Crypto c => ToObject (PredicateFailure (UTXO c)) where toObject _verb (ValueNotConservedUTxO consumed produced) = mkObject [ "kind" .= String "ValueNotConservedUTxO" , "consumed" .= consumed - , "produced" .= produced ] + , "produced" .= produced + , "error" .= renderValueNotConservedErr consumed produced + ] toObject verb (UpdateFailure f) = toObject verb f +renderBadInputsUTxOErr :: Set (TxIn c) -> Value +renderBadInputsUTxOErr txIns + | Set.null txIns = String "There are no transaction inputs in this transaction." + | otherwise = String $ "These transaction inputs do not exist in the UTxO set: " <> unwrapTxIns txIns + where + unwrapTxIns :: Set (TxIn c) -> Text + unwrapTxIns badTxins = textShow . Set.toList $ Set.map (\(TxIn txId' index) -> (txId', index)) badTxins + +renderValueNotConservedErr :: Coin -> Coin -> Value +renderValueNotConservedErr consumed produced + | consumed > produced = String "This transaction has consumed more Lovelace than it has produced." + | consumed < produced = String "This transaction has produced more Lovelace than it has consumed." + | otherwise = String "consumed == produced, this is not an error and this error should be impossible." + instance ToObject (PredicateFailure (PPUP c)) where toObject _verb (NonGenesisUpdatePPUP proposalKeys genesisKeys) =