Merge remote-tracking branch 'upstream/master'

cardano-chain-gen/cardano-chain-gen.cabal

@@ -152,6 +152,7 @@ test-suite cardano-chain-gen
                         Test.Cardano.Db.Mock.Unit.Conway.CommandLineArg.ForceIndex
                         Test.Cardano.Db.Mock.Unit.Conway.CommandLineArg.MigrateConsumedPruneTxOut
                         Test.Cardano.Db.Mock.Unit.Conway.Config
+                        Test.Cardano.Db.Mock.Unit.Conway.InlineAndReference
                         Test.Cardano.Db.Mock.Unit.Conway.Other
                         Test.Cardano.Db.Mock.Unit.Conway.Plutus
                         Test.Cardano.Db.Mock.Unit.Conway.Reward

cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Alonzo.hs

@@ -198,9 +198,14 @@ mkUnlockScriptTx inputIndex colInputIndex outputIndex succeeds amount fees sta =
   Right
     $ mkScriptTx
       succeeds
-      (mapMaybe mkScriptInp $ zip [0 ..] inputPairs)
+      (mapMaybe mkScriptInp' $ zip [0 ..] inputPairs)
     $ consPaymentTxBody inpts colInput (StrictSeq.fromList [output]) (Coin fees) mempty
 
+mkScriptInp' ::
+  (Word64, (TxIn StandardCrypto, Core.TxOut StandardAlonzo)) ->
+  Maybe (RdmrPtr, Maybe (ScriptHash StandardCrypto, Core.Script StandardAlonzo))
+mkScriptInp' = map (second Just) . mkScriptInp
+
 mkScriptInp ::
   (Word64, (TxIn StandardCrypto, Core.TxOut StandardAlonzo)) ->
   Maybe (RdmrPtr, (ScriptHash StandardCrypto, Core.Script StandardAlonzo))
@@ -219,17 +224,17 @@ mkScriptInp (n, (_txIn, txOut))
 
 mkScriptMint ::
   MultiAsset StandardCrypto ->
-  [(RdmrPtr, (ScriptHash StandardCrypto, Core.Script StandardAlonzo))]
+  [(RdmrPtr, Maybe (ScriptHash StandardCrypto, Core.Script StandardAlonzo))]
 mkScriptMint (MultiAsset mp) = mapMaybe f $ zip [0 ..] (Map.keys mp)
   where
     f (n, policyId)
       | policyID policyId == alwaysFailsScriptHash =
-          Just (RdmrPtr Mint n, (alwaysFailsScriptHash, alwaysFailsScript))
+          Just (RdmrPtr Mint n, Just (alwaysFailsScriptHash, alwaysFailsScript))
       | policyID policyId == alwaysSucceedsScriptHash =
           Just
-            (RdmrPtr Mint n, (alwaysSucceedsScriptHash, alwaysSucceedsScript))
+            (RdmrPtr Mint n, Just (alwaysSucceedsScriptHash, alwaysSucceedsScript))
       | policyID policyId == alwaysMintScriptHash =
-          Just (RdmrPtr Mint n, (alwaysMintScriptHash, alwaysMintScript))
+          Just (RdmrPtr Mint n, Just (alwaysMintScriptHash, alwaysMintScript))
       | otherwise = Nothing
 
 mkMAssetsScriptTx ::
@@ -250,7 +255,7 @@ mkMAssetsScriptTx inputIndex colInputIndex outputIndex minted succeeds fees sta
   Right
     $ mkScriptTx
       succeeds
-      ( mapMaybe mkScriptInp (zip [0 ..] inputPairs)
+      ( mapMaybe mkScriptInp' (zip [0 ..] inputPairs)
           ++ mkScriptMint minted
       )
     $ consPaymentTxBody inpts colInput (StrictSeq.fromList outps) (Coin fees) minted
@@ -300,7 +305,7 @@ mkScriptDCertTx consDert valid st = do
     cred <- resolveStakeCreds stakeIndex st
     pure $ mkDCert cred
   Right $
-    mkScriptTx valid (mapMaybe prepareRedeemer $ zip [0 ..] consDert) $
+    mkScriptTx valid (mapMaybe (map (second Just) . prepareRedeemer) $ zip [0 ..] consDert) $
       consCertTxBody dcerts (Withdrawals mempty)
   where
     prepareRedeemer (n, (StakeIndexScript bl, addRedeemer, _)) =
@@ -356,7 +361,7 @@ mkScriptTx ::
   , Core.TxWits era ~ AlonzoTxWits era
   ) =>
   Bool ->
-  [(RdmrPtr, (ScriptHash StandardCrypto, Core.Script era))] ->
+  [(RdmrPtr, Maybe (ScriptHash StandardCrypto, Core.Script era))] ->
   Core.TxBody era ->
   AlonzoTx era
 mkScriptTx valid rdmrs txBody =
@@ -369,7 +374,7 @@ mkScriptTx valid rdmrs txBody =
   where
     witnesses =
       mkWitnesses
-        (map (second Just) rdmrs)
+        rdmrs
         [(hashData @era plutusDataList, plutusDataList)]
 
 mkWitnesses ::

cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Babbage.hs

@@ -480,7 +480,10 @@ mkScriptTx valid rdmrs txBody =
 mkUTxOBabbage :: AlonzoTx StandardBabbage -> [(TxIn StandardCrypto, BabbageTxOut StandardBabbage)]
 mkUTxOBabbage = mkUTxOAlonzo
 
-mkUTxOCollBabbage :: AlonzoTx StandardBabbage -> [(TxIn StandardCrypto, BabbageTxOut StandardBabbage)]
+mkUTxOCollBabbage ::
+  (BabbageEraTxBody era) =>
+  AlonzoTx era ->
+  [(TxIn (EraCrypto era), TxOut era)]
 mkUTxOCollBabbage tx = Map.toList $ unUTxO $ collOuts $ getField @"body" tx
 
 emptyTxBody :: BabbageTxBody StandardBabbage

cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Conway.hs

@@ -7,16 +7,21 @@
 
 module Cardano.Mock.Forging.Tx.Conway (
   Babbage.TxOutScriptType (..),
+  Babbage.DatumType (..),
+  Babbage.ReferenceScript (..),
   consTxBody,
   consCertTxBody,
   consPoolParams,
+  consTxCertPool,
   mkPaymentTx,
   mkPaymentTx',
   mkLockByScriptTx,
   mkUnlockScriptTx,
+  mkUnlockScriptTxBabbage,
   mkScriptTx,
   mkSimpleTx,
   mkDCertTx,
+  mkDCertPoolTx,
   mkDCertTxPools,
   mkSimpleDCertTx,
   mkScriptDCertTx,
@@ -32,6 +37,7 @@ module Cardano.Mock.Forging.Tx.Conway (
   Babbage.mkScriptInp,
   mkWitnesses,
   mkUTxOConway,
+  mkUTxOCollConway,
   addValidityInterval,
 ) where
 
@@ -52,7 +58,7 @@ import Cardano.Ledger.Conway.TxOut (BabbageTxOut (..))
 import qualified Cardano.Ledger.Core as Core
 import Cardano.Ledger.Credential (Credential (..), StakeCredential, StakeReference (..))
 import Cardano.Ledger.Crypto (ADDRHASH ())
-import Cardano.Ledger.Keys (KeyHash (..))
+import Cardano.Ledger.Keys (KeyHash (..), KeyRole (..))
 import Cardano.Ledger.Mary.Value (MaryValue (..), MultiAsset (..), PolicyID (..), valueFromList)
 import Cardano.Ledger.Plutus.Data
 import Cardano.Ledger.Plutus.Language (Language (..))
@@ -132,6 +138,21 @@ consCertTxBody ref = consTxBody mempty mempty (toSet ref) mempty SNothing (Coin
     toSet Nothing = mempty
     toSet (Just a) = Set.singleton a
 
+consTxCertPool ::
+  [StakeCredential StandardCrypto] ->
+  KeyHash 'StakePool StandardCrypto ->
+  ConwayTxCert StandardConway
+consTxCertPool [] _ = panic "Expected at least 1 pool owner"
+consTxCertPool (rwCred : poolOwners) poolId =
+  ConwayTxCertPool
+    . Core.RegPool
+    . consPoolParams poolId rwCred
+    . map unKeyHashObj
+    $ poolOwners
+  where
+    unKeyHashObj (KeyHashObj owner) = owner
+    unKeyHashObj _ = panic "Expected a KeyHashObj"
+
 mkPaymentTx ::
   ConwayUTxOIndex ->
   ConwayUTxOIndex ->
@@ -218,30 +239,37 @@ mkUnlockScriptTx ::
   Integer ->
   ConwayLedgerState ->
   Either ForgingError (AlonzoTx StandardConway)
-mkUnlockScriptTx inputIndex colInputIndex outputIndex succeeds amount fees state' = do
-  inputPairs <- map fst <$> mapM (`resolveUTxOIndex` state') inputIndex
-  (colInputPair, _) <- resolveUTxOIndex colInputIndex state'
-  addr <- resolveAddress outputIndex state'
+mkUnlockScriptTx inputIndex colInputIndex outputIndex =
+  mkUnlockScriptTx' inputIndex colInputIndex outputIndex mempty Nothing
 
-  let inputs = Set.fromList $ map fst inputPairs
-      colInputs = Set.singleton $ fst colInputPair
-      output =
-        BabbageTxOut
-          addr
-          (valueFromList (Coin amount) [])
-          NoDatum
-          SNothing
-
-  pure $
-    mkScriptTx succeeds (mkScriptInps inputPairs) $
-      consPaymentTxBody
-        inputs
-        colInputs
-        mempty
-        (StrictSeq.singleton output)
-        SNothing
-        (Coin fees)
-        mempty
+mkUnlockScriptTxBabbage ::
+  [ConwayUTxOIndex] ->
+  ConwayUTxOIndex ->
+  ConwayUTxOIndex ->
+  [ConwayUTxOIndex] ->
+  Bool ->
+  Bool ->
+  Integer ->
+  Integer ->
+  ConwayLedgerState ->
+  Either ForgingError (AlonzoTx StandardConway)
+mkUnlockScriptTxBabbage inputIndex colInputIndex outputIndex refInput compl succeeds amount fees state' = do
+  let colTxOutType =
+        if compl
+          then Just $ Babbage.TxOutInline True Babbage.InlineDatum (Babbage.ReferenceScript True)
+          else Just $ Babbage.TxOutNoInline True
+      colOutput = mkOutFromType amount <$> colTxOutType
+
+  mkUnlockScriptTx'
+    inputIndex
+    colInputIndex
+    outputIndex
+    refInput
+    colOutput
+    succeeds
+    amount
+    fees
+    state'
 
 mkDCertTx ::
   [ConwayTxCert StandardConway] ->
@@ -250,6 +278,24 @@ mkDCertTx ::
   Either ForgingError (AlonzoTx StandardConway)
 mkDCertTx certs wdrl ref = Right (mkSimpleTx True $ consCertTxBody ref certs wdrl)
 
+mkDCertPoolTx ::
+  [ ( [StakeIndex]
+    , PoolIndex
+    , [StakeCredential StandardCrypto] ->
+      KeyHash 'StakePool StandardCrypto ->
+      ConwayTxCert StandardConway
+    )
+  ] ->
+  ConwayLedgerState ->
+  Either ForgingError (AlonzoTx StandardConway)
+mkDCertPoolTx consDCert state' = do
+  dcerts <- forM consDCert $ \(stakeIxs, poolIx, mkDCert) -> do
+    stakeCreds <- forM stakeIxs $ \stakeIx -> resolveStakeCreds stakeIx state'
+    let poolId = resolvePool poolIx state'
+    pure $ mkDCert stakeCreds poolId
+
+  mkDCertTx dcerts (Withdrawals mempty) Nothing
+
 mkDCertTxPools :: ConwayLedgerState -> Either ForgingError (AlonzoTx StandardConway)
 mkDCertTxPools state' =
   Right $
@@ -297,7 +343,7 @@ mkScriptDCertTx consCert isValid' state' = do
           mkRedeemer n (alwaysSucceedsScriptHash, alwaysSucceedsScript)
     prepareRedeemer _ = Nothing
 
-    mkRedeemer n (a, b) = Just (RdmrPtr Cert n, (a, b))
+    mkRedeemer n (a, b) = Just (RdmrPtr Cert n, Just (a, b))
 
 mkMultiAssetsScriptTx ::
   [ConwayUTxOIndex] ->
@@ -554,17 +600,17 @@ mkFullTx n m state' = do
 
 mkScriptMint ::
   MultiAsset StandardCrypto ->
-  [(RdmrPtr, (Core.ScriptHash StandardCrypto, Core.Script StandardConway))]
+  [(RdmrPtr, Maybe (Core.ScriptHash StandardCrypto, Core.Script StandardConway))]
 mkScriptMint (MultiAsset m) =
   mapMaybe mkMint . zip [0 ..] . map policyID $ Map.keys m
   where
     mkMint (n, policyId)
       | policyId == alwaysFailsScriptHash =
-          Just (RdmrPtr Mint n, alwaysFails)
+          Just (RdmrPtr Mint n, Just alwaysFails)
       | policyId == alwaysSucceedsScriptHash =
-          Just (RdmrPtr Mint n, alwaysSucceeds)
+          Just (RdmrPtr Mint n, Just alwaysSucceeds)
       | policyId == alwaysMintScriptHash =
-          Just (RdmrPtr Mint n, alwaysMint)
+          Just (RdmrPtr Mint n, Just alwaysMint)
       | otherwise = Nothing
 
     alwaysFails = (alwaysFailsScriptHash, alwaysFailsScript)
@@ -588,6 +634,11 @@ mkUTxOConway ::
   [(TxIn StandardCrypto, BabbageTxOut StandardConway)]
 mkUTxOConway = mkUTxOAlonzo
 
+mkUTxOCollConway ::
+  AlonzoTx StandardConway ->
+  [(TxIn StandardCrypto, BabbageTxOut StandardConway)]
+mkUTxOCollConway = Babbage.mkUTxOCollBabbage
+
 mkOutFromType ::
   Integer ->
   Babbage.TxOutScriptType ->
@@ -610,18 +661,48 @@ mkOutFromType amount txOutType =
       SJust True -> SJust alwaysSucceedsScript
       SJust False -> SJust alwaysFailsScript
 
--- | Takes a nested Monad of the form Monad (_, Monad), and combines them into one
--- outer monad
-joinSnd :: Monad m => m (a, m b) -> m (a, b)
-joinSnd m = do
-  (a, m') <- m
-  b <- m'
-  pure (a, b)
-
 mkScriptInps ::
   [(TxIn StandardCrypto, Core.TxOut StandardConway)] ->
-  [(RdmrPtr, (Core.ScriptHash StandardCrypto, Core.Script StandardConway))]
-mkScriptInps = mapMaybe joinSnd . map Babbage.mkScriptInp . zip [0 ..]
+  [(RdmrPtr, Maybe (Core.ScriptHash StandardCrypto, Core.Script StandardConway))]
+mkScriptInps = mapMaybe Babbage.mkScriptInp . zip [0 ..]
+
+mkUnlockScriptTx' ::
+  [ConwayUTxOIndex] ->
+  ConwayUTxOIndex ->
+  ConwayUTxOIndex ->
+  [ConwayUTxOIndex] ->
+  Maybe (BabbageTxOut StandardConway) ->
+  Bool ->
+  Integer ->
+  Integer ->
+  ConwayLedgerState ->
+  Either ForgingError (AlonzoTx StandardConway)
+mkUnlockScriptTx' inputIndex colInputIndex outputIndex refInput colOut succeeds amount fees state' = do
+  inputPairs <- map fst <$> mapM (`resolveUTxOIndex` state') inputIndex
+  refInputPairs <- map fst <$> mapM (`resolveUTxOIndex` state') refInput
+  (colInputPair, _) <- resolveUTxOIndex colInputIndex state'
+  addr <- resolveAddress outputIndex state'
+
+  let inputs = Set.fromList $ map fst inputPairs
+      colInputs = Set.singleton $ fst colInputPair
+      refInputs = Set.fromList $ map fst refInputPairs
+      output =
+        BabbageTxOut
+          addr
+          (valueFromList (Coin amount) [])
+          NoDatum
+          SNothing
+
+  pure $
+    mkScriptTx succeeds (mkScriptInps inputPairs) $
+      consPaymentTxBody
+        inputs
+        colInputs
+        refInputs
+        (StrictSeq.singleton output)
+        (maybeToStrictMaybe colOut)
+        (Coin fees)
+        mempty
 
 allPoolStakeCert' :: ConwayLedgerState -> [ConwayTxCert StandardConway]
 allPoolStakeCert' st = map (mkRegTxCert SNothing) (getCreds st)

cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway.hs

@@ -7,6 +7,7 @@ import qualified Test.Cardano.Db.Mock.Unit.Conway.CommandLineArg.EpochDisabled a
 import qualified Test.Cardano.Db.Mock.Unit.Conway.CommandLineArg.ForceIndex as ForceIndex
 import qualified Test.Cardano.Db.Mock.Unit.Conway.CommandLineArg.MigrateConsumedPruneTxOut as MigrateConsumedPruneTxOut
 import qualified Test.Cardano.Db.Mock.Unit.Conway.Config as ConConfig
+import qualified Test.Cardano.Db.Mock.Unit.Conway.InlineAndReference as InlineRef
 import qualified Test.Cardano.Db.Mock.Unit.Conway.Other as Other
 import qualified Test.Cardano.Db.Mock.Unit.Conway.Plutus as Plutus
 import qualified Test.Cardano.Db.Mock.Unit.Conway.Reward as Reward
@@ -163,6 +164,45 @@ unitTests iom knownMigrations =
         , test "mint many multi assets" Plutus.mintMultiAssets
         , test "swap many multi assets" Plutus.swapMultiAssets
         ]
+    , testGroup
+        "Pools and smash"
+        [ test "pool registration" Other.poolReg
+        , test "query pool that's not registered" Other.nonexistentPoolQuery
+        , test "pool deregistration" Other.poolDeReg
+        , test "multiple deregistration" Other.poolDeRegMany
+        , test "delist pool" Other.poolDelist
+        ]
+    , testGroup
+        "Inline and reference"
+        [ test "spend inline datum" InlineRef.unlockDatumOutput
+        , test "spend inline datum same block" InlineRef.unlockDatumOutputSameBlock
+        , test "inline datum with noncanonical CBOR" InlineRef.inlineDatumCBOR
+        , test "spend reference script" InlineRef.spendRefScript
+        , test "spend reference script same block" InlineRef.spendRefScriptSameBlock
+        , test "spend collateral output of invalid tx" InlineRef.spendCollateralOutput
+        , test
+            "spend collateral output of invalid tx rollback"
+            InlineRef.spendCollateralOutputRollback
+        , test
+            "spend collateral output of invalid tx same block"
+            InlineRef.spendCollateralOutputSameBlock
+        , test
+            "reference input to output which is not spent"
+            InlineRef.referenceInputUnspend
+        , test
+            "supply and run script which is both reference and in witnesses"
+            InlineRef.supplyScriptsTwoWays
+        , test
+            "supply and run script which is both reference and in witnesses same block"
+            InlineRef.supplyScriptsTwoWaysSameBlock
+        , test "reference script as minting" InlineRef.referenceMintingScript
+        , test "reference script as delegation" InlineRef.referenceDelegation
+        ]
+    , testGroup
+        "Hard Fork"
+        [ test "fork from Babbage to Conway fixed epoch" Other.forkFixedEpoch
+        , test "fork from Babbage to Conway and rollback" Other.rollbackFork
+        ]
     ]
   where
     test :: String -> (IOManager -> [(Text, Text)] -> Assertion) -> TestTree