Guard queries with eras

cardano-cli/src/Cardano/CLI/EraBased/Options/Common.hs

@@ -178,7 +178,7 @@ parseTxId = do
   str' <- some Parsec.hexDigit <?> "transaction id (hexadecimal)"
   case deserialiseFromRawBytesHex AsTxId (BSC.pack str') of
     Right addr -> return addr
-    Left e -> fail $ prettyToString $ "Incorrect transaction id format: " <> prettyError e
+    Left e -> fail $ docToString $ "Incorrect transaction id format: " <> prettyError e
 
 parseTxIx :: Parsec.Parser TxIx
 parseTxIx = TxIx . fromIntegral <$> decimal
@@ -260,7 +260,7 @@ readVerificationKey asType =
       :: String
       -> Either String (VerificationKey keyrole)
     deserialiseFromBech32OrHex str' =
-      first (prettyToString . renderInputDecodeError) $
+      first (docToString . renderInputDecodeError) $
         deserialiseInput (AsVerificationKey asType) keyFormats (BSC.pack str')
 
 -- | The first argument is the optional prefix.
@@ -498,14 +498,14 @@ pHexHash
   :: SerialiseAsRawBytes (Hash a) => AsType a -> ReadM (Hash a)
 pHexHash a =
   Opt.eitherReader $
-    first (prettyToString . prettyError)
+    first (docToString . prettyError)
       . deserialiseFromRawBytesHex (AsHash a)
       . BSC.pack
 
 pBech32KeyHash :: SerialiseAsBech32 (Hash a) => AsType a -> ReadM (Hash a)
 pBech32KeyHash a =
   Opt.eitherReader $
-    first (prettyToString . prettyError)
+    first (docToString . prettyError)
     . deserialiseFromBech32 (AsHash a)
     . Text.pack
 
@@ -522,7 +522,7 @@ pGenesisDelegateVerificationKey =
       -> Either String (VerificationKey GenesisDelegateKey)
     deserialiseFromHex =
       first
-        (\e -> prettyToString $ "Invalid genesis delegate verification key: " <> prettyError e)
+        (\e -> docToString $ "Invalid genesis delegate verification key: " <> prettyError e)
         . deserialiseFromRawBytesHex (AsVerificationKey AsGenesisDelegateKey)
         . BSC.pack
 
@@ -619,7 +619,7 @@ pAddCommitteeColdVerificationKeyHash =
   where
     deserialiseFromHex :: String -> Either String (Hash CommitteeColdKey)
     deserialiseFromHex =
-      first (\e -> prettyToString $ "Invalid Consitutional Committee cold key hash: " <> prettyError e)
+      first (\e -> docToString $ "Invalid Consitutional Committee cold key hash: " <> prettyError e)
         . deserialiseFromRawBytesHex (AsHash AsCommitteeColdKey)
         . BSC.pack
 
@@ -640,7 +640,7 @@ pAddCommitteeColdVerificationKey =
   where
     deserialiseFromHex :: String -> Either String (VerificationKey CommitteeColdKey)
     deserialiseFromHex =
-      first (\e -> prettyToString $ "Invalid Constitutional Committee cold key: " <> prettyError e)
+      first (\e -> docToString $ "Invalid Constitutional Committee cold key: " <> prettyError e)
         . deserialiseFromRawBytesHex (AsVerificationKey AsCommitteeColdKey)
         . BSC.pack
 
@@ -671,7 +671,7 @@ pRemoveCommitteeColdVerificationKeyHash =
   where
     deserialiseFromHex :: String -> Either String (Hash CommitteeColdKey)
     deserialiseFromHex =
-      first (\e -> prettyToString $ "Invalid Consitutional Committee cold key hash: " <> prettyError e)
+      first (\e -> docToString $ "Invalid Consitutional Committee cold key hash: " <> prettyError e)
         . deserialiseFromRawBytesHex (AsHash AsCommitteeColdKey)
         . BSC.pack
 
@@ -692,7 +692,7 @@ pRemoveCommitteeColdVerificationKey =
   where
     deserialiseFromHex :: String -> Either String (VerificationKey CommitteeColdKey)
     deserialiseFromHex =
-      first (\e -> prettyToString $ "Invalid Constitutional Committee cold key: " <> prettyError e)
+      first (\e -> docToString $ "Invalid Constitutional Committee cold key: " <> prettyError e)
         . deserialiseFromRawBytesHex (AsVerificationKey AsCommitteeColdKey)
         . BSC.pack
 
@@ -731,7 +731,7 @@ pCommitteeColdVerificationKey =
   where
     deserialiseFromHex :: String -> Either String (VerificationKey CommitteeColdKey)
     deserialiseFromHex =
-      first (\e -> prettyToString $ "Invalid Constitutional Committee cold key: " <> prettyError e)
+      first (\e -> docToString $ "Invalid Constitutional Committee cold key: " <> prettyError e)
         . deserialiseFromRawBytesHex (AsVerificationKey AsCommitteeColdKey)
         . BSC.pack
 
@@ -745,7 +745,7 @@ pCommitteeColdVerificationKeyHash =
   where
     deserialiseFromHex :: String -> Either String (Hash CommitteeColdKey)
     deserialiseFromHex =
-      first (\e -> prettyToString $ "Invalid Consitutional Committee cold key hash: " <> prettyError e)
+      first (\e -> docToString $ "Invalid Consitutional Committee cold key hash: " <> prettyError e)
         . deserialiseFromRawBytesHex (AsHash AsCommitteeColdKey)
         . BSC.pack
 
@@ -809,7 +809,7 @@ pCommitteeHotVerificationKey =
 
 deserialiseHotCCKeyFromHex :: String -> Either String (VerificationKey CommitteeHotKey)
 deserialiseHotCCKeyFromHex =
-  first (\e -> prettyToString $ "Invalid Constitutional Committee hot key: " <> prettyError e)
+  first (\e -> docToString $ "Invalid Constitutional Committee hot key: " <> prettyError e)
     . deserialiseFromRawBytesHex (AsVerificationKey AsCommitteeHotKey)
     . BSC.pack
 
@@ -842,7 +842,7 @@ pCommitteeHotKeyHash prefix =
   where
     deserialiseFromHex :: String -> Either String (Hash CommitteeHotKey)
     deserialiseFromHex =
-      first (\e -> prettyToString $ "Invalid Consitutional Committee hot key hash: " <> prettyError e)
+      first (\e -> docToString $ "Invalid Consitutional Committee hot key hash: " <> prettyError e)
         . deserialiseFromRawBytesHex (AsHash AsCommitteeHotKey)
         . BSC.pack
 
@@ -1162,7 +1162,7 @@ pScriptDataOrFile dataFlagPrefix helpTextForValue helpTextForFile =
         Left e -> fail $ "readerScriptData: " <> e
         Right sDataValue ->
           case scriptDataJsonToHashable ScriptDataJsonNoSchema sDataValue of
-            Left err -> fail $ prettyToString $ prettyError err
+            Left err -> fail $ docToString $ prettyError err
             Right sd -> return sd
 
 --------------------------------------------------------------------------------
@@ -1648,7 +1648,7 @@ pGenesisVerificationKeyHash =
   where
     deserialiseFromHex :: String -> Either String (Hash GenesisKey)
     deserialiseFromHex =
-      first (\e -> prettyToString $ "Invalid genesis verification key hash: " <> prettyError e)
+      first (\e -> docToString $ "Invalid genesis verification key hash: " <> prettyError e)
         . deserialiseFromRawBytesHex (AsHash AsGenesisKey)
         . BSC.pack
 
@@ -1662,7 +1662,7 @@ pGenesisVerificationKey =
   where
     deserialiseFromHex :: String -> Either String (VerificationKey GenesisKey)
     deserialiseFromHex =
-      first (\e -> prettyToString $ "Invalid genesis verification key: " <> prettyError e)
+      first (\e -> docToString $ "Invalid genesis verification key: " <> prettyError e)
         . deserialiseFromRawBytesHex (AsVerificationKey AsGenesisKey)
         . BSC.pack
 
@@ -1701,7 +1701,7 @@ pGenesisDelegateVerificationKeyHash =
     deserialiseFromHex =
       first
         (\e ->
-          prettyToString $ "Invalid genesis delegate verification key hash: " <> prettyError e)
+          docToString $ "Invalid genesis delegate verification key hash: " <> prettyError e)
         . deserialiseFromRawBytesHex (AsHash AsGenesisDelegateKey)
         . BSC.pack
 
@@ -1745,15 +1745,15 @@ pKesVerificationKey =
         Right res -> Right res
 
         -- The input was valid Bech32, but some other error occurred.
-        Left err@(Bech32UnexpectedPrefix _ _) -> Left (prettyToString $ prettyError err)
-        Left err@(Bech32DataPartToBytesError _) -> Left (prettyToString $ prettyError err)
-        Left err@(Bech32DeserialiseFromBytesError _) -> Left (prettyToString $ prettyError err)
-        Left err@(Bech32WrongPrefix _ _) -> Left (prettyToString $ prettyError err)
+        Left err@(Bech32UnexpectedPrefix _ _) -> Left (docToString $ prettyError err)
+        Left err@(Bech32DataPartToBytesError _) -> Left (docToString $ prettyError err)
+        Left err@(Bech32DeserialiseFromBytesError _) -> Left (docToString $ prettyError err)
+        Left err@(Bech32WrongPrefix _ _) -> Left (docToString $ prettyError err)
 
         -- The input was not valid Bech32. Attempt to deserialise it as hex.
         Left (Bech32DecodingError _) ->
           first
-            (\e -> prettyToString $ "Invalid stake pool verification key: " <> prettyError e) $
+            (\e -> docToString $ "Invalid stake pool verification key: " <> prettyError e) $
           deserialiseFromRawBytesHex asType (BSC.pack str)
 
 pKesVerificationKeyFile :: Parser (VerificationKeyFile In)
@@ -2318,7 +2318,7 @@ pVrfVerificationKeyHash =
   where
     deserialiseFromHex :: String -> Either String (Hash VrfKey)
     deserialiseFromHex =
-      first (\e -> prettyToString $ "Invalid VRF verification key hash: " <> prettyError e)
+      first (\e -> docToString $ "Invalid VRF verification key hash: " <> prettyError e)
         . deserialiseFromRawBytesHex (AsHash AsVrfKey)
         . BSC.pack
 
@@ -2535,7 +2535,7 @@ pStakePoolMetadataHash =
   where
     metadataHash :: String -> Either String (Hash StakePoolMetadata)
     metadataHash =
-      first (prettyToString . prettyError)
+      first (docToString . prettyError)
         . deserialiseFromRawBytesHex (AsHash AsStakePoolMetadata)
         . BSC.pack
 

cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs

@@ -50,6 +50,7 @@ import           Cardano.CLI.EraBased.Run.Genesis (readAndDecodeShelleyGenesis)
 import           Cardano.CLI.Helpers
 import           Cardano.CLI.Read
 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
@@ -264,7 +265,7 @@ runQueryTipCmd
         }
 
   mLocalState <- hushM (first QueryCmdAcquireFailure eLocalState) $ \e ->
-    liftIO . LT.hPutStrLn IO.stderr $ prettyToLazyText $ "Warning: Local state unavailable: " <> renderQueryCmdError e
+    liftIO . LT.hPutStrLn IO.stderr $ docToLazyText $ "Warning: Local state unavailable: " <> renderQueryCmdError e
 
   chainTip <- pure (mLocalState >>= O.mChainTip)
     -- The chain tip is unavailable via local state query because we are connecting with an older
@@ -280,7 +281,7 @@ runQueryTipCmd
   localStateOutput <- forM mLocalState $ \localState -> do
     case slotToEpoch tipSlotNo (O.eraHistory localState) of
       Left e -> do
-        liftIO . LT.hPutStrLn IO.stderr $ prettyToLazyText $
+        liftIO . LT.hPutStrLn IO.stderr $ docToLazyText $
           "Warning: Epoch unavailable: " <> renderQueryCmdError (QueryCmdPastHorizon e)
         return $ O.QueryTipLocalStateOutput
           { O.localStateChainTip = chainTip
@@ -302,7 +303,7 @@ runQueryTipCmd
           return $ flip (percentage tolerance) nowSeconds tipTimeResult
 
         mSyncProgress <- hushM syncProgressResult $ \e -> do
-          liftIO . LT.hPutStrLn IO.stderr $ prettyToLazyText $ "Warning: Sync progress unavailable: " <> renderQueryCmdError e
+          liftIO . LT.hPutStrLn IO.stderr $ docToLazyText $ "Warning: Sync progress unavailable: " <> renderQueryCmdError e
 
         return $ O.QueryTipLocalStateOutput
           { O.localStateChainTip = chainTip
@@ -404,8 +405,8 @@ runQueryKesPeriodInfoCmd
           let counterInformation = opCertNodeAndOnDiskCounters onDiskC stateC
 
           -- Always render diagnostic information
-          liftIO . putStrLn $ prettyToString $ renderOpCertIntervalInformation (unFile nodeOpCertFp) opCertIntervalInformation
-          liftIO . putStrLn $ prettyToString $ renderOpCertNodeAndOnDiskCounterInformation (unFile nodeOpCertFp) counterInformation
+          liftIO . putStrLn $ docToString $ renderOpCertIntervalInformation (unFile nodeOpCertFp) opCertIntervalInformation
+          liftIO . putStrLn $ docToString $ renderOpCertNodeAndOnDiskCounterInformation (unFile nodeOpCertFp) counterInformation
 
           let qKesInfoOutput = createQueryKesPeriodInfoOutput opCertIntervalInformation counterInformation eInfo gParams
               kesPeriodInfoJSON = encodePretty qKesInfoOutput
@@ -631,7 +632,8 @@ runQueryPoolStateCmd
         sbe <- requireShelleyBasedEra era
           & onNothing (left QueryCmdByronEra)
 
-        beo <- forEraMaybeEon era & hoistMaybe (QueryCmdLocalStateQueryError . mkEraMismatchError EraNodeMismatchError { nodeEra = era, era = BabbageEra }) )
+        beo <- forEraMaybeEon era
+          & hoistMaybe (QueryCmdLocalStateQueryError $ mkEraMismatchError NodeEraMismatchError { nodeEra = era, era = BabbageEra })
 
         result <- lift (queryPoolState beo $ Just $ Set.fromList poolIds)
           & onLeft (left . QueryCmdUnsupportedNtcVersion)
@@ -713,7 +715,10 @@ runQueryStakeSnapshotCmd
               All -> Nothing
               Only poolIds -> Just $ Set.fromList poolIds
 
-        result <- lift (queryStakeSnapshot sbe poolFilter)
+        beo <- forEraMaybeEon era
+          & hoistMaybe (QueryCmdLocalStateQueryError $ mkEraMismatchError NodeEraMismatchError { nodeEra = era, era = BabbageEra })
+
+        result <- lift (queryStakeSnapshot beo poolFilter)
           & onLeft (left . QueryCmdUnsupportedNtcVersion)
           & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError)
 
@@ -812,14 +817,19 @@ runQueryStakeAddressInfoCmd
           & onLeft (left . QueryCmdUnsupportedNtcVersion)
           & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError)
 
-        stakeDelegDeposits <- lift (queryStakeDelegDeposits sbe stakeAddr)
+        beo <- forEraMaybeEon era
+          & hoistMaybe (QueryCmdLocalStateQueryError $ mkEraMismatchError NodeEraMismatchError { nodeEra = era, era = BabbageEra })
+
+        stakeDelegDeposits <- lift (queryStakeDelegDeposits beo stakeAddr)
           & onLeft (left . QueryCmdUnsupportedNtcVersion)
           & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError)
 
-        stakeVoteDelegatees <- monoidForEraInEonA era $ \(_ :: ConwayEraOnwards era) ->
-          lift (queryStakeVoteDelegatees sbe stakeAddr)
-            & onLeft (left . QueryCmdUnsupportedNtcVersion)
-            & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError)
+        ceo <- forEraMaybeEon era
+          & hoistMaybe (QueryCmdLocalStateQueryError $ mkEraMismatchError NodeEraMismatchError { nodeEra = era, era = ConwayEra })
+
+        stakeVoteDelegatees <- lift (queryStakeVoteDelegatees ceo stakeAddr)
+          & onLeft (left . QueryCmdUnsupportedNtcVersion)
+          & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError)
 
         return $ do
           writeStakeAddressInfo
@@ -1223,7 +1233,10 @@ runQueryLeadershipScheduleCmd
 
         case whichSchedule of
           CurrentEpoch -> do
-            serCurrentEpochState <- lift (queryPoolDistribution sbe (Just (Set.singleton poolid)))
+            beo <- forEraMaybeEon era
+              & hoistMaybe (QueryCmdLocalStateQueryError $ mkEraMismatchError NodeEraMismatchError { nodeEra = era, era = BabbageEra })
+
+            serCurrentEpochState <- lift (queryPoolDistribution beo (Just (Set.singleton poolid)))
               & onLeft (left . QueryCmdUnsupportedNtcVersion)
               & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError)
 
@@ -1519,3 +1532,4 @@ utcTimeToSlotNo nodeSocketPath consensusModeParams networkId utcTime = do
     )
     & onLeft (left . QueryCmdAcquireFailure)
     & onLeft left
+

cardano-cli/src/Cardano/CLI/Pretty.hs

@@ -23,7 +23,7 @@ consoleBracket :: IO a -> IO a
 consoleBracket = bracket_ (IO.waitQSem sem) (IO.signalQSem sem)
 
 putLn :: MonadIO m => Doc AnsiStyle -> m ()
-putLn = liftIO . consoleBracket . TextLazy.putStrLn . prettyToLazyText
+putLn = liftIO . consoleBracket . TextLazy.putStrLn . docToLazyText
 
 hPutLn :: MonadIO m => IO.Handle -> Doc AnsiStyle -> m ()
-hPutLn h = liftIO . consoleBracket . TextLazy.hPutStr h . prettyToLazyText
+hPutLn h = liftIO . consoleBracket . TextLazy.hPutStr h . docToLazyText

cardano-cli/src/Cardano/CLI/Types/Errors/QueryCmdLocalStateQueryError.hs

@@ -9,8 +9,8 @@ module Cardano.CLI.Types.Errors.QueryCmdLocalStateQueryError
 
 import           Cardano.Api.Pretty
 
+import           Cardano.CLI.Types.Errors.NodeEraMismatchError
 import           Ouroboros.Consensus.Cardano.Block (EraMismatch (..))
-import Cardano.CLI.Types.Errors.NodeEraMismatchError
 
 -- | An error that can occur while querying a node's local state.
 newtype QueryCmdLocalStateQueryError
@@ -21,8 +21,8 @@ newtype QueryCmdLocalStateQueryError
 
 mkEraMismatchError :: NodeEraMismatchError -> QueryCmdLocalStateQueryError
 mkEraMismatchError NodeEraMismatchError{nodeEra, era} =
-  EraMismatchError EraMismatch{ ledgerEraName = prettyToText $ pretty nodeEra
-                              , otherEraName = prettyToText $ pretty era}
+  EraMismatchError EraMismatch{ ledgerEraName = docToText $ pretty nodeEra
+                              , otherEraName = docToText $ pretty era}
 
 renderLocalStateQueryError :: QueryCmdLocalStateQueryError -> Doc ann
 renderLocalStateQueryError = \case

cardano-cli/src/Cardano/CLI/Types/Errors/StakeAddressDelegationError.hs

@@ -8,13 +8,8 @@ module Cardano.CLI.Types.Errors.StakeAddressDelegationError
 import           Cardano.Api
 import           Cardano.Api.Pretty
 
-import qualified Data.Text as Text
-
 newtype StakeAddressDelegationError = VoteDelegationNotSupported (EraInEon ShelleyToBabbageEra) deriving Show
 
 instance Error StakeAddressDelegationError where
   prettyError = \case
-    VoteDelegationNotSupported (EraInEon eraInEon) -> "Vote delegation not supported in " <> pshow eraTxt <> " era."
-      where
-        cEra = toCardanoEra eraInEon
-        eraTxt = cardanoEraConstraints cEra $ Text.unpack . renderEra $ AnyCardanoEra cEra
+    VoteDelegationNotSupported (EraInEon eraInEon) -> "Vote delegation not supported in " <> pretty (toCardanoEra eraInEon) <> " era."

cardano-cli/src/Cardano/CLI/Types/Errors/TxCmdError.hs

@@ -110,13 +110,13 @@ renderTxCmdError = \case
     renderBootstrapWitnessError sbwErr
   TxCmdTxFeatureMismatch era TxFeatureImplicitFees ->
     "An explicit transaction fee must be specified for " <>
-    pretty (renderEra era) <> " era transactions."
+    pretty era <> " era transactions."
 
   TxCmdTxFeatureMismatch (AnyCardanoEra ShelleyEra) TxFeatureValidityNoUpperBound ->
     "A TTL must be specified for Shelley era transactions."
 
   TxCmdTxFeatureMismatch era feature ->
-    pretty (renderFeature feature) <> " cannot be used for " <> pretty (renderEra era) <>
+    pretty (renderFeature feature) <> " cannot be used for " <> pretty era <>
     " era transactions."
 
   TxCmdTxBodyError err' ->
@@ -127,8 +127,8 @@ renderTxCmdError = \case
 
   TxCmdWitnessEraMismatch era era' (WitnessFile file) ->
     "The era of a witness does not match the era of the transaction. " <>
-    "The transaction is for the " <> pretty (renderEra era) <> " era, but the " <>
-    "witness in " <> pshow file <> " is for the " <> pretty (renderEra era') <> " era."
+    "The transaction is for the " <> pretty era <> " era, but the " <>
+    "witness in " <> pshow file <> " is for the " <> pretty era' <> " era."
 
   TxCmdPolicyIdsMissing policyids ->
     mconcat