Fix incorrect handling of timelocks in impAllegraSatisfyNativeScript

IntersectMBO · Nov 18, 2024 · 521f1c4 · 521f1c4
1 parent 26fab88
commit 521f1c4
Show file tree

Hide file tree

Showing 2 changed files with 17 additions and 10 deletions.
diff --git a/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/ImpTest.hs b/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/ImpTest.hs
@@ -19,6 +19,7 @@ import Cardano.Ledger.Allegra (AllegraEra)
 import Cardano.Ledger.Allegra.Core
 import Cardano.Ledger.Allegra.Scripts (
   AllegraEraScript,
+  evalTimelock,
   pattern RequireTimeExpire,
   pattern RequireTimeStart,
  )
@@ -55,15 +56,18 @@ instance
   fixupTx = shelleyFixupTx
 
 impAllegraSatisfyNativeScript ::
-  AllegraEraScript era =>
+  ( AllegraEraScript era
+  , AllegraEraTxBody era
+  ) =>
   Set.Set (KeyHash 'Witness (EraCrypto era)) ->
+  TxBody era ->
   NativeScript era ->
   ImpTestM era (Maybe (Map.Map (KeyHash 'Witness (EraCrypto era)) (KeyPair 'Witness (EraCrypto era))))
-impAllegraSatisfyNativeScript providedVKeyHashes script = do
+impAllegraSatisfyNativeScript providedVKeyHashes txBody script = do
   impState <- get
   let
     keyPairs = impState ^. impKeyPairsG
-    prevSlotNo = impState ^. impLastTickG
+    vi = txBody ^. vldtTxBodyL
     satisfyMOf m Empty
       | m <= 0 = Just mempty
       | otherwise = Nothing
@@ -82,10 +86,10 @@ impAllegraSatisfyNativeScript providedVKeyHashes script = do
       RequireAllOf ss -> satisfyMOf (length ss) ss
       RequireAnyOf ss -> satisfyMOf 1 ss
       RequireMOf m ss -> satisfyMOf m ss
-      RequireTimeExpire slotNo
-        | slotNo < prevSlotNo -> Just mempty
+      lock@(RequireTimeStart _)
+        | evalTimelock mempty vi lock -> Just mempty
         | otherwise -> Nothing
-      RequireTimeStart slotNo
-        | slotNo > prevSlotNo -> Just mempty
+      lock@(RequireTimeExpire _)
+        | evalTimelock mempty vi lock -> Just mempty
         | otherwise -> Nothing
   pure $ satisfyScript script
diff --git a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs
@@ -512,6 +512,8 @@ class
   impSatisfyNativeScript ::
     -- | Set of Witnesses that have already been satisfied
     Set.Set (KeyHash 'Witness (EraCrypto era)) ->
+    -- | The transaction body that the script will be applied to
+    TxBody era ->
     NativeScript era ->
     ImpTestM era (Maybe (Map (KeyHash 'Witness (EraCrypto era)) (KeyPair 'Witness (EraCrypto era))))
 
@@ -714,7 +716,7 @@ instance
         startEpochNo = impEraStartEpochNo @(ShelleyEra c)
     pure $ translateToShelleyLedgerStateFromUtxo transContext startEpochNo Byron.empty
 
-  impSatisfyNativeScript providedVKeyHashes script = do
+  impSatisfyNativeScript providedVKeyHashes _txBody script = do
     keyPairs <- gets impKeyPairs
     let
       satisfyMOf m Empty
@@ -863,7 +865,8 @@ updateAddrTxWits tx = impAnn "updateAddrTxWits" $ do
       addrWitHashes = curAddrWitHashes <> Set.map witVKeyHash extraAddrVKeyWits
   -- Shelley Based Native Script Witnesses
   scriptsRequired <- impNativeScriptsRequired tx
-  nativeScriptsKeyPairs <- mapM (impSatisfyNativeScript addrWitHashes) (Map.elems scriptsRequired)
+  nativeScriptsKeyPairs <-
+    mapM (impSatisfyNativeScript addrWitHashes txBody) (Map.elems scriptsRequired)
   let extraNativeScriptVKeyWits =
         mkWitnessesVKey txBodyHash $ Map.elems (mconcat (catMaybes nativeScriptsKeyPairs))
   -- Byron Based Witessed
@@ -903,7 +906,7 @@ impNativeScriptKeyPairs tx = do
   scriptsRequired <- impNativeScriptsRequired tx
   let nativeScripts = Map.elems scriptsRequired
       curAddrWits = Set.map witVKeyHash $ tx ^. witsTxL . addrTxWitsL
-  keyPairs <- mapM (impSatisfyNativeScript curAddrWits) nativeScripts
+  keyPairs <- mapM (impSatisfyNativeScript curAddrWits $ tx ^. bodyTxL) nativeScripts
   pure . mconcat $ catMaybes keyPairs
 
 fixupTxOuts :: (ShelleyEraImp era, HasCallStack) => Tx era -> ImpTestM era (Tx era)