Wire up makeShelleyTransactionBody for Babbage era

IntersectMBO · May 20, 2022 · 06383b7 · 06383b7
1 parent 6c90668
commit 06383b7
Showing 1 changed file with 57 additions and 59 deletions.
diff --git a/cardano-api/src/Cardano/Api/TxBody.hs b/cardano-api/src/Cardano/Api/TxBody.hs
@@ -182,8 +182,8 @@ import           Data.Type.Equality (TestEquality (..), (:~:) (Refl))
 import           Data.Word (Word16, Word32, Word64)
 import           GHC.Generics
 import           GHC.Records (HasField (..))
-import qualified Text.Parsec as Parsec
 import           Text.Parsec ((<?>))
+import qualified Text.Parsec as Parsec
 import qualified Text.Parsec.Language as Parsec
 import qualified Text.Parsec.String as Parsec
 import qualified Text.Parsec.Token as Parsec
@@ -234,16 +234,18 @@ import qualified Cardano.Ledger.Alonzo.Tx as Alonzo
 import qualified Cardano.Ledger.Alonzo.TxBody as Alonzo
 import qualified Cardano.Ledger.Alonzo.TxWitness as Alonzo
 
+import qualified Cardano.Ledger.Babbage as Babbage
+import qualified Cardano.Ledger.Babbage.PParams as Babbage
 import qualified Cardano.Ledger.Babbage.TxBody as Babbage
-import           Ouroboros.Consensus.Shelley.Eras (StandardAllegra, StandardAlonzo, StandardMary,
-                   StandardShelley)
+import           Ouroboros.Consensus.Shelley.Eras (StandardAllegra, StandardAlonzo, StandardBabbage,
+                   StandardMary, StandardShelley)
 
 import           Cardano.Api.Address
 import           Cardano.Api.Certificate
 import           Cardano.Api.Eras
 import           Cardano.Api.Error
-import           Cardano.Api.Hash
 import           Cardano.Api.HasTypeProxy
+import           Cardano.Api.Hash
 import           Cardano.Api.KeysByron
 import           Cardano.Api.KeysShelley
 import           Cardano.Api.NetworkId
@@ -3186,6 +3188,7 @@ makeShelleyTransactionBody era@ShelleyBasedEraBabbage
                              txFee,
                              txValidityRange = (lowerBound, upperBound),
                              txMetadata,
+                             txAuxScripts,
                              txExtraKeyWits,
                              txProtocolParams,
                              txWithdrawals,
@@ -3224,7 +3227,7 @@ makeShelleyTransactionBody era@ShelleyBasedEraBabbage
     case txProtocolParams of
       BuildTxWith Nothing | not (Set.null languages)
         -> Left TxBodyMissingProtocolParams
-      _ -> return () --TODO alonzo: validate protocol params for the Alonzo era.
+      _ -> return () --TODO alonzo: validate protocol params for the Babbage era.
                      --             All the necessary params must be provided.
 
     return $
@@ -3285,22 +3288,20 @@ makeShelleyTransactionBody era@ShelleyBasedEraBabbage
            , Babbage.scriptIntegrityHash =
                case txProtocolParams of
                  BuildTxWith Nothing        -> SNothing
-                 BuildTxWith (Just _pparams) ->
-                   error "Babbage scriptIntegrityHash - depends on consensus exposing a babbage era"
-                   -- Alonzo.hashScriptIntegrity
-                   --   (toLedgerPParams ShelleyBasedEraBabbage pparams)
-                   --   languages
-                   --   (error "Babbage redeemers - depends on consensus exposing a babbage era")
-                   --   (error "Babbage datums - depends on consensus exposing a babbage era")
-           , Babbage.adHash = error "Babbage txAuxData - depends on consensus exposing a babbage era"
-                 -- (maybeToStrictMaybe
-                 --                (Ledger.hashAuxiliaryData <$> (error "TODO: Babbage txAuxData")))
+                 BuildTxWith (Just pparams) ->
+                    Alonzo.hashScriptIntegrity
+                      (toLedgerPParams ShelleyBasedEraBabbage pparams)
+                      languages
+                      redeemers
+                      datums
+           , Babbage.adHash =
+                maybeToStrictMaybe (Ledger.hashAuxiliaryData <$> txAuxData)
            , Babbage.txnetworkid = SNothing
            })
-        (error "TODO: Babbage scripts - depends on consensus exposing a babbage era")
+        scripts
         (TxBodyScriptData ScriptDataInBabbageEra
-          (error "TODO: Babbage datums") (error "TODO: Babbage redeemers"))
-        (error "TODO: Babbage txAuxData")
+          datums redeemers)
+        txAuxData
         txScriptValidity
   where
     maxShelleyTxInIx :: Word
@@ -3309,39 +3310,37 @@ makeShelleyTransactionBody era@ShelleyBasedEraBabbage
     witnesses :: [(ScriptWitnessIndex, AnyScriptWitness BabbageEra)]
     witnesses = collectTxBodyScriptWitnesses txbodycontent
 
-    -- TODO: Babbage era - depends on consensus exposing a babbage era
-    -- scripts :: [Ledger.Script StandardBabbage]
-    -- scripts =
-    --   [ toShelleyScript (scriptWitnessScript scriptwitness)
-    --   | (_, AnyScriptWitness scriptwitness) <- witnesses
-    --   ]
-
-    -- TODO: Babbage era - depends on consensus exposing a babbage era
-    --datums :: Alonzo.TxDats StandardBabbage
-    --datums =
-    --  Alonzo.TxDats $
-    --    Map.fromList
-    --      [ (Alonzo.hashData d', d')
-    --      | d <- scriptdata
-    --      , let d' = toAlonzoData d
-    --      ]
-
-    _scriptdata :: [ScriptData]
-    _scriptdata =
+    scripts :: [Ledger.Script StandardBabbage]
+    scripts =
+      [ toShelleyScript (scriptWitnessScript scriptwitness)
+      | (_, AnyScriptWitness scriptwitness) <- witnesses
+      ]
+
+    -- Note these do not include inline datums!
+    datums :: Alonzo.TxDats StandardBabbage
+    datums =
+      Alonzo.TxDats $
+        Map.fromList
+          [ (Alonzo.hashData d', d')
+          | d <- scriptdata
+          , let d' = toAlonzoData d
+          ]
+
+    scriptdata :: [ScriptData]
+    scriptdata =
         [ d | TxOut _ _ (TxOutDatumInTx _ d) _ <- txOuts ]
      ++ [ d | (_, AnyScriptWitness
                     (PlutusScriptWitness
                        _ _ _ (ScriptDatumForTxIn d) _ _)) <- witnesses
             ]
-    -- TODO: Babbage era - depends on consensus exposing a babbage era
-    --redeemers :: Alonzo.Redeemers StandardBabbage
-    --redeemers =
-    --  Alonzo.Redeemers $
-    --    Map.fromList
-    --      [ (toAlonzoRdmrPtr idx, (toAlonzoData d, toAlonzoExUnits e))
-    --      | (idx, AnyScriptWitness
-    --                (PlutusScriptWitness _ _ _ _ d e)) <- witnesses
-    --      ]
+    redeemers :: Alonzo.Redeemers StandardBabbage
+    redeemers =
+      Alonzo.Redeemers $
+        Map.fromList
+          [ (toAlonzoRdmrPtr idx, (toAlonzoData d, toAlonzoExUnits e))
+          | (idx, AnyScriptWitness
+                    (PlutusScriptWitness _ _ _ _ d e)) <- witnesses
+          ]
 
     languages :: Set Alonzo.Language
     languages =
@@ -3350,19 +3349,18 @@ makeShelleyTransactionBody era@ShelleyBasedEraBabbage
         | (_, AnyScriptWitness (PlutusScriptWitness _ v _ _ _ _)) <- witnesses
         ]
 
-    -- TODO: Babbage era - depends on consensus exposing a babbage era
-    -- txAuxData :: Maybe (Ledger.AuxiliaryData StandardBabbage)
-    -- txAuxData
-    --   | Map.null ms
-    --   , null ss   = Nothing
-    --   | otherwise = Just (toAlonzoAuxiliaryData ms ss)
-    --   where
-    --     ms = case txMetadata of
-    --            TxMetadataNone                     -> Map.empty
-    --            TxMetadataInEra _ (TxMetadata ms') -> ms'
-    --     ss = case txAuxScripts of
-    --            TxAuxScriptsNone   -> []
-    --            TxAuxScripts _ ss' -> ss'
+    txAuxData :: Maybe (Ledger.AuxiliaryData StandardBabbage)
+    txAuxData
+      | Map.null ms
+      , null ss   = Nothing
+      | otherwise = Just (toAlonzoAuxiliaryData ms ss)
+      where
+        ms = case txMetadata of
+               TxMetadataNone                     -> Map.empty
+               TxMetadataInEra _ (TxMetadata ms') -> ms'
+        ss = case txAuxScripts of
+               TxAuxScriptsNone   -> []
+               TxAuxScripts _ ss' -> ss'
 
 
 -- | A variant of 'toShelleyTxOutAny that is used only internally to this module