Skip to content

Commit

Permalink
Merge pull request #993 from IntersectMBO/smelc/simplify-queries-code
Browse files Browse the repository at this point in the history 
Query.hs: simplify implementation with a few new functions and code sharing
  • Loading branch information
@smelc
smelc authored Dec 13, 2024
2 parents e68b762 + c730206 commit 3388452
Show file tree
Hide file tree
Showing 4 changed files with 70 additions and 167 deletions.
1 change: 0 additions & 1 deletion cardano-cli/cardano-cli.cabal
View file
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
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)
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

0 comments on commit 3388452

Please sign in to comment.