Merge pull request #386 from input-output-hk/mgalazyn/feature/guard-q…

…ueries-with-their-eras

Guard queries with their respective eras

cardano-api/internal/Cardano/Api/Convenience/Query.hs

@@ -1,6 +1,5 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 
 -- | Convenience query functions
@@ -18,7 +17,6 @@ module Cardano.Api.Convenience.Query (
 
 import           Cardano.Api.Address
 import           Cardano.Api.Certificate
-import           Cardano.Api.Eon.ConwayEraOnwards (ConwayEraOnwards)
 import           Cardano.Api.Eon.ShelleyBasedEra
 import           Cardano.Api.Eras
 import           Cardano.Api.IO
@@ -113,14 +111,15 @@ queryStateForBalancedTx era allTxIns certs = runExceptT $ do
     & onLeft (left . QueryEraMismatch)
 
   stakeDelegDeposits <-
-    lift (queryStakeDelegDeposits sbe stakeCreds)
-      & onLeft (left . QceUnsupportedNtcVersion)
-      & onLeft (left . QueryEraMismatch)
+    monoidForEraInEonA era $ \beo ->
+      lift (queryStakeDelegDeposits beo stakeCreds)
+        & onLeft (left . QceUnsupportedNtcVersion)
+        & onLeft (left . QueryEraMismatch)
 
   drepDelegDeposits <-
-    forEraInEon @ConwayEraOnwards era (pure mempty) $ \_ ->
+    monoidForEraInEonA era $ \con ->
       Map.map (fromShelleyLovelace . drepDeposit) <$>
-      (lift (queryDRepState sbe drepCreds)
+      (lift (queryDRepState con drepCreds)
           & onLeft (left . QceUnsupportedNtcVersion)
           & onLeft (left . QueryEraMismatch))
 

cardano-api/internal/Cardano/Api/Query.hs

@@ -1,6 +1,5 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE EmptyCase #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
@@ -325,6 +324,10 @@ data QueryInShelleyBasedEra era result where
     -> QueryInShelleyBasedEra era (Map StakeCredential (Ledger.DRep StandardCrypto))
 
 
+-- | Mapping for queries in Shelley-based eras returning minimal node-to-client protocol versions. More
+-- information about queries versioning can be found:
+--   * https://input-output-hk.github.io/ouroboros-network/ouroboros-network/Ouroboros-Network-NodeToClient.html#t:NodeToClientVersion
+--   * https://input-output-hk.github.io/ouroboros-consensus/docs/for-developers/QueryVersioning/#implementation
 instance NodeToClientVersionOf (QueryInShelleyBasedEra era result) where
   nodeToClientVersionOf QueryEpoch = NodeToClientV_9
   nodeToClientVersionOf QueryGenesisParameters = NodeToClientV_9
@@ -338,10 +341,12 @@ instance NodeToClientVersionOf (QueryInShelleyBasedEra era result) where
   nodeToClientVersionOf QueryDebugLedgerState = NodeToClientV_9
   nodeToClientVersionOf QueryProtocolState = NodeToClientV_9
   nodeToClientVersionOf QueryCurrentEpochState = NodeToClientV_9
+  -- Babbage >= v13
   nodeToClientVersionOf (QueryPoolState _) = NodeToClientV_14
   nodeToClientVersionOf (QueryPoolDistribution _) = NodeToClientV_14
   nodeToClientVersionOf (QueryStakeSnapshot _) = NodeToClientV_14
   nodeToClientVersionOf (QueryStakeDelegDeposits _) = NodeToClientV_15
+  -- Conway >= v16
   nodeToClientVersionOf QueryConstitution = NodeToClientV_16
   nodeToClientVersionOf QueryGovState = NodeToClientV_16
   nodeToClientVersionOf QueryDRepState{} = NodeToClientV_16

cardano-api/internal/Cardano/Api/Query/Expr.hs

@@ -37,6 +37,8 @@ module Cardano.Api.Query.Expr
 import           Cardano.Api.Address
 import           Cardano.Api.Block
 import           Cardano.Api.Certificate
+import           Cardano.Api.Eon.BabbageEraOnwards
+import           Cardano.Api.Eon.ConwayEraOnwards
 import           Cardano.Api.Eon.ShelleyBasedEra
 import           Cardano.Api.Eras
 import           Cardano.Api.GenesisParameters
@@ -108,17 +110,19 @@ queryGenesisParameters sbe =
   queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe QueryGenesisParameters
 
 queryPoolDistribution :: ()
-  => ShelleyBasedEra era
+  => BabbageEraOnwards era
   -> Maybe (Set PoolId)
   -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (SerialisedPoolDistribution era)))
-queryPoolDistribution sbe mPoolIds =
+queryPoolDistribution era mPoolIds = do
+  let sbe = babbageEraOnwardsToShelleyBasedEra era
   queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe $ QueryPoolDistribution mPoolIds
 
 queryPoolState :: ()
-  => ShelleyBasedEra era
+  => BabbageEraOnwards era
   -> Maybe (Set PoolId)
   -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (SerialisedPoolState era)))
-queryPoolState sbe mPoolIds =
+queryPoolState era mPoolIds = do
+  let sbe = babbageEraOnwardsToShelleyBasedEra era
   queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe $ QueryPoolState mPoolIds
 
 queryProtocolParameters :: ()
@@ -155,12 +159,14 @@ queryStakeAddresses sbe stakeCredentials networkId =
   queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe $ QueryStakeAddresses stakeCredentials networkId
 
 queryStakeDelegDeposits :: ()
-  => ShelleyBasedEra era
+  => BabbageEraOnwards era
   -> Set StakeCredential
   -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either Consensus.EraMismatch (Map StakeCredential Lovelace)))
-queryStakeDelegDeposits sbe stakeCreds
+queryStakeDelegDeposits era stakeCreds
   | S.null stakeCreds = pure . pure $ pure mempty
-  | otherwise         = queryExpr $ QueryInEra . QueryInShelleyBasedEra sbe $ QueryStakeDelegDeposits stakeCreds
+  | otherwise         = do
+    let sbe = babbageEraOnwardsToShelleyBasedEra era
+    queryExpr $ QueryInEra . QueryInShelleyBasedEra sbe $ QueryStakeDelegDeposits stakeCreds
 
 queryStakeDistribution :: ()
   => ShelleyBasedEra era
@@ -183,10 +189,11 @@ queryStakePools sbe =
   queryExpr $ QueryInEra . QueryInShelleyBasedEra sbe $ QueryStakePools
 
 queryStakeSnapshot :: ()
-  => ShelleyBasedEra era
+  => BabbageEraOnwards era
   -> Maybe (Set PoolId)
   -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (SerialisedStakeSnapshots era)))
-queryStakeSnapshot sbe mPoolIds =
+queryStakeSnapshot era mPoolIds = do
+  let sbe = babbageEraOnwardsToShelleyBasedEra era
   queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe $ QueryStakeSnapshot mPoolIds
 
 querySystemStart :: ()
@@ -202,45 +209,53 @@ queryUtxo sbe utxoFilter =
   queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe $ QueryUTxO utxoFilter
 
 queryConstitution :: ()
-  => ShelleyBasedEra era
+  => ConwayEraOnwards era
   -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Maybe (L.Constitution (ShelleyLedgerEra era)))))
-queryConstitution sbe =
+queryConstitution era = do
+  let sbe = conwayEraOnwardsToShelleyBasedEra era
   queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe QueryConstitution
 
 queryGovState :: ()
-  => ShelleyBasedEra era
+  => ConwayEraOnwards era
   -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (L.GovState (ShelleyLedgerEra era))))
-queryGovState sbe =
+queryGovState era = do
+  let sbe = conwayEraOnwardsToShelleyBasedEra era
   queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe QueryGovState
 
 queryDRepState :: ()
-  => ShelleyBasedEra era
+  => ConwayEraOnwards era
   -> Set (L.Credential L.DRepRole L.StandardCrypto)
   -- ^ An empty credentials set means that states for all DReps will be returned
   -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Map (L.Credential L.DRepRole L.StandardCrypto) (L.DRepState L.StandardCrypto))))
-queryDRepState sbe drepCreds = queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe $ QueryDRepState drepCreds
+queryDRepState era drepCreds = do
+  let sbe = conwayEraOnwardsToShelleyBasedEra era
+  queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe $ QueryDRepState drepCreds
 
 queryDRepStakeDistribution :: ()
-  => ShelleyBasedEra era
+  => ConwayEraOnwards era
   -> Set (L.DRep L.StandardCrypto)
   -- ^ An empty DRep set means that distributions for all DReps will be returned
   -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Map (L.DRep L.StandardCrypto) Lovelace)))
-queryDRepStakeDistribution sbe dreps = queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe $ QueryDRepStakeDistr dreps
+queryDRepStakeDistribution era dreps = do
+  let sbe = conwayEraOnwardsToShelleyBasedEra era
+  queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe $ QueryDRepStakeDistr dreps
 
 -- | Returns info about committee members filtered by: cold credentials, hot credentials and statuses.
 -- If empty sets are passed as filters, then no filtering is done.
 queryCommitteeMembersState :: ()
-  => ShelleyBasedEra era
+  => ConwayEraOnwards era
   -> Set (L.Credential L.ColdCommitteeRole L.StandardCrypto)
   -> Set (L.Credential L.HotCommitteeRole L.StandardCrypto)
   -> Set L.MemberStatus
   -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Maybe (L.CommitteeMembersState L.StandardCrypto))))
-queryCommitteeMembersState sbe coldCreds hotCreds statuses =
+queryCommitteeMembersState era coldCreds hotCreds statuses = do
+  let sbe = conwayEraOnwardsToShelleyBasedEra era
   queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe (QueryCommitteeMembersState coldCreds hotCreds statuses)
 
 queryStakeVoteDelegatees :: ()
-  => ShelleyBasedEra era
+  => ConwayEraOnwards era
   -> Set StakeCredential
   -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Map StakeCredential (L.DRep L.StandardCrypto))))
-queryStakeVoteDelegatees sbe stakeCredentials =
+queryStakeVoteDelegatees era stakeCredentials = do
+  let sbe = conwayEraOnwardsToShelleyBasedEra era
   queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe $ QueryStakeVoteDelegatees stakeCredentials