Support PlutusV2

alonzo/impl/cardano-ledger-alonzo.cabal

@@ -51,6 +51,7 @@ library
     Cardano.Ledger.Alonzo.TxSeq
     Cardano.Ledger.Alonzo.TxWitness
     Cardano.Ledger.DescribeEras
+    Fake.Plutus.V2.Ledger.Api
   build-depends:
     array,
     base-deriving-via,

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

@@ -129,7 +129,7 @@ instance (CC.Crypto c) => Shelley.ValidateScript (AlonzoEra c) where
       then "\x01"
       else nativeMultiSigTag -- "\x00"
   validateScript (TimelockScript script) tx = validateTimelock @(AlonzoEra c) script tx
-  validateScript (PlutusScript _) _tx = True
+  validateScript (PlutusScript _ _) _tx = True
 
 -- To run a PlutusScript use Cardano.Ledger.Alonzo.TxInfo(runPLCScript)
 -- To run any Alonzo Script use Cardano.Ledger.Alonzo.PlutusScriptApi(evalScripts)

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

@@ -34,10 +34,8 @@ module Cardano.Ledger.Alonzo.Data
 where
 
 import Cardano.Binary (FromCBOR (..), ToCBOR (..), TokenType (..), peekTokenType, withSlice)
-import Cardano.Ledger.Alonzo.Scripts
-  ( Script (..),
-    isPlutusScript,
-  )
+import Cardano.Ledger.Alonzo.Language (Language (..))
+import Cardano.Ledger.Alonzo.Scripts (Script (..))
 import Cardano.Ledger.AuxiliaryData (AuxiliaryDataHash (..))
 import Cardano.Ledger.BaseTypes (StrictMaybe (..))
 import qualified Cardano.Ledger.Core as Core
@@ -72,8 +70,7 @@ import qualified Codec.Serialise as Cborg (Serialise (..))
 import Data.ByteString.Lazy (toStrict)
 import Data.ByteString.Short (toShort)
 import Data.Coders
-import qualified Data.Foldable as Foldable
-import qualified Data.List as List
+import Data.Foldable (foldl')
 import Data.Map (Map)
 import Data.Maybe (mapMaybe)
 import Data.MemoBytes (Mem, MemoBytes (..), memoBytes)
@@ -180,19 +177,21 @@ encodeRaw ::
 encodeRaw metadata allScripts =
   Tag 259 $
     Keyed
-      (\m tss pss -> AuxiliaryDataRaw m (StrictSeq.fromList $ tss <> pss))
+      (\m tss p1ss p2ss -> AuxiliaryDataRaw m (StrictSeq.fromList $ tss <> p1ss <> p2ss))
       !> Omit null (Key 0 $ mapEncode metadata)
       !> Omit null (Key 1 $ E (encodeFoldable . mapMaybe getTimelock) timelocks)
-      !> Omit null (Key 2 $ E (encodeFoldable . mapMaybe getPlutus) plutusScripts)
+      !> Omit null (Key 2 $ E (encodeFoldable . mapMaybe getPlutus) plutusV1Scripts)
+      !> Omit null (Key 3 $ E (encodeFoldable . mapMaybe getPlutus) plutusV2Scripts)
   where
     getTimelock (TimelockScript x) = Just x
     getTimelock _ = Nothing
-    getPlutus (PlutusScript x) = Just x
+    getPlutus (PlutusScript _ x) = Just x
     getPlutus _ = Nothing
-    (plutusScripts, timelocks) =
-      List.partition
-        isPlutusScript
-        (Foldable.toList allScripts)
+    sortScripts (ts, v1, v2) s@(TimelockScript _) = (s : ts, v1, v2)
+    sortScripts (ts, v1, v2) s@(PlutusScript PlutusV1 _) = (ts, s : v1, v2)
+    sortScripts (ts, v1, v2) s@(PlutusScript PlutusV2 _) = (ts, v1, s : v2)
+    (timelocks, plutusV1Scripts, plutusV2Scripts) =
+      foldl' sortScripts (mempty, mempty, mempty) allScripts
 
 instance
   ( Era era,
@@ -243,7 +242,11 @@ instance
           (D (sequence <$> decodeStrictSeq fromCBOR))
       auxDataField 2 =
         fieldA
-          (\x ad -> ad {scripts' = scripts' ad <> (PlutusScript <$> x)})
+          (\x ad -> ad {scripts' = scripts' ad <> (PlutusScript PlutusV1 <$> x)})
+          (D (decodeStrictSeq fromCBOR))
+      auxDataField 3 =
+        fieldA
+          (\x ad -> ad {scripts' = scripts' ad <> (PlutusScript PlutusV2 <$> x)})
           (D (decodeStrictSeq fromCBOR))
       auxDataField n = field (\_ t -> t) (Invalid n)
 

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

@@ -24,7 +24,9 @@ import NoThunks.Class (NoThunks)
 -- For now, the only Non-Native Scriting language is Plutus
 -- We might add new languages in the futures.
 
-data Language = PlutusV1 --    | ADD-NEW-LANGUAGES-HERE
+data Language
+  = PlutusV1
+  | PlutusV2
   deriving (Eq, Generic, Show, Ord, Enum, Bounded, Ix)
 
 instance NoThunks Language
@@ -33,20 +35,23 @@ instance NFData Language
 
 instance ToCBOR Language where
   toCBOR PlutusV1 = toCBOR (0 :: Int)
+  toCBOR PlutusV2 = toCBOR (1 :: Int)
 
 instance FromCBOR Language where
   fromCBOR = do
     n <- decodeWord64
     case n of
       0 -> pure PlutusV1
+      1 -> pure PlutusV2
       m -> invalidKey (fromIntegral m)
 
 nonNativeLanguages :: Set.Set Language
-nonNativeLanguages = Set.singleton PlutusV1
+nonNativeLanguages = Set.fromList [PlutusV1, PlutusV2]
 
 -- ==================================
 
 ppLanguage :: Language -> PDoc
 ppLanguage PlutusV1 = ppString "PlutusV1"
+ppLanguage PlutusV2 = ppString "PlutusV2"
 
 instance PrettyA Language where prettyA = ppLanguage

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

@@ -41,7 +41,7 @@ import Cardano.Binary
     serialize',
     serializeEncoding',
   )
-import Cardano.Ledger.Alonzo.Language (Language (PlutusV1), ppLanguage)
+import Cardano.Ledger.Alonzo.Language (Language (..), ppLanguage)
 import Cardano.Ledger.Alonzo.Scripts
   ( CostModel,
     ExUnits (..),
@@ -517,6 +517,10 @@ getLanguageView pp lang@PlutusV1 =
   LangDepView
     (serialize' lang)
     (serializeEncoding' $ maybe encodeNull toCBOR $ Map.lookup lang (_costmdls pp))
+getLanguageView pp lang@PlutusV2 =
+  LangDepView
+    (serialize' lang)
+    (serializeEncoding' $ maybe encodeNull toCBOR $ Map.lookup lang (_costmdls pp))
 
 encodeLangViews :: Set LangDepView -> Encoding
 encodeLangViews views =

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

@@ -178,7 +178,7 @@ collectTwoPhaseScriptInputs ei sysS pp tx utxo =
     -- on 1-phase scripts.
     knownToNotBe1Phase (_, sh) =
       case sh `Map.lookup` txscripts' (getField @"wits" tx) of
-        Just (AlonzoScript.PlutusScript _) -> True
+        Just (AlonzoScript.PlutusScript _ _) -> True
         Just (AlonzoScript.TimelockScript _) -> False
         Nothing -> True
     redeemer (sp, _) =
@@ -211,7 +211,7 @@ merge f (x : xs) (y : ys) zs = merge f xs ys (gg x y zs)
     gg (Left a) (Left b) (Left cs) = Left (a : b : cs)
 
 language :: AlonzoScript.Script era -> Maybe Language
-language (AlonzoScript.PlutusScript _) = Just PlutusV1
+language (AlonzoScript.PlutusScript lang _) = Just lang
 language (AlonzoScript.TimelockScript _) = Nothing
 
 -- | evaluate a list of scripts, All scripts in the list must be True.
@@ -236,8 +236,8 @@ evalScripts tx ((AlonzoScript.TimelockScript timelock, _, _, _) : rest) =
     vhks = Set.map witKeyHash (txwitsVKey' (getField @"wits" tx))
     lift True = Passes
     lift False = Fails [OnePhaseFailure . pack . show $ timelock]
-evalScripts tx ((AlonzoScript.PlutusScript pscript, ds, units, cost) : rest) =
-  runPLCScript (Proxy @era) cost pscript units (map getPlutusData ds)
+evalScripts tx ((AlonzoScript.PlutusScript lang pscript, ds, units, cost) : rest) =
+  runPLCScript (Proxy @era) lang cost pscript units (map getPlutusData ds)
     `andResult` evalScripts tx rest
 
 -- Collect information (purpose and hash) about all the scripts in a Tx.

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

@@ -82,10 +82,11 @@ import qualified Data.Set as Set
 import Data.Text (Text)
 import Data.Typeable
 import Data.Word (Word64, Word8)
+import Fake.Plutus.V2.Ledger.Api as PV2 hiding (Script)
 import GHC.Generics (Generic)
 import NoThunks.Class (InspectHeapNamed (..), NoThunks)
 import Numeric.Natural (Natural)
-import Plutus.V1.Ledger.Api (defaultCostModelParams, validateCostModelParams)
+import Plutus.V1.Ledger.Api as PV1 hiding (Script)
 import qualified Plutus.V1.Ledger.Examples as Plutus
   ( alwaysFailingNAryFunction,
     alwaysSucceedingNAryFunction,
@@ -112,12 +113,12 @@ instance NoThunks Tag
 -- | Scripts in the Alonzo Era, Either a Timelock script or a Plutus script.
 data Script era
   = TimelockScript (Timelock (Crypto era))
-  | PlutusScript ShortByteString -- A Plutus.V1.Ledger.Scripts(Script) that has been 'CBOR' encoded
+  | PlutusScript Language ShortByteString
   deriving (Eq, Generic, Ord)
 
 instance (ValidateScript era, Core.Script era ~ Script era) => Show (Script era) where
   show (TimelockScript x) = "TimelockScript " ++ show x
-  show s@(PlutusScript _) = "PlutusScript " ++ show (hashScript @era s)
+  show s@(PlutusScript v _) = "PlutusScript " ++ show v ++ " " ++ show (hashScript @era s)
 
 deriving via
   InspectHeapNamed "Script" (Script era)
@@ -129,14 +130,14 @@ instance NFData (Script era)
 -- | Both constructors know their original bytes
 instance SafeToHash (Script era) where
   originalBytes (TimelockScript t) = originalBytes t
-  originalBytes (PlutusScript bs) = fromShort bs
+  originalBytes (PlutusScript _ bs) = fromShort bs
 
 alwaysSucceeds, alwaysFails :: Natural -> Script era
-alwaysSucceeds n = PlutusScript (Plutus.alwaysSucceedingNAryFunction n)
-alwaysFails n = PlutusScript (Plutus.alwaysFailingNAryFunction n)
+alwaysSucceeds n = PlutusScript PlutusV1 (Plutus.alwaysSucceedingNAryFunction n)
+alwaysFails n = PlutusScript PlutusV1 (Plutus.alwaysFailingNAryFunction n)
 
 isPlutusScript :: Script era -> Bool
-isPlutusScript (PlutusScript _) = True
+isPlutusScript (PlutusScript _ _) = True
 isPlutusScript (TimelockScript _) = False
 
 -- ===========================================
@@ -186,28 +187,36 @@ instance NoThunks CostModel
 
 instance NFData CostModel
 
-checkCostModel :: Map Text Integer -> Either String CostModel
-checkCostModel cm =
-  if validateCostModelParams cm
+checkCostModel :: Language -> Map Text Integer -> Either String CostModel
+checkCostModel PlutusV1 cm =
+  if PV1.validateCostModelParams cm
     then Right (CostModel cm)
-    else Left ("Invalid cost model: " ++ show cm)
+    else Left ("Invalid PlutusV1 cost model: " ++ show cm)
+checkCostModel PlutusV2 cm =
+  if PV2.validateCostModelParams cm
+    then Right (CostModel cm)
+    else Left ("Invalid PlutusV2 cost model: " ++ show cm)
 
-{-# DEPRECATED defaultCostModel "Use 'import Test.Cardano.Ledger.Alonzo.PlutusScripts' instead." #-}
-defaultCostModel :: Maybe CostModel
-defaultCostModel = CostModel <$> defaultCostModelParams
+defaultCostModel :: Language -> Maybe CostModel
+defaultCostModel PlutusV1 = CostModel <$> PV1.defaultCostModelParams
+defaultCostModel PlutusV2 = CostModel <$> PV2.defaultCostModelParams
 
 decodeCostModelMap :: Decoder s (Map Language CostModel)
 decodeCostModelMap = decodeMapByKey fromCBOR decodeCostModel
 
 decodeCostModel :: Language -> Decoder s CostModel
-decodeCostModel PlutusV1 =
-  case defaultCostModelParams of
+decodeCostModel lang =
+  case dcmps of
     Nothing -> fail "Default Plutus Cost Model is corrupt."
     Just dcm -> do
-      checked <- checkCostModel <$> decodeArrayAsMap (Map.keysSet dcm) fromCBOR
+      checked <- checkCostModel lang <$> decodeArrayAsMap (Map.keysSet dcm) fromCBOR
       case checked of
         Left e -> fail e
         Right cm -> pure cm
+  where
+    dcmps = case lang of
+      PlutusV1 -> PV1.defaultCostModelParams
+      PlutusV2 -> PV2.defaultCostModelParams
 
 decodeArrayAsMap :: Ord a => Set a -> Decoder s b -> Decoder s (Map a b)
 decodeArrayAsMap keys decodeValue = do
@@ -294,7 +303,8 @@ instance forall era. (Typeable (Crypto era), Typeable era) => ToCBOR (Script era
 
 encodeScript :: (Typeable (Crypto era)) => Script era -> Encode 'Open (Script era)
 encodeScript (TimelockScript i) = Sum TimelockScript 0 !> To i
-encodeScript (PlutusScript s) = Sum PlutusScript 1 !> To s -- Use the ToCBOR instance of ShortByteString
+encodeScript (PlutusScript PlutusV1 s) = Sum (PlutusScript PlutusV1) 1 !> To s -- Use the ToCBOR instance of ShortByteString
+encodeScript (PlutusScript PlutusV2 s) = Sum (PlutusScript PlutusV1) 2 !> To s
 
 instance
   (CC.Crypto (Crypto era), Typeable (Crypto era), Typeable era) =>
@@ -304,7 +314,8 @@ instance
     where
       decodeScript :: Word -> Decode 'Open (Annotator (Script era))
       decodeScript 0 = Ann (SumD TimelockScript) <*! From
-      decodeScript 1 = Ann (SumD PlutusScript) <*! Ann From
+      decodeScript 1 = Ann (SumD $ PlutusScript PlutusV1) <*! Ann From
+      decodeScript 2 = Ann (SumD $ PlutusScript PlutusV2) <*! Ann From
       decodeScript n = Invalid n
 
 -- ============================================================
@@ -316,7 +327,7 @@ ppTag x = ppString (show x)
 instance PrettyA Tag where prettyA = ppTag
 
 ppScript :: forall era. (ValidateScript era, Core.Script era ~ Script era) => Script era -> PDoc
-ppScript s@(PlutusScript _) = ppString "PlutusScript " PP.<+> ppScriptHash (hashScript @era s)
+ppScript s@(PlutusScript v _) = ppString ("PlutusScript " <> show v <> " ") PP.<+> ppScriptHash (hashScript @era s)
 ppScript (TimelockScript x) = ppTimelock x
 
 instance (ValidateScript era, Core.Script era ~ Script era) => PrettyA (Script era) where prettyA = ppScript

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

@@ -29,7 +29,7 @@ import qualified Cardano.Ledger.Core as Core
 import qualified Cardano.Ledger.Crypto as CC (Crypto)
 import Cardano.Slotting.EpochInfo.API (EpochInfo)
 import Cardano.Slotting.Time (SystemStart)
-import Data.Array (Array, (!))
+import Data.Array (Array, bounds, (!))
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import GHC.Records (HasField (..))
@@ -57,6 +57,8 @@ data ScriptFailure c
   | -- | The execution budget that was calculated by the Plutus
     --  evaluator is out of bounds.
     IncompatibleBudget P.ExBudget
+  | -- | There was no cost model for given version of Plutus
+    NoCostModel Language
   deriving (Show)
 
 note :: e -> Maybe a -> Either e a
@@ -101,24 +103,25 @@ evaluateTransactionExecutionUnits pp tx utxo ei sysS costModels = do
       msb <- case Map.lookup sh scripts of
         Nothing -> pure Nothing
         Just (TimelockScript _) -> []
-        Just (PlutusScript bytes) -> pure $ Just bytes
+        Just (PlutusScript v bytes) -> pure $ Just (bytes, v)
       pointer <- case rdptr @(AlonzoEra c) txb sp of
         SNothing -> []
         -- Since scriptsNeeded used the transaction to create script purposes,
         -- it would be a logic error if rdptr was not able to find sp.
         SJust p -> pure p
       pure (pointer, (sp, msb))
 
-    (CostModel costModel) = costModels ! PlutusV1
-
     findAndCount ::
       P.TxInfo ->
       RdmrPtr ->
       (Data (AlonzoEra c), ExUnits) ->
       Either (ScriptFailure c) ExUnits
     findAndCount inf pointer (rdmr, _) = do
       (sp, mscript) <- note (RedeemerNotNeeded pointer) $ Map.lookup pointer ptrToPlutusScript
-      script <- note (MissingScript pointer) mscript
+      (script, lang) <- note (MissingScript pointer) mscript
+      let (l1, l2) = bounds costModels
+      (CostModel costModel) <-
+        if l1 <= lang && lang <= l2 then Right (costModels ! lang) else Left (NoCostModel lang)
       args <- case sp of
         (Spending txin) -> do
           txOut <- note (UnknownTxIn txin) $ Map.lookup txin (unUTxO utxo)