Merge pull request #2451 from input-output-hk/nc/lobster

At PV6, translate time for Plutus correctly.

alonzo/impl/src/Cardano/Ledger/Alonzo/PlutusScriptApi.hs

@@ -24,6 +24,7 @@ where
 import Cardano.Binary (FromCBOR (..), ToCBOR (..))
 import Cardano.Ledger.Alonzo.Data (getPlutusData)
 import Cardano.Ledger.Alonzo.Language (Language (..))
+import Cardano.Ledger.Alonzo.PParams (ProtVer)
 import Cardano.Ledger.Alonzo.Scripts (CostModel, ExUnits (..))
 import qualified Cardano.Ledger.Alonzo.Scripts as AlonzoScript (Script (..))
 import Cardano.Ledger.Alonzo.Tx
@@ -152,6 +153,7 @@ collectTwoPhaseScriptInputs ::
     Core.Value era ~ Mary.Value (Crypto era),
     HasField "datahash" (Core.TxOut era) (StrictMaybe (DataHash (Crypto era))),
     HasField "_costmdls" (Core.PParams era) (Map.Map Language CostModel),
+    HasField "_protocolVersion" (Core.PParams era) ProtVer,
     HasField "wdrls" (Core.TxBody era) (Wdrl (Crypto era)),
     HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))),
     HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))),
@@ -169,7 +171,7 @@ collectTwoPhaseScriptInputs ei sysS pp tx utxo =
     Nothing -> Left [NoCostModel PlutusV1]
     Just cost -> merge (apply cost) (map redeemer needed) (map getscript needed) (Right [])
   where
-    txinfo = runIdentity $ txInfo ei sysS utxo tx
+    txinfo = runIdentity $ txInfo pp ei sysS utxo tx
     needed = filter knownToNotBe1Phase $ scriptsNeeded utxo tx
     -- The formal spec achieves the same filtering as knownToNotBe1Phase
     -- by use of the (partial) language function, which is not defined

alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxos.hs

@@ -22,6 +22,7 @@ where
 
 import Cardano.Binary (FromCBOR (..), ToCBOR (..))
 import Cardano.Ledger.Alonzo.Language (Language)
+import Cardano.Ledger.Alonzo.PParams (ProtVer)
 import Cardano.Ledger.Alonzo.PlutusScriptApi
   ( CollectError,
     collectTwoPhaseScriptInputs,
@@ -97,6 +98,7 @@ instance
     HasField "_keyDeposit" (Core.PParams era) Coin,
     HasField "_poolDeposit" (Core.PParams era) Coin,
     HasField "_costmdls" (Core.PParams era) (Map.Map Language CostModel),
+    HasField "_protocolVersion" (Core.PParams era) ProtVer,
     HasField "datahash" (Core.TxOut era) (StrictMaybe (DataHash (Crypto era)))
   ) =>
   STS (UTXOS era)
@@ -130,6 +132,7 @@ utxosTransition ::
     HasField "_keyDeposit" (Core.PParams era) Coin,
     HasField "_poolDeposit" (Core.PParams era) Coin,
     HasField "collateral" (Core.TxBody era) (Set (TxIn (Crypto era))),
+    HasField "_protocolVersion" (Core.PParams era) ProtVer,
     HasField "_costmdls" (Core.PParams era) (Map.Map Language CostModel)
   ) =>
   TransitionRule (UTXOS era)
@@ -160,7 +163,8 @@ scriptsValidateTransition ::
     HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))),
     HasField "_keyDeposit" (Core.PParams era) Coin,
     HasField "_poolDeposit" (Core.PParams era) Coin,
-    HasField "_costmdls" (Core.PParams era) (Map.Map Language CostModel)
+    HasField "_costmdls" (Core.PParams era) (Map.Map Language CostModel),
+    HasField "_protocolVersion" (Core.PParams era) ProtVer
   ) =>
   TransitionRule (UTXOS era)
 scriptsValidateTransition = do
@@ -218,7 +222,8 @@ scriptsNotValidateTransition ::
     HasField "collateral" (Core.TxBody era) (Set (TxIn (Crypto era))),
     HasField "_costmdls" (Core.PParams era) (Map.Map Language CostModel),
     HasField "_keyDeposit" (Core.PParams era) Coin,
-    HasField "_poolDeposit" (Core.PParams era) Coin
+    HasField "_poolDeposit" (Core.PParams era) Coin,
+    HasField "_protocolVersion" (Core.PParams era) ProtVer
   ) =>
   TransitionRule (UTXOS era)
 scriptsNotValidateTransition = do
@@ -351,6 +356,7 @@ constructValidated ::
     HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))),
     HasField "datahash" (Core.TxOut era) (StrictMaybe (DataHash (Crypto era))),
     HasField "_costmdls" (Core.PParams era) (Map.Map Language CostModel),
+    HasField "_protocolVersion" (Core.PParams era) ProtVer,
     HasField "wdrls" (Core.TxBody era) (Wdrl (Crypto era))
   ) =>
   Globals ->

alonzo/impl/src/Cardano/Ledger/Alonzo/Tools.hs

@@ -13,6 +13,7 @@ where
 import Cardano.Ledger.Alonzo (AlonzoEra)
 import Cardano.Ledger.Alonzo.Data (Data, getPlutusData)
 import Cardano.Ledger.Alonzo.Language (Language (..))
+import Cardano.Ledger.Alonzo.PParams (_protocolVersion)
 import Cardano.Ledger.Alonzo.PlutusScriptApi (scriptsNeeded)
 import Cardano.Ledger.Alonzo.Scripts
   ( CostModel (..),
@@ -72,6 +73,7 @@ evaluateTransactionExecutionUnits ::
   ( CC.Crypto c,
     Monad m
   ) =>
+  Core.PParams (AlonzoEra c) ->
   -- | The transaction.
   Core.Tx (AlonzoEra c) ->
   -- | The current UTxO set (or the relevant portion for the transaction).
@@ -85,8 +87,8 @@ evaluateTransactionExecutionUnits ::
   -- | A map from redeemer pointers to either a failure or a sufficient execution budget.
   --  The value is monadic, depending on the epoch info.
   m (Map RdmrPtr (Either (ScriptFailure c) ExUnits))
-evaluateTransactionExecutionUnits tx utxo ei sysS costModels = do
-  txinfo <- txInfo ei sysS utxo tx
+evaluateTransactionExecutionUnits pp tx utxo ei sysS costModels = do
+  txinfo <- txInfo pp ei sysS utxo tx
   pure $ Map.mapWithKey (findAndCount txinfo) (unRedeemers $ getField @"txrdmrs" ws)
   where
     txb = getField @"body" tx

alonzo/impl/src/Cardano/Ledger/Alonzo/TxInfo.hs

@@ -16,6 +16,9 @@ import Cardano.Crypto.Hash.Class (Hash (UnsafeHash))
 import Cardano.Ledger.Address (Addr (..), RewardAcnt (..))
 import Cardano.Ledger.Alonzo.Data (Data (..), getPlutusData)
 import Cardano.Ledger.Alonzo.Language (Language (..))
+-- Instances only
+
+import Cardano.Ledger.Alonzo.PParams (ProtVer)
 import Cardano.Ledger.Alonzo.Scripts (CostModel (..), ExUnits (..), Script (..), decodeCostModel)
 import Cardano.Ledger.Alonzo.Tx
 import Cardano.Ledger.Alonzo.TxBody
@@ -32,7 +35,7 @@ import qualified Cardano.Ledger.Alonzo.TxBody as Alonzo (TxBody (..), TxOut (..)
 import Cardano.Ledger.Alonzo.TxWitness (TxWitness, unTxDats)
 import Cardano.Ledger.BaseTypes (StrictMaybe (..))
 import Cardano.Ledger.Coin (Coin (..))
-import Cardano.Ledger.Core as Core (TxBody, TxOut, Value)
+import Cardano.Ledger.Core as Core (PParams, TxBody, TxOut, Value)
 import Cardano.Ledger.Credential (Credential (KeyHashObj, ScriptHashObj), Ptr (..), StakeReference (..))
 import qualified Cardano.Ledger.Crypto as CC (Crypto)
 import Cardano.Ledger.Era (Crypto, Era)
@@ -63,7 +66,6 @@ import Data.Fixed (HasResolution (resolution))
 import qualified Data.Map as Map
 import Data.Maybe (mapMaybe)
 import qualified Data.Set as Set
--- Instances only
 import Data.Text (Text, pack)
 import Data.Text.Prettyprint.Doc (Pretty (..))
 import Data.Time.Clock (nominalDiffTimeToSeconds)
@@ -118,6 +120,9 @@ import qualified Plutus.V1.Ledger.Api as P
     validateScript,
   )
 import Plutus.V1.Ledger.Contexts ()
+import qualified Shelley.Spec.Ledger.HardForks as HardForks
+  ( translateTimeForPlutusScripts,
+  )
 import Shelley.Spec.Ledger.Scripts (ScriptHash (..))
 import Shelley.Spec.Ledger.TxBody
   ( DCert (..),
@@ -180,32 +185,42 @@ transAddr (Addr _net object stake) = Just (P.Address (transCred object) (transSt
 transAddr (AddrBootstrap _bootaddr) = Nothing
 
 slotToPOSIXTime ::
-  Monad m =>
+  (Monad m, HasField "_protocolVersion" (PParams era) ProtVer) =>
+  Core.PParams era ->
   EpochInfo m ->
   SystemStart ->
   SlotNo ->
   m P.POSIXTime
-slotToPOSIXTime ei sysS s = do
-  P.POSIXTime . resolution . nominalDiffTimeToSeconds . utcTimeToPOSIXSeconds
+slotToPOSIXTime pp ei sysS s = do
+  P.POSIXTime . transTime . nominalDiffTimeToSeconds . utcTimeToPOSIXSeconds
     <$> epochInfoSlotToUTCTime ei sysS s
+  where
+    transTime =
+      if HardForks.translateTimeForPlutusScripts pp
+        then
+          truncate
+            -- Convert to milliseconds
+            . (* fromInteger 1000)
+        else resolution
 
 -- | translate a validity interval to POSIX time
 transVITime ::
-  Monad m =>
+  (Monad m, HasField "_protocolVersion" (PParams era) ProtVer) =>
+  Core.PParams era ->
   EpochInfo m ->
   SystemStart ->
   ValidityInterval ->
   m P.POSIXTimeRange
-transVITime _ _ (ValidityInterval SNothing SNothing) = pure P.always
-transVITime ei sysS (ValidityInterval (SJust i) SNothing) = do
-  t <- slotToPOSIXTime ei sysS i
+transVITime _ _ _ (ValidityInterval SNothing SNothing) = pure P.always
+transVITime pp ei sysS (ValidityInterval (SJust i) SNothing) = do
+  t <- slotToPOSIXTime pp ei sysS i
   pure $ P.from t
-transVITime ei sysS (ValidityInterval SNothing (SJust i)) = do
-  t <- slotToPOSIXTime ei sysS i
+transVITime pp ei sysS (ValidityInterval SNothing (SJust i)) = do
+  t <- slotToPOSIXTime pp ei sysS i
   pure $ P.to t
-transVITime ei sysS (ValidityInterval (SJust i) (SJust j)) = do
-  t1 <- slotToPOSIXTime ei sysS i
-  t2 <- slotToPOSIXTime ei sysS j
+transVITime pp ei sysS (ValidityInterval (SJust i) (SJust j)) = do
+  t1 <- slotToPOSIXTime pp ei sysS i
+  t2 <- slotToPOSIXTime pp ei sysS j
   pure $
     P.Interval
       (P.lowerBound t1)
@@ -351,15 +366,17 @@ txInfo ::
     Core.TxBody era ~ Alonzo.TxBody era,
     Value era ~ Mary.Value (Crypto era),
     HasField "body" tx (Core.TxBody era),
-    HasField "wits" tx (TxWitness era)
+    HasField "wits" tx (TxWitness era),
+    HasField "_protocolVersion" (PParams era) ProtVer
   ) =>
+  Core.PParams era ->
   EpochInfo m ->
   SystemStart ->
   UTxO era ->
   tx ->
   m P.TxInfo
-txInfo ei sysS utxo tx = do
-  timeRange <- transVITime ei sysS interval
+txInfo pp ei sysS utxo tx = do
+  timeRange <- transVITime pp ei sysS interval
   pure $
     P.TxInfo
       { P.txInfoInputs = mapMaybe (txInfoIn utxo) (Set.toList (inputs' tbody)),

cardano-ledger-test/src/Test/Cardano/Ledger/Alonzo/Tools.hs

@@ -158,7 +158,7 @@ updateTxExUnits tx utxo ei ss costmdls err = do
   -- rdmrs :: Map RdmrPtr ExUnits
   rdmrs <-
     traverse (failLeft err)
-      =<< evaluateTransactionExecutionUnits tx utxo ei ss costmdls
+      =<< evaluateTransactionExecutionUnits pparams tx utxo ei ss costmdls
   pure (replaceRdmrs tx rdmrs)
 
 replaceRdmrs :: Core.Tx A -> Map RdmrPtr ExUnits -> Core.Tx A

cardano-ledger-test/src/Test/Cardano/Ledger/Examples/TwoPhaseValidation.hs

@@ -1911,7 +1911,7 @@ collectTwoPhaseScriptInputsOutputOrdering =
     apf = Alonzo Mock
     context =
       valContext
-        (runIdentity $ txInfo testEpochInfo testSystemStart (initUTxO apf) (validatingTx apf))
+        (runIdentity $ txInfo (pp apf) testEpochInfo testSystemStart (initUTxO apf) (validatingTx apf))
         (Spending $ TxIn genesisId 1)
 
 collectOrderingAlonzo :: TestTree

shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/HardForks.hs

@@ -7,6 +7,7 @@ module Shelley.Spec.Ledger.HardForks
     allowMIRTransfer,
     validatePoolRewardAccountNetID,
     allowScriptStakeCredsToEarnRewards,
+    translateTimeForPlutusScripts,
   )
 where
 
@@ -47,3 +48,11 @@ allowScriptStakeCredsToEarnRewards ::
   Natural ->
   Bool
 allowScriptStakeCredsToEarnRewards pvM = pvM > 4
+
+-- | Starting with protocol version 6, we translate slots to time correctly for
+-- Plutus scripts.
+translateTimeForPlutusScripts ::
+  (HasField "_protocolVersion" pp ProtVer) =>
+  pp ->
+  Bool
+translateTimeForPlutusScripts pp = pvMajor (getField @"_protocolVersion" pp) > 5