Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Query.hs: simplify implementation with a few new functions and code sharing #993

Merged
merged 2 commits into from
Dec 13, 2024
Merged

Query.hs: simplify implementation with a few new functions and code sharing #993

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
d37c5f7
Query.hs: simplify implementation with a few new functions
smelc Dec 12, 2024
c730206
Remove QueryCmdLocalStateQueryError: its only use is better served by…
smelc Dec 13, 2024
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
1 change: 0 additions & 1 deletion cardano-cli/cardano-cli.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -176,7 +176,6 @@ library
Cardano.CLI.Types.Errors.PlutusScriptDecodeError
Cardano.CLI.Types.Errors.ProtocolParamsError
Cardano.CLI.Types.Errors.QueryCmdError
Cardano.CLI.Types.Errors.QueryCmdLocalStateQueryError
Cardano.CLI.Types.Errors.RegistrationError
Cardano.CLI.Types.Errors.ScriptDataError
Cardano.CLI.Types.Errors.ScriptDecodeError
Expand Down
184 changes: 58 additions & 126 deletions cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -52,7 +52,6 @@ import Cardano.CLI.Helpers
import Cardano.CLI.Types.Common
import Cardano.CLI.Types.Errors.NodeEraMismatchError
import Cardano.CLI.Types.Errors.QueryCmdError
import Cardano.CLI.Types.Errors.QueryCmdLocalStateQueryError
import Cardano.CLI.Types.Key
import Cardano.CLI.Types.Output (QueryDRepStateOutput (..))
import qualified Cardano.CLI.Types.Output as O
Expand Down Expand Up @@ -310,18 +309,13 @@ runQueryUTxOCmd
join $
lift
( executeLocalStateQueryExpr localNodeConnInfo target $ runExceptT $ do
AnyCardanoEra era <-
lift queryCurrentEra
& onLeft (left . QueryCmdUnsupportedNtcVersion)
AnyCardanoEra era <- easyRunQueryCurrentEra

sbe <-
requireShelleyBasedEra era
& onNothing (left QueryCmdByronEra)

utxo <-
lift (queryUtxo sbe queryFilter)
& onLeft (left . QueryCmdUnsupportedNtcVersion)
& onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError)
utxo <- easyRunQuery (queryUtxo sbe queryFilter)

pure $ do
writeFilteredUTxOs sbe format mOutFile utxo
Expand Down Expand Up @@ -354,33 +348,23 @@ runQueryKesPeriodInfoCmd
join $
lift
( executeLocalStateQueryExpr localNodeConnInfo target $ runExceptT $ do
AnyCardanoEra era <-
lift queryCurrentEra
& onLeft (left . QueryCmdUnsupportedNtcVersion)
AnyCardanoEra era <- easyRunQueryCurrentEra

sbe <-
requireShelleyBasedEra era
& onNothing (left QueryCmdByronEra)

-- We check that the KES period specified in the operational certificate is correct
-- based on the KES period defined in the genesis parameters and the current slot number
gParams <-
lift (queryGenesisParameters sbe)
& onLeft (left . QueryCmdUnsupportedNtcVersion)
& onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError)
gParams <- easyRunQuery (queryGenesisParameters sbe)

eraHistory <-
lift queryEraHistory
& onLeft (left . QueryCmdUnsupportedNtcVersion)
eraHistory <- easyRunQueryEraHistory

let eInfo = toTentativeEpochInfo eraHistory

-- We get the operational certificate counter from the protocol state and check that
-- it is equivalent to what we have on disk.
ptclState <-
lift (queryProtocolState sbe)
& onLeft (left . QueryCmdUnsupportedNtcVersion)
& onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError)
ptclState <- easyRunQuery (queryProtocolState sbe)

pure $ do
chainTip <- liftIO $ getLocalChainTip localNodeConnInfo
Expand Down Expand Up @@ -659,9 +643,7 @@ runQueryPoolStateCmd
join $
lift
( executeLocalStateQueryExpr localNodeConnInfo target $ runExceptT $ do
AnyCardanoEra era <-
lift queryCurrentEra
& onLeft (left . QueryCmdUnsupportedNtcVersion)
AnyCardanoEra era <- easyRunQueryCurrentEra

sbe <-
requireShelleyBasedEra era
Expand All @@ -673,13 +655,9 @@ runQueryPoolStateCmd
All -> Nothing
Only poolIds -> Just $ fromList poolIds

result <-
lift (queryPoolState beo poolFilter)
& onLeft (left . QueryCmdUnsupportedNtcVersion)
& onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError)
result <- easyRunQuery (queryPoolState beo poolFilter)

pure $ do
shelleyBasedEraConstraints sbe (writePoolState mOutFile) result
pure $ shelleyBasedEraConstraints sbe (writePoolState mOutFile) result
)
& onLeft (left . QueryCmdAcquireFailure)
& onLeft left
Expand Down Expand Up @@ -753,20 +731,15 @@ runQueryRefScriptSizeCmd
join $
lift
( executeLocalStateQueryExpr localNodeConnInfo target $ runExceptT $ do
AnyCardanoEra era <-
lift queryCurrentEra
& onLeft (left . QueryCmdUnsupportedNtcVersion)
AnyCardanoEra era <- easyRunQueryCurrentEra

sbe <-
requireShelleyBasedEra era
& onNothing (left QueryCmdByronEra)

beo <- requireEon BabbageEra era

utxo <-
lift (queryUtxo sbe $ QueryUTxOByTxIn transactionInputs)
& onLeft (left . QueryCmdUnsupportedNtcVersion)
& onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError)
utxo <- easyRunQuery (queryUtxo sbe $ QueryUTxOByTxIn transactionInputs)

pure $
writeFormattedOutput format mOutFile $
Expand Down Expand Up @@ -807,9 +780,7 @@ runQueryStakeSnapshotCmd
join $
lift
( executeLocalStateQueryExpr localNodeConnInfo target $ runExceptT $ do
AnyCardanoEra era <-
lift queryCurrentEra
& onLeft (left . QueryCmdUnsupportedNtcVersion)
AnyCardanoEra era <- easyRunQueryCurrentEra

sbe <-
requireShelleyBasedEra era
Expand All @@ -821,13 +792,9 @@ runQueryStakeSnapshotCmd

beo <- requireEon BabbageEra era

result <-
lift (queryStakeSnapshot beo poolFilter)
& onLeft (left . QueryCmdUnsupportedNtcVersion)
& onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError)
result <- easyRunQuery (queryStakeSnapshot beo poolFilter)

pure $ do
shelleyBasedEraConstraints sbe (writeStakeSnapshots mOutFile) result
pure $ shelleyBasedEraConstraints sbe (writeStakeSnapshots mOutFile) result
)
& onLeft (left . QueryCmdAcquireFailure)
& onLeft left
Expand All @@ -853,21 +820,15 @@ runQueryLedgerStateCmd
join $
lift
( executeLocalStateQueryExpr localNodeConnInfo target $ runExceptT $ do
AnyCardanoEra era <-
lift queryCurrentEra
& onLeft (left . QueryCmdUnsupportedNtcVersion)
AnyCardanoEra era <- easyRunQueryCurrentEra

sbe <-
requireShelleyBasedEra era
& onNothing (left QueryCmdByronEra)

result <-
lift (queryDebugLedgerState sbe)
& onLeft (left . QueryCmdUnsupportedNtcVersion)
& onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError)
result <- easyRunQuery (queryDebugLedgerState sbe)

pure $ do
shelleyBasedEraConstraints sbe (writeLedgerState mOutFile) result
pure $ shelleyBasedEraConstraints sbe (writeLedgerState mOutFile) result
)
& onLeft (left . QueryCmdAcquireFailure)
& onLeft left
Expand All @@ -893,18 +854,13 @@ runQueryProtocolStateCmd
join $
lift
( executeLocalStateQueryExpr localNodeConnInfo target $ runExceptT $ do
AnyCardanoEra era <-
lift queryCurrentEra
& onLeft (left . QueryCmdUnsupportedNtcVersion)
AnyCardanoEra era <- easyRunQueryCurrentEra

sbe <-
requireShelleyBasedEra era
& onNothing (left QueryCmdByronEra)

result <-
lift (queryProtocolState sbe)
& onLeft (left . QueryCmdUnsupportedNtcVersion)
& onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError)
result <- easyRunQuery (queryProtocolState sbe)

pure $ shelleyBasedEraConstraints sbe $ writeProtocolState sbe mOutFile result
)
Expand Down Expand Up @@ -934,9 +890,7 @@ runQueryStakeAddressInfoCmd
join $
lift
( executeLocalStateQueryExpr localNodeConnInfo target $ runExceptT $ do
AnyCardanoEra era <-
lift queryCurrentEra
& onLeft (left . QueryCmdUnsupportedNtcVersion)
AnyCardanoEra era <- easyRunQueryCurrentEra

sbe <-
requireShelleyBasedEra era
Expand All @@ -945,21 +899,14 @@ runQueryStakeAddressInfoCmd
let stakeAddr = Set.singleton $ fromShelleyStakeCredential addr

(stakeRewardAccountBalances, stakePools) <-
lift (queryStakeAddresses sbe stakeAddr networkId)
& onLeft (left . QueryCmdUnsupportedNtcVersion)
& onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError)
easyRunQuery (queryStakeAddresses sbe stakeAddr networkId)

beo <- requireEon BabbageEra era

stakeDelegDeposits <-
lift (queryStakeDelegDeposits beo stakeAddr)
& onLeft (left . QueryCmdUnsupportedNtcVersion)
& onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError)
stakeDelegDeposits <- easyRunQuery (queryStakeDelegDeposits beo stakeAddr)

stakeVoteDelegatees <- monoidForEraInEonA era $ \ceo ->
lift (queryStakeVoteDelegatees ceo stakeAddr)
& onLeft (left . QueryCmdUnsupportedNtcVersion)
& onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError)
easyRunQuery (queryStakeVoteDelegatees ceo stakeAddr)

return $ do
writeStakeAddressInfo
Expand Down Expand Up @@ -1281,16 +1228,13 @@ runQueryStakePoolsCmd
join $
lift
( executeLocalStateQueryExpr localNodeConnInfo target $ runExceptT @QueryCmdError $ do
AnyCardanoEra era <- lift queryCurrentEra & onLeft (left . QueryCmdUnsupportedNtcVersion)
AnyCardanoEra era <- easyRunQueryCurrentEra

sbe <-
requireShelleyBasedEra era
& onNothing (left QueryCmdByronEra)

poolIds <-
lift (queryStakePools sbe)
& onLeft (left . QueryCmdUnsupportedNtcVersion)
& onLeft (left . QueryCmdEraMismatch)
palas marked this conversation as resolved.
Show resolved Hide resolved
poolIds <- easyRunQuery (queryStakePools sbe)

pure $ writeStakePools (newOutputFormat format mOutFile) mOutFile poolIds
)
Expand Down Expand Up @@ -1354,18 +1298,13 @@ runQueryStakeDistributionCmd
join $
lift
( executeLocalStateQueryExpr localNodeConnInfo target $ runExceptT $ do
AnyCardanoEra era <-
lift queryCurrentEra
& onLeft (left . QueryCmdUnsupportedNtcVersion)
AnyCardanoEra era <- easyRunQueryCurrentEra

sbe <-
requireShelleyBasedEra era
& onNothing (left QueryCmdByronEra)

result <-
lift (queryStakeDistribution sbe)
& onLeft (left . QueryCmdUnsupportedNtcVersion)
& onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError)
result <- easyRunQuery (queryStakeDistribution sbe)

pure $ do
writeStakeDistribution (newOutputFormat format mOutFile) mOutFile result
Expand Down Expand Up @@ -1440,43 +1379,25 @@ runQueryLeadershipScheduleCmd
join $
lift
( executeLocalStateQueryExpr localNodeConnInfo target $ runExceptT $ do
AnyCardanoEra era <-
lift queryCurrentEra
& onLeft (left . QueryCmdUnsupportedNtcVersion)
AnyCardanoEra era <- easyRunQueryCurrentEra

sbe <-
requireShelleyBasedEra era
& onNothing (left QueryCmdByronEra)

pparams <-
lift (queryProtocolParameters sbe)
& onLeft (left . QueryCmdUnsupportedNtcVersion)
& onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError)

ptclState <-
lift (queryProtocolState sbe)
& onLeft (left . QueryCmdUnsupportedNtcVersion)
& onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError)

eraHistory <-
lift queryEraHistory
& onLeft (left . QueryCmdUnsupportedNtcVersion)
pparams <- easyRunQuery (queryProtocolParameters sbe)
ptclState <- easyRunQuery (queryProtocolState sbe)
eraHistory <- easyRunQueryEraHistory

let eInfo = toEpochInfo eraHistory

curentEpoch <-
lift (queryEpoch sbe)
& onLeft (left . QueryCmdUnsupportedNtcVersion)
& onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError)
curentEpoch <- easyRunQuery (queryEpoch sbe)

case whichSchedule of
CurrentEpoch -> do
beo <- requireEon BabbageEra era

serCurrentEpochState <-
lift (queryPoolDistribution beo (Just (Set.singleton poolid)))
& onLeft (left . QueryCmdUnsupportedNtcVersion)
& onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError)
serCurrentEpochState <- easyRunQuery (queryPoolDistribution beo (Just (Set.singleton poolid)))

pure $ do
schedule <-
Expand All @@ -1496,10 +1417,7 @@ runQueryLeadershipScheduleCmd

writeSchedule mOutFile eInfo shelleyGenesis schedule
NextEpoch -> do
serCurrentEpochState <-
lift (queryCurrentEpochState sbe)
& onLeft (left . QueryCmdUnsupportedNtcVersion)
& onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError)
serCurrentEpochState <- easyRunQuery (queryCurrentEpochState sbe)

pure $ do
tip <- liftIO $ getLocalChainTip localNodeConnInfo
Expand Down Expand Up @@ -1899,13 +1817,8 @@ utcTimeToSlotNo nodeSocketPath consensusModeParams networkId target utcTime = do

lift
( executeLocalStateQueryExpr localNodeConnInfo target $ runExceptT $ do
systemStart <-
lift querySystemStart
& onLeft (left . QueryCmdUnsupportedNtcVersion)

eraHistory <-
lift queryEraHistory
& onLeft (left . QueryCmdUnsupportedNtcVersion)
systemStart <- easyRunQuerySystemStart
eraHistory <- easyRunQueryEraHistory

let relTime = toRelativeTime systemStart utcTime

Expand All @@ -1926,9 +1839,7 @@ requireEon
-- TODO: implement 'Bounded' for `Some eon` and remove 'minEra'
requireEon minEra era =
hoistMaybe
( QueryCmdLocalStateQueryError $
mkEraMismatchError NodeEraMismatchError{nodeEra = era, era = minEra}
)
(mkEraMismatchError NodeEraMismatchError{nodeEra = era, era = minEra})
(forEraMaybeEon era)

-- | The output format to use, for commands with a recently introduced --output-[json,text] flag
Expand All @@ -1943,3 +1854,24 @@ newOutputFormat format mOutFile =

strictTextToLazyBytestring :: Text -> LBS.ByteString
strictTextToLazyBytestring t = BS.fromChunks [Text.encodeUtf8 t]

easyRunQueryCurrentEra
:: ExceptT QueryCmdError (LocalStateQueryExpr block point QueryInMode r IO) AnyCardanoEra
easyRunQueryCurrentEra = lift queryCurrentEra & onLeft (left . QueryCmdUnsupportedNtcVersion)

easyRunQueryEraHistory
:: ExceptT QueryCmdError (LocalStateQueryExpr block point QueryInMode r IO) EraHistory
easyRunQueryEraHistory = lift queryEraHistory & onLeft (left . QueryCmdUnsupportedNtcVersion)

easyRunQuerySystemStart
:: ExceptT QueryCmdError (LocalStateQueryExpr block point QueryInMode r IO) SystemStart
easyRunQuerySystemStart = lift querySystemStart & onLeft (left . QueryCmdUnsupportedNtcVersion)

easyRunQuery
:: ()
=> Monad m
=> m (Either UnsupportedNtcVersionError (Either Consensus.EraMismatch a)) -> ExceptT QueryCmdError m a
easyRunQuery q =
lift q
& onLeft (left . QueryCmdUnsupportedNtcVersion)
& onLeft (left . QueryCmdEraMismatch)
Loading
Loading