Implement orphan instances

Propagate the new ShelleyBlock type in Cardano.Api.Query/InMode

cardano-api/src/Cardano/Api/InMode.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -33,6 +34,9 @@ import qualified Ouroboros.Consensus.HardFork.Combinator as Consensus
 import           Ouroboros.Consensus.HardFork.Combinator.AcrossEras (EraMismatch)
 import qualified Ouroboros.Consensus.HardFork.Combinator.Degenerate as Consensus
 import qualified Ouroboros.Consensus.Ledger.SupportsMempool as Consensus
+import qualified Ouroboros.Consensus.Ledger.SupportsProtocol as Consensus
+import qualified Ouroboros.Consensus.Protocol.TPraos as TPraos
+import qualified Ouroboros.Consensus.Shelley.HFEras as Consensus
 import qualified Ouroboros.Consensus.Shelley.Ledger as Consensus
 import qualified Ouroboros.Consensus.TypeFamilyWrappers as Consensus
 
@@ -96,6 +100,10 @@ fromConsensusGenTx CardanoMode (Consensus.HardForkGenTx (Consensus.OneEraGenTx (
   let Consensus.ShelleyTx _txid shelleyEraTx = tx'
   in TxInMode (ShelleyTx ShelleyBasedEraAlonzo shelleyEraTx) AlonzoEraInCardanoMode
 
+fromConsensusGenTx CardanoMode (Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (S (S (S (S (Z tx')))))))) =
+  let Consensus.ShelleyTx _txid shelleyEraTx = tx'
+  in TxInMode (ShelleyTx ShelleyBasedEraBabbage shelleyEraTx) BabbageEraInCardanoMode
+
 toConsensusGenTx :: ConsensusBlockForMode mode ~ block
                  => TxInMode mode
                  -> Consensus.GenTx block
@@ -142,10 +150,10 @@ toConsensusGenTx (TxInMode (ShelleyTx _ tx) AlonzoEraInCardanoMode) =
   where
     tx' = Consensus.mkShelleyTx tx
 
-toConsensusGenTx (TxInMode (ShelleyTx _ _tx) BabbageEraInCardanoMode) =
-    Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (S (S (S (Z tx'))))))
+toConsensusGenTx (TxInMode (ShelleyTx _ tx) BabbageEraInCardanoMode) =
+    Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (S (S (S (S (Z tx')))))))
   where
-    tx' = error "TODO: Babbage era - depends on consensus exposing a babbage era" -- Consensus.mkShelleyTx tx
+    tx' = Consensus.mkShelleyTx tx
 
 -- ----------------------------------------------------------------------------
 -- Transaction ids in the context of a consensus mode
@@ -171,9 +179,9 @@ toConsensusTxId (TxIdInMode txid ByronEraInByronMode) =
   txid' = Consensus.ByronTxId $ toByronTxId txid
 
 toConsensusTxId (TxIdInMode t ShelleyEraInShelleyMode) =
-  Consensus.HardForkGenTxId $ Consensus.OneEraGenTxId  $ Z  (Consensus.WrapGenTxId txid')
+    Consensus.HardForkGenTxId $ Consensus.OneEraGenTxId  $ Z  (Consensus.WrapGenTxId txid')
  where
-  txid' :: Consensus.TxId (Consensus.GenTx (Consensus.ShelleyBlock Consensus.StandardShelley))
+  txid' :: Consensus.TxId (Consensus.GenTx Consensus.StandardShelleyBlock)
   txid' = Consensus.ShelleyTxId $ toShelleyTxId t
 
 toConsensusTxId (TxIdInMode txid ByronEraInCardanoMode) =
@@ -185,25 +193,25 @@ toConsensusTxId (TxIdInMode txid ByronEraInCardanoMode) =
 toConsensusTxId (TxIdInMode txid ShelleyEraInCardanoMode) =
   Consensus.HardForkGenTxId (Consensus.OneEraGenTxId (S (Z (Consensus.WrapGenTxId txid'))))
  where
-  txid' :: Consensus.TxId (Consensus.GenTx (Consensus.ShelleyBlock Consensus.StandardShelley))
+  txid' :: Consensus.TxId (Consensus.GenTx Consensus.StandardShelleyBlock)
   txid' = Consensus.ShelleyTxId $ toShelleyTxId txid
 
 toConsensusTxId (TxIdInMode txid AllegraEraInCardanoMode) =
   Consensus.HardForkGenTxId (Consensus.OneEraGenTxId (S (S (Z (Consensus.WrapGenTxId txid')))))
  where
-  txid' :: Consensus.TxId (Consensus.GenTx (Consensus.ShelleyBlock Consensus.StandardAllegra))
+  txid' :: Consensus.TxId (Consensus.GenTx Consensus.StandardAllegraBlock)
   txid' = Consensus.ShelleyTxId $ toShelleyTxId txid
 
 toConsensusTxId (TxIdInMode txid MaryEraInCardanoMode) =
   Consensus.HardForkGenTxId (Consensus.OneEraGenTxId (S (S (S (Z (Consensus.WrapGenTxId txid'))))))
  where
-  txid' :: Consensus.TxId (Consensus.GenTx (Consensus.ShelleyBlock Consensus.StandardMary))
+  txid' :: Consensus.TxId (Consensus.GenTx Consensus.StandardMaryBlock)
   txid' = Consensus.ShelleyTxId $ toShelleyTxId txid
 
 toConsensusTxId (TxIdInMode txid AlonzoEraInCardanoMode) =
   Consensus.HardForkGenTxId (Consensus.OneEraGenTxId (S (S (S (S (Z (Consensus.WrapGenTxId txid')))))))
  where
-  txid' :: Consensus.TxId (Consensus.GenTx (Consensus.ShelleyBlock Consensus.StandardAlonzo))
+  txid' :: Consensus.TxId (Consensus.GenTx Consensus.StandardAlonzoBlock)
   txid' = Consensus.ShelleyTxId $ toShelleyTxId txid
 
 toConsensusTxId (TxIdInMode _txid BabbageEraInCardanoMode) =
@@ -224,7 +232,7 @@ data TxValidationError era where
 
      ShelleyTxValidationError
        :: ShelleyBasedEra era
-       -> Consensus.ApplyTxErr (Consensus.ShelleyBlock (ShelleyLedgerEra era))
+       -> Consensus.ApplyTxErr (Consensus.ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era))
        -> TxValidationError era
 
 -- The GADT in the ShelleyTxValidationError case requires a custom instance
@@ -282,6 +290,10 @@ deriving instance Show (TxValidationErrorInMode mode)
 
 
 fromConsensusApplyTxErr :: ConsensusBlockForMode mode ~ block
+                        => Consensus.LedgerSupportsProtocol
+                             (Consensus.ShelleyBlock
+                             (TPraos.TPraos Consensus.StandardCrypto)
+                             (Consensus.ShelleyEra Consensus.StandardCrypto))
                         => ConsensusMode mode
                         -> Consensus.ApplyTxErr block
                         -> TxValidationErrorInMode mode
@@ -320,6 +332,10 @@ fromConsensusApplyTxErr CardanoMode (Consensus.ApplyTxErrAlonzo err) =
       (ShelleyTxValidationError ShelleyBasedEraAlonzo err)
       AlonzoEraInCardanoMode
 
+fromConsensusApplyTxErr CardanoMode (Consensus.ApplyTxErrBabbage err) =
+    TxValidationErrorInMode
+      (ShelleyTxValidationError ShelleyBasedEraBabbage err)
+      BabbageEraInCardanoMode
+
 fromConsensusApplyTxErr CardanoMode (Consensus.ApplyTxErrWrongEra err) =
     TxValidationEraMismatch err
-

cardano-api/src/Cardano/Api/Orphans.hs

@@ -4,7 +4,9 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE UndecidableInstances #-}
 
 {-# OPTIONS_GHC -Wno-orphans #-}
@@ -27,15 +29,20 @@ import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
 import           Data.UMap (Trip (Triple), UMap (UnifiedMap))
 
+import qualified Cardano.Ledger.Babbage as Babbage
 import           Cardano.Ledger.BaseTypes (StrictMaybe (..))
 import qualified Cardano.Ledger.BaseTypes as Ledger
 import           Cardano.Ledger.Compactible (Compactible (fromCompact))
+import qualified Cardano.Ledger.Era as Ledger
 import qualified Cardano.Ledger.Shelley.PoolRank as Shelley
 import           Cardano.Ledger.UnifiedMap (UnifiedMap)
 import           Cardano.Slotting.Slot (SlotNo (..))
 import           Cardano.Slotting.Time (SystemStart (..))
 
 import qualified Cardano.Crypto.Hash.Class as Crypto
+import qualified Cardano.Ledger.Alonzo.Scripts as Alonzo
+import qualified Cardano.Ledger.Babbage.PParams as Babbage
+import qualified Cardano.Ledger.Babbage.TxBody as Babbage
 import qualified Cardano.Ledger.Coin as Shelley
 import qualified Cardano.Ledger.Core as Core
 import qualified Cardano.Ledger.Crypto as Crypto
@@ -51,6 +58,8 @@ import qualified Cardano.Ledger.Shelley.RewardUpdate as Shelley
 import qualified Cardano.Ledger.Shelley.Rewards as Shelley
 import qualified Ouroboros.Consensus.Shelley.Eras as Consensus
 
+import           Cardano.Api.Script
+import           Cardano.Api.SerialiseRaw (serialiseToRawBytesHexText)
 
 -- Orphan instances involved in the JSON output of the API queries.
 -- We will remove/replace these as we provide more API wrapper types
@@ -152,9 +161,61 @@ instance ToJSON (PParamsUpdate era) where
      ++ [ "protocolVersion"       .= x | x <- mbfield (Shelley._protocolVersion pp) ]
      ++ [ "minUTxOValue"          .= x | x <- mbfield (Shelley._minUTxOValue pp) ]
      ++ [ "minPoolCost"           .= x | x <- mbfield (Shelley._minPoolCost pp) ]
-    where
-      mbfield SNothing  = []
-      mbfield (SJust x) = [x]
+
+instance ToJSON (Babbage.PParamsUpdate era) where
+  toJSON pp =
+    Aeson.object $
+        [ "minFeeA"               .= x | x <- mbfield (Babbage._minfeeA pp) ]
+     ++ [ "minFeeB"               .= x | x <- mbfield (Babbage._minfeeB pp) ]
+     ++ [ "maxBlockBodySize"      .= x | x <- mbfield (Babbage._maxBBSize pp) ]
+     ++ [ "maxTxSize"             .= x | x <- mbfield (Babbage._maxTxSize pp) ]
+     ++ [ "maxBlockHeaderSize"    .= x | x <- mbfield (Babbage._maxBHSize pp) ]
+     ++ [ "keyDeposit"            .= x | x <- mbfield (Babbage._keyDeposit pp) ]
+     ++ [ "poolDeposit"           .= x | x <- mbfield (Babbage._poolDeposit pp) ]
+     ++ [ "eMax"                  .= x | x <- mbfield (Babbage._eMax pp) ]
+     ++ [ "nOpt"                  .= x | x <- mbfield (Babbage._nOpt pp) ]
+     ++ [ "a0"                    .= x | x <- mbfield (Babbage._a0 pp) ]
+     ++ [ "rho"                   .= x | x <- mbfield (Babbage._rho pp) ]
+     ++ [ "tau"                   .= x | x <- mbfield (Babbage._tau pp) ]
+     ++ [ "protocolVersion"       .= x | x <- mbfield (Babbage._protocolVersion pp) ]
+     ++ [ "minPoolCost"           .= x | x <- mbfield (Babbage._minPoolCost pp) ]
+     ++ [ "coinsPerUTxOWord"      .= x | x <- mbfield (Babbage._coinsPerUTxOWord pp) ]
+     ++ [ "costmdls"              .= x | x <- mbfield (Babbage._costmdls pp) ]
+     ++ [ "prices"                .= x | x <- mbfield (Babbage._prices pp) ]
+     ++ [ "maxTxExUnits"          .= x | x <- mbfield (Babbage._maxTxExUnits pp) ]
+     ++ [ "maxBlockExUnits"       .= x | x <- mbfield (Babbage._maxBlockExUnits pp) ]
+     ++ [ "maxValSize"            .= x | x <- mbfield (Babbage._maxValSize pp) ]
+     ++ [ "collateralPercentage"  .= x | x <- mbfield (Babbage._collateralPercentage pp) ]
+     ++ [ "maxCollateralInputs"   .= x | x <- mbfield (Babbage._maxCollateralInputs pp) ]
+
+mbfield :: StrictMaybe a -> [a]
+mbfield SNothing  = []
+mbfield (SJust x) = [x]
+
+instance ( Ledger.Era era
+         , ToJSON (Core.Value era)
+         , ToJSON (Babbage.Datum era)
+         , ToJSON (Core.Script era)
+         ) => ToJSON (Babbage.TxOut era) where
+  toJSON (Babbage.TxOut addr val dat mRefScript)=
+    object
+      [ "address" .= addr
+      , "value" .= val
+      , "datum" .= dat
+      , "referenceScript" .= mRefScript
+      ]
+
+instance Ledger.Crypto era ~ Consensus.StandardCrypto
+  => ToJSON (Babbage.Datum era) where
+    toJSON d = case Babbage.datumDataHash d of
+                 SNothing -> Aeson.Null
+                 SJust dH -> toJSON $ ScriptDataHash dH
+
+instance ToJSON (Alonzo.Script (Babbage.BabbageEra Consensus.StandardCrypto)) where
+  toJSON s = Aeson.String . serialiseToRawBytesHexText
+               $ ScriptHash $ Ledger.hashScript @(Babbage.BabbageEra Consensus.StandardCrypto) s
+
+
 
 instance Crypto.Crypto crypto => ToJSON (Shelley.DPState crypto) where
   toJSON dpState = object [ "dstate" .= Shelley.dpsDState dpState

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

@@ -91,6 +91,7 @@ import qualified Ouroboros.Consensus.Byron.Ledger as Consensus
 import           Ouroboros.Consensus.Cardano.Block (LedgerState (..), StandardCrypto)
 import qualified Ouroboros.Consensus.Cardano.Block as Consensus
 import qualified Ouroboros.Consensus.Ledger.Query as Consensus
+import qualified Ouroboros.Consensus.Protocol.Abstract as Consensus
 import qualified Ouroboros.Consensus.Shelley.Ledger as Consensus
 import           Ouroboros.Network.Block (Serialised (..))
 
@@ -307,6 +308,7 @@ instance
     ( Typeable era
     , Ledger.Era (ShelleyLedgerEra era)
     , FromCBOR (Core.PParams (ShelleyLedgerEra era))
+    , FromCBOR (Shelley.StashedAVVMAddresses (ShelleyLedgerEra era))
     , FromCBOR (Core.Value (ShelleyLedgerEra era))
     , FromCBOR (Ledger.State (Core.EraRule "PPUP" (ShelleyLedgerEra era)))
     , Share (Core.TxOut (ShelleyLedgerEra era)) ~ Interns (Shelley.Credential 'Shelley.Staking (Ledger.Crypto (ShelleyLedgerEra era)))
@@ -330,9 +332,8 @@ instance ( IsShelleyBasedEra era
                                           , "possibleRewardUpdate" .= Shelley.nesRu newEpochS
                                           , "stakeDistrib" .= Shelley.nesPd newEpochS
                                           ]
-
 newtype ProtocolState era
-  = ProtocolState (Serialised (TPraos.ChainDepState (Ledger.Crypto (ShelleyLedgerEra era))))
+  = ProtocolState (Serialised (Consensus.ChainDepState (ConsensusProtocol era)))
 
 decodeProtocolState
   :: ProtocolState era
@@ -474,8 +475,8 @@ toConsensusQuery (QueryInEra erainmode (QueryInShelleyBasedEra era q)) =
 
 
 toConsensusQueryShelleyBased
-  :: forall era ledgerera mode block xs result.
-     ConsensusBlockForEra era ~ Consensus.ShelleyBlock ledgerera
+  :: forall era ledgerera mode protocol block xs result.
+     ConsensusBlockForEra era ~ Consensus.ShelleyBlock protocol ledgerera
   => Ledger.Crypto ledgerera ~ Consensus.StandardCrypto
   => ConsensusBlockForMode mode ~ block
   => block ~ Consensus.HardForkBlock xs
@@ -673,16 +674,23 @@ fromConsensusQueryResult (QueryInEra AlonzoEraInCardanoMode
       _ -> fromConsensusQueryResultMismatch
 
 fromConsensusQueryResult (QueryInEra BabbageEraInCardanoMode
-                                     (QueryInShelleyBasedEra _era _q)) _q' _r' =
-    error "TODO: Babbage era - depends on consensus exposing a babbage era"
+                                     (QueryInShelleyBasedEra _era q)) q' r' =
+    case q' of
+      Consensus.BlockQuery (Consensus.QueryIfCurrentBabbage q'')
+        -> bimap fromConsensusEraMismatch
+                 (fromConsensusQueryResultShelleyBased
+                    ShelleyBasedEraBabbage q q'')
+                 r'
+      _ -> fromConsensusQueryResultMismatch
 
 fromConsensusQueryResultShelleyBased
-  :: forall era ledgerera result result'.
+  :: forall era ledgerera protocol result result'.
      ShelleyLedgerEra era ~ ledgerera
   => Ledger.Crypto ledgerera ~ Consensus.StandardCrypto
+  => ConsensusProtocol era ~ protocol
   => ShelleyBasedEra era
   -> QueryInShelleyBasedEra era result
-  -> Consensus.BlockQuery (Consensus.ShelleyBlock ledgerera) result'
+  -> Consensus.BlockQuery (Consensus.ShelleyBlock protocol ledgerera) result'
   -> result'
   -> result
 fromConsensusQueryResultShelleyBased _ QueryEpoch q' epoch =