Merge pull request #1334 from input-output-hk/lc/babbage-lenses

Replace Babbage-specific calls with lenses

hydra-cardano-api/src/Hydra/Cardano/Api.hs

@@ -286,7 +286,7 @@ pattern PlutusScriptWitness
   , plutusScriptWitnessExecutionUnits
   } <-
   Cardano.Api.PlutusScriptWitness
-    PlutusScriptV2InBabbage
+    _
     PlutusScriptV2
     (PScript plutusScriptWitnessScript)
     plutusScriptWitnessDatum
@@ -295,7 +295,7 @@ pattern PlutusScriptWitness
   where
     PlutusScriptWitness =
       Cardano.Api.PlutusScriptWitness
-        PlutusScriptV2InBabbage
+        scriptLanguageInEra
         PlutusScriptV2
         . PScript
 
@@ -335,7 +335,7 @@ pattern ShelleyTxBody
     txBodyScriptValidity
   where
     ShelleyTxBody =
-      Cardano.Api.Shelley.ShelleyTxBody ShelleyBasedEraBabbage
+      Cardano.Api.Shelley.ShelleyTxBody shelleyBasedEra
 
 signShelleyTransaction :: TxBody -> [ShelleyWitnessSigningKey] -> Tx
 signShelleyTransaction = Cardano.Api.signShelleyTransaction shelleyBasedEra
@@ -593,7 +593,7 @@ pattern TxOut :: AddressInEra -> Value -> TxOutDatum ctx -> ReferenceScript -> T
 pattern TxOut{txOutAddress, txOutValue, txOutDatum, txOutReferenceScript} <-
   Cardano.Api.TxOut
     txOutAddress
-    (TxOutValueShelleyBased ShelleyBasedEraBabbage (Extras.fromLedgerValue -> txOutValue))
+    (TxOutValueShelleyBased _ (Extras.fromLedgerValue -> txOutValue))
     txOutDatum
     txOutReferenceScript
   where
@@ -612,12 +612,12 @@ type ReferenceScript = Cardano.Api.Shelley.ReferenceScript Era
 pattern ReferenceScript :: ScriptInAnyLang -> ReferenceScript
 pattern ReferenceScript{referenceScript} <-
   Cardano.Api.Shelley.ReferenceScript
-    Cardano.Api.Shelley.BabbageEraOnwardsBabbage
+    _
     referenceScript
   where
     ReferenceScript =
       Cardano.Api.Shelley.ReferenceScript
-        Cardano.Api.Shelley.BabbageEraOnwardsBabbage
+        babbageEraOnwards
 
 pattern ReferenceScriptNone :: Cardano.Api.Shelley.ReferenceScript Era
 pattern ReferenceScriptNone <-
@@ -703,12 +703,18 @@ type TxValidityUpperBound = Cardano.Api.TxValidityUpperBound Era
 {-# COMPLETE TxValidityNoUpperBound, TxValidityUpperBound #-}
 
 pattern TxValidityNoUpperBound :: TxValidityUpperBound
-pattern TxValidityNoUpperBound =
-  Cardano.Api.TxValidityUpperBound ShelleyBasedEraBabbage Nothing
+pattern TxValidityNoUpperBound <-
+  Cardano.Api.TxValidityUpperBound _ Nothing
+  where
+    TxValidityNoUpperBound =
+      Cardano.Api.TxValidityUpperBound shelleyBasedEra Nothing
 
 pattern TxValidityUpperBound :: SlotNo -> TxValidityUpperBound
-pattern TxValidityUpperBound{upperBound} =
-  Cardano.Api.TxValidityUpperBound ShelleyBasedEraBabbage (Just upperBound)
+pattern TxValidityUpperBound{upperBound} <-
+  Cardano.Api.TxValidityUpperBound _ (Just upperBound)
+  where
+    TxValidityUpperBound =
+      Cardano.Api.TxValidityUpperBound shelleyBasedEra . Just
 
 -- ** Witness
 

hydra-cardano-api/src/Hydra/Cardano/Api/Prelude.hs

@@ -37,7 +37,6 @@ import Cardano.Api.Shelley hiding (
  )
 import Cardano.Api.UTxO (UTxO, UTxO' (..))
 import Cardano.Crypto.Hash.Class qualified as CC
-import Cardano.Ledger.Babbage qualified as Ledger
 import Cardano.Ledger.Binary qualified as Ledger
 import Cardano.Ledger.Core qualified as Ledger
 import Cardano.Ledger.Crypto (StandardCrypto)
@@ -57,7 +56,7 @@ import Test.QuickCheck (Arbitrary (..), Gen)
 type Era = BabbageEra
 
 -- | Currently supported ledger era.
-type LedgerEra = Ledger.BabbageEra StandardCrypto
+type LedgerEra = ShelleyLedgerEra Era
 
 type UsesStandardCrypto era = (EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto)
 

hydra-node/src/Hydra/Chain/Direct/Wallet.hs

@@ -37,12 +37,12 @@ import Cardano.Ledger.Api (
   outputsTxBodyL,
   ppMaxTxExUnitsL,
   rdmrsTxWitsL,
+  referenceInputsTxBodyL,
   scriptIntegrityHashTxBodyL,
   witsTxL,
  )
 import Cardano.Ledger.Babbage.Tx (body, getLanguageView, hashScriptIntegrity, wits)
 import Cardano.Ledger.Babbage.Tx qualified as Babbage
-import Cardano.Ledger.Babbage.TxBody (spendInputs')
 import Cardano.Ledger.Babbage.TxBody qualified as Babbage
 import Cardano.Ledger.Babbage.UTxO (getReferenceScripts)
 import Cardano.Ledger.BaseTypes qualified as Ledger
@@ -60,7 +60,7 @@ import Cardano.Slotting.EpochInfo (EpochInfo)
 import Cardano.Slotting.Time (SystemStart (..))
 import Control.Arrow (left)
 import Control.Concurrent.Class.MonadSTM (check, newTVarIO, readTVarIO, writeTVar)
-import Control.Lens ((%~), (.~), (^.))
+import Control.Lens (view, (%~), (.~), (^.))
 import Data.List qualified as List
 import Data.Map.Strict ((!))
 import Data.Map.Strict qualified as Map
@@ -214,7 +214,7 @@ applyTxs txs isOurs utxo =
       -- XXX: Use cardano-api types instead here
       let tx = toLedgerTx apiTx
       let txId = getTxId tx
-      modify (`Map.withoutKeys` spendInputs' (body tx))
+      modify (`Map.withoutKeys` view inputsTxBodyL (body tx))
       let indexedOutputs =
             let outs = toList $ body tx ^. outputsTxBodyL
                 maxIx = fromIntegral $ length outs
@@ -261,7 +261,7 @@ coverFee_ ::
 coverFee_ pparams systemStart epochInfo lookupUTxO walletUTxO partialTx@Babbage.AlonzoTx{body, wits} = do
   (feeTxIn, feeTxOut) <- findUTxOToPayFees walletUTxO
 
-  let newInputs = spendInputs' body <> Set.singleton feeTxIn
+  let newInputs = view inputsTxBodyL body <> Set.singleton feeTxIn
   resolvedInputs <- traverse resolveInput (toList newInputs)
 
   -- Ensure we have at least the minimum amount of ada. NOTE: setMinCoinTxOut
@@ -273,13 +273,13 @@ coverFee_ pparams systemStart epochInfo lookupUTxO walletUTxO partialTx@Babbage.
   estimatedScriptCosts <- estimateScriptsCost pparams systemStart epochInfo utxo partialTx
   let adjustedRedeemers =
         adjustRedeemers
-          (spendInputs' body)
+          (view inputsTxBodyL body)
           newInputs
           estimatedScriptCosts
           (txrdmrs wits)
 
   -- Compute script integrity hash from adjusted redeemers
-  let referenceScripts = getReferenceScripts @LedgerEra (Ledger.UTxO utxo) (Babbage.referenceInputs' body)
+  let referenceScripts = getReferenceScripts @LedgerEra (Ledger.UTxO utxo) (view referenceInputsTxBodyL body)
       langs =
         [ getLanguageView pparams l
         | (_hash, script) <- Map.toList $ Map.union (txscripts wits) referenceScripts

hydra-node/src/Hydra/Ledger/Cardano.hs

@@ -15,6 +15,7 @@ import Hydra.Ledger.Cardano.Builder
 import Cardano.Api.UTxO (fromPairs, pairs)
 import Cardano.Api.UTxO qualified as UTxO
 import Cardano.Crypto.DSIGN qualified as CC
+import Cardano.Ledger.Api (updateTxBodyL)
 import Cardano.Ledger.Babbage.Tx qualified as Ledger
 import Cardano.Ledger.BaseTypes (StrictMaybe (..))
 import Cardano.Ledger.BaseTypes qualified as Ledger
@@ -27,6 +28,7 @@ import Cardano.Ledger.Shelley.Rules qualified as Ledger
 import Cardano.Ledger.Shelley.UTxO qualified as Ledger
 import Codec.CBOR.Decoding qualified as CBOR
 import Codec.CBOR.Encoding qualified as CBOR
+import Control.Lens (set)
 import Control.Monad (foldM)
 import Data.Aeson (object, (.:), (.:?), (.=))
 import Data.Aeson qualified as Aeson
@@ -157,7 +159,7 @@ instance Arbitrary Tx where
   arbitrary = fromLedgerTx . withoutProtocolUpdates <$> arbitrary
    where
     withoutProtocolUpdates tx@(Ledger.AlonzoTx body _ _ _) =
-      let body' = body{Ledger.btbUpdate = SNothing}
+      let body' = body & set updateTxBodyL SNothing
        in tx{Ledger.body = body'}
 
 -- | Create a zero-fee, payment cardano transaction.

hydra-node/test/Hydra/Chain/Direct/Contract/Mutation.hs

@@ -133,15 +133,13 @@ import Hydra.Cardano.Api
 import Cardano.Api.UTxO qualified as UTxO
 import Cardano.Ledger.Alonzo.Scripts qualified as Ledger
 import Cardano.Ledger.Alonzo.TxWits qualified as Ledger
-import Cardano.Ledger.Api (AlonzoPlutusPurpose (..), AsIndex (..), outputsTxBodyL)
-import Cardano.Ledger.Babbage.TxBody qualified as Ledger
-import Cardano.Ledger.Binary (mkSized)
+import Cardano.Ledger.Api (AllegraEraTxBody (vldtTxBodyL), AlonzoPlutusPurpose (..), AsIndex (..), inputsTxBodyL, mintTxBodyL, outputsTxBodyL, reqSignerHashesTxBodyL)
 import Cardano.Ledger.Core qualified as Ledger
 import Cardano.Ledger.Credential (Credential (..))
 import Cardano.Ledger.Mary.Value qualified as Ledger
 import Cardano.Ledger.Plutus.Data qualified as Ledger
 import Control.Exception (assert)
-import Control.Lens ((^.))
+import Control.Lens (set, view, (.~), (^.))
 import Data.Map qualified as Map
 import Data.Sequence.Strict qualified as StrictSeq
 import Data.Set qualified as Set
@@ -342,7 +340,7 @@ applyMutation mutation (tx@(Tx body wits), utxo) = case mutation of
             Nothing -> error $ "txIn not resolvable: " <> show txIn
             Just o -> o
 
-    ledgerInputs = Ledger.btbInputs ledgerBody
+    ledgerInputs = view inputsTxBodyL ledgerBody
 
     ShelleyTxBody ledgerBody scripts scriptData mAuxData scriptValidity = body
   ChangeInputHeadDatum d' ->
@@ -429,7 +427,9 @@ applyMutation mutation (tx@(Tx body wits), utxo) = case mutation of
    where
     ShelleyTxBody ledgerBody scripts scriptData mAuxData scriptValidity = body
     valueToMultiAsset (Ledger.MaryValue _ multiAsset) = multiAsset
-    ledgerBody' = ledgerBody{Ledger.btbMint = valueToMultiAsset $ toLedgerValue v'}
+    ledgerBody' =
+      ledgerBody
+        & set mintTxBodyL (valueToMultiAsset $ toLedgerValue v')
     body' = ShelleyTxBody ledgerBody' scripts scriptData' mAuxData scriptValidity
     -- Drop all Mint redeemer pointers when we don't mint/burn anymore
     scriptData' =
@@ -453,8 +453,7 @@ applyMutation mutation (tx@(Tx body wits), utxo) = case mutation of
     body' = ShelleyTxBody ledgerBody' scripts scriptData mAuxData scriptValidity
     ledgerBody' =
       ledgerBody
-        { Ledger.btbReqSignerHashes = Set.fromList (toLedgerKeyHash <$> newSigners)
-        }
+        & set reqSignerHashesTxBodyL (Set.fromList (toLedgerKeyHash <$> newSigners))
   ChangeValidityInterval (lowerBound, upperBound) ->
     changeValidityInterval (Just lowerBound) (Just upperBound)
   ChangeValidityLowerBound bound ->
@@ -474,10 +473,11 @@ applyMutation mutation (tx@(Tx body wits), utxo) = case mutation of
 
     ledgerBody' =
       ledgerBody
-        { Ledger.btbMint =
-            valueToMultiAsset . toLedgerValue $
+        & set
+          mintTxBodyL
+          ( valueToMultiAsset . toLedgerValue $
               replacePolicyInValue selectedPid mutatedPid mint
-        }
+          )
 
     selectedPid =
       fromMaybe (error "cannot mutate non minting transaction")
@@ -488,7 +488,7 @@ applyMutation mutation (tx@(Tx body wits), utxo) = case mutation of
           )
         $ valueToList mint
 
-    mint = fromLedgerMultiAsset $ Ledger.btbMint ledgerBody
+    mint = fromLedgerMultiAsset $ view mintTxBodyL ledgerBody
 
     scripts' =
       map
@@ -510,14 +510,13 @@ applyMutation mutation (tx@(Tx body wits), utxo) = case mutation of
     body' = ShelleyTxBody ledgerBody' scripts scriptData mAuxData scriptValidity
     ledgerBody' =
       ledgerBody
-        { Ledger.btbValidityInterval =
-            toLedgerValidityInterval
-              ( fromMaybe lowerBound lowerBound'
-              , fromMaybe upperBound upperBound'
-              )
-        }
+        & vldtTxBodyL
+          .~ toLedgerValidityInterval
+            ( fromMaybe lowerBound lowerBound'
+            , fromMaybe upperBound upperBound'
+            )
     (lowerBound, upperBound) = fromLedgerValidityInterval ledgerValidityInterval
-    ledgerValidityInterval = Ledger.btbValidityInterval ledgerBody
+    ledgerValidityInterval = ledgerBody ^. vldtTxBodyL
 
 -- * Orphans
 
@@ -620,7 +619,7 @@ alterTxIns fn tx =
  where
   body' = ShelleyTxBody ledgerBody' scripts scriptData' mAuxData scriptValidity
 
-  ledgerBody' = ledgerBody{Ledger.btbInputs = inputs'}
+  ledgerBody' = ledgerBody & set inputsTxBodyL inputs'
 
   inputs' = Set.fromList $ toLedgerTxIn . fst <$> newSortedInputs
 
@@ -650,7 +649,7 @@ alterTxIns fn tx =
         . resolveRedeemers
         . fmap fromLedgerTxIn
         . toList
-      $ Ledger.btbInputs ledgerBody
+      $ view inputsTxBodyL ledgerBody
 
   resolveRedeemers :: [TxIn] -> [(TxIn, Maybe HashableScriptData)]
   resolveRedeemers txInputs =
@@ -676,9 +675,9 @@ alterTxOuts fn tx =
   Tx body' wits
  where
   body' = ShelleyTxBody ledgerBody' scripts scriptData' mAuxData scriptValidity
-  ledgerBody' = ledgerBody{Ledger.btbOutputs = ledgerOutputs'}
+  ledgerBody' = ledgerBody & outputsTxBodyL .~ ledgerOutputs'
 
-  ledgerOutputs' = StrictSeq.fromList . map (mkSized ledgerEraVersion . toLedgerTxOut . toCtxUTxOTxOut) $ outputs'
+  ledgerOutputs' = StrictSeq.fromList . map (toLedgerTxOut . toCtxUTxOTxOut) $ outputs'
 
   outputs' = fn . fmap fromLedgerTxOut . toList $ ledgerBody ^. outputsTxBodyL
 

hydra-node/test/Hydra/Chain/Direct/WalletSpec.hs

@@ -5,18 +5,17 @@ module Hydra.Chain.Direct.WalletSpec where
 import Hydra.Prelude
 import Test.Hydra.Prelude
 
-import Cardano.Ledger.Api (EraTx (getMinFeeTx), EraTxBody (feeTxBodyL), PParams, bodyTxL, coinTxOutL, outputsTxBodyL)
+import Cardano.Ledger.Api (EraTx (getMinFeeTx), EraTxBody (feeTxBodyL, inputsTxBodyL), PParams, bodyTxL, coinTxOutL, outputsTxBodyL)
 import Cardano.Ledger.Babbage.Tx (AlonzoTx (..))
 import Cardano.Ledger.Babbage.TxBody (BabbageTxBody (..), BabbageTxOut (..))
 import Cardano.Ledger.BaseTypes qualified as Ledger
-import Cardano.Ledger.Binary (mkSized)
 import Cardano.Ledger.Coin (Coin (..))
 import Cardano.Ledger.Core (Tx, Value)
 import Cardano.Ledger.SafeHash qualified as SafeHash
 import Cardano.Ledger.Shelley.API qualified as Ledger
 import Cardano.Ledger.Val (Val (..), invert)
 import Control.Concurrent (newEmptyMVar, putMVar, takeMVar)
-import Control.Lens (view, (.~), (<>~), (^.))
+import Control.Lens (set, view, (.~), (<>~), (^.))
 import Control.Tracer (nullTracer)
 import Data.Map.Strict qualified as Map
 import Data.Sequence.Strict qualified as StrictSeq
@@ -33,7 +32,6 @@ import Hydra.Cardano.Api (
   fromLedgerTxOut,
   fromLedgerUTxO,
   genTxIn,
-  ledgerEraVersion,
   selectLovelace,
   toLedgerTxIn,
   toLedgerUTxO,
@@ -268,7 +266,7 @@ isBalanced utxo originalTx balancedTx =
   let inp' = knownInputBalance utxo balancedTx
       out' = outputBalance balancedTx
       out = outputBalance originalTx
-      fee = (btbTxFee . body) balancedTx
+      fee = (view feeTxBodyL . body) balancedTx
    in coin (deltaValue out' inp') == fee
         & counterexample ("Fee:             " <> show fee)
         & counterexample ("Delta value:     " <> show (coin $ deltaValue out' inp'))
@@ -344,9 +342,8 @@ genTxsSpending utxo = scale (round @Double . sqrt . fromIntegral) $ do
     (input, output) <- gets Map.findMax
     let body =
           base
-            { btbInputs = Set.singleton input
-            , btbOutputs = StrictSeq.fromList [mkSized ledgerEraVersion output]
-            }
+            & inputsTxBodyL .~ Set.singleton input
+            & outputsTxBodyL .~ StrictSeq.singleton output
     let input' = Ledger.TxIn (Ledger.TxId $ SafeHash.hashAnnotated body) (Ledger.TxIx 0)
     modify (\m -> m & Map.delete input & Map.insert input' output)
     pure body
@@ -365,14 +362,14 @@ genUTxO = do
 
 genOutputsForInputs :: Tx LedgerEra -> Gen (Map TxIn TxOut)
 genOutputsForInputs AlonzoTx{body} = do
-  let n = Set.size (btbInputs body)
+  let n = Set.size (view inputsTxBodyL body)
   outs <- vectorOf n arbitrary
-  pure $ Map.fromList $ zip (toList (btbInputs body)) outs
+  pure $ Map.fromList $ zip (toList (view inputsTxBodyL body)) outs
 
 genLedgerTx :: Gen (Tx LedgerEra)
 genLedgerTx = do
   tx <- arbitrary
-  body <- (\x -> x{btbTxFee = Coin 0}) <$> arbitrary
+  body <- (\x -> x & set feeTxBodyL (Coin 0)) <$> arbitrary
   pure $ tx{body, wits = mempty}
 
 --
@@ -381,7 +378,7 @@ genLedgerTx = do
 
 allTxIns :: [Tx LedgerEra] -> Set TxIn
 allTxIns txs =
-  Set.unions (btbInputs . body <$> txs)
+  Set.unions (view inputsTxBodyL . body <$> txs)
 
 allTxOuts :: [Tx LedgerEra] -> [TxOut]
 allTxOuts txs =
@@ -413,7 +410,7 @@ deltaValue a b
 
 -- | NOTE: This does not account for withdrawals
 knownInputBalance :: Map TxIn TxOut -> Tx LedgerEra -> Value LedgerEra
-knownInputBalance utxo = foldMap resolve . toList . btbInputs . body
+knownInputBalance utxo = foldMap resolve . toList . view inputsTxBodyL . body
  where
   resolve :: TxIn -> Value LedgerEra
   resolve k = maybe zero getValue (Map.lookup k utxo)