Skip to content

Commit

Permalink
Merge #1008 #1022
Browse files Browse the repository at this point in the history
1008: Make filtering optional in the shelley query UTxO command r=intricate a=intricate



1022: Update BadInputsUTxO & ValueNotConserved logging errors r=intricate a=Jimbo4350



Co-authored-by: Jordan Millar <[email protected]>
Co-authored-by: Duncan Coutts <[email protected]>
  • Loading branch information
3 people authored May 22, 2020
3 parents b3a9ec7 + ef554ab + 53dc90e commit a87bc25
Show file tree
Hide file tree
Showing 6 changed files with 90 additions and 49 deletions.
3 changes: 2 additions & 1 deletion cardano-api/src/Cardano/Api.hs
Original file line number Diff line number Diff line change
Expand Up @@ -60,8 +60,9 @@ module Cardano.Api

-- * Node local state queries
, LocalStateQueryError (..)
, QueryFilter (..)
, renderLocalStateQueryError
, queryFilteredUTxOFromLocalState
, queryUTxOFromLocalState
, queryLocalLedgerState
, queryPParamsFromLocalState
, queryStakeDistributionFromLocalState
Expand Down
58 changes: 34 additions & 24 deletions cardano-api/src/Cardano/Api/LocalStateQuery.hs
Original file line number Diff line number Diff line change
Expand Up @@ -6,9 +6,10 @@

module Cardano.Api.LocalStateQuery
( LocalStateQueryError (..)
, QueryFilter (..)
, renderLocalStateQueryError
, queryLocalLedgerState
, queryFilteredUTxOFromLocalState
, queryUTxOFromLocalState
, Ledger.UTxO(..)
, queryPParamsFromLocalState
, Ledger.PParams
Expand All @@ -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)
Expand Down Expand Up @@ -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
Expand All @@ -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.
Expand Down Expand Up @@ -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.
Expand Down
2 changes: 1 addition & 1 deletion cardano-cli/src/Cardano/CLI/Shelley/Commands.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
31 changes: 21 additions & 10 deletions cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down Expand Up @@ -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"
Expand All @@ -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

Expand Down Expand Up @@ -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 <$>
Expand Down
21 changes: 10 additions & 11 deletions cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
]

24 changes: 22 additions & 2 deletions cardano-config/src/Cardano/TracingOrphanInstances/Shelley.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
Expand All @@ -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(..))


--
Expand Down Expand Up @@ -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"
Expand All @@ -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) =
Expand Down

0 comments on commit a87bc25

Please sign in to comment.