From 3644d36a53d1f0192d0ccdceeb61f0376e93c9c9 Mon Sep 17 00:00:00 2001 From: Ana Pantilie Date: Fri, 16 May 2025 15:24:14 +0300 Subject: [PATCH 1/6] WIP: add certificate path to CompiledCode --- .../src/PlutusTx/Compiler/Types.hs | 3 ++- plutus-tx-plugin/src/PlutusTx/Plugin.hs | 6 ++--- plutus-tx/src/PlutusTx/Code.hs | 27 +++++++++++++------ plutus-tx/src/PlutusTx/Lift.hs | 9 ++++--- plutus-tx/src/PlutusTx/Plugin/Utils.hs | 2 +- plutus-tx/src/PlutusTx/TH.hs | 3 ++- 6 files changed, 33 insertions(+), 17 deletions(-) diff --git a/plutus-tx-plugin/src/PlutusTx/Compiler/Types.hs b/plutus-tx-plugin/src/PlutusTx/Compiler/Types.hs index cd762e39525..44aed68ffe8 100644 --- a/plutus-tx-plugin/src/PlutusTx/Compiler/Types.hs +++ b/plutus-tx-plugin/src/PlutusTx/Compiler/Types.hs @@ -198,7 +198,8 @@ type Compiling uni fun m ann = , MonadReader (CompileContext uni fun) m , MonadState CompileState m , MonadDefs LexName uni fun Ann m - , MonadWriter CoverageIndex m + -- TODO: fix + , MonadWriter (CoverageIndex, Maybe FilePath) m ) -- Packing up equality constraints gives us a nice way of writing type signatures as this way diff --git a/plutus-tx-plugin/src/PlutusTx/Plugin.hs b/plutus-tx-plugin/src/PlutusTx/Plugin.hs index aef78bef7b3..246ac0257ef 100644 --- a/plutus-tx-plugin/src/PlutusTx/Plugin.hs +++ b/plutus-tx-plugin/src/PlutusTx/Plugin.hs @@ -446,7 +446,7 @@ runCompiler :: , fun ~ PLC.DefaultFun , MonadReader (CompileContext uni fun) m , MonadState CompileState m - , MonadWriter CoverageIndex m + , MonadWriter (CoverageIndex, Maybe CertPath) m , MonadQuote m , MonadError (CompileError uni fun Ann) m , MonadIO m @@ -643,8 +643,8 @@ stripTicks = \case e -> e -- | Helper to avoid doing too much construction of Core ourselves -mkCompiledCode :: forall a . BS.ByteString -> BS.ByteString -> BS.ByteString -> CompiledCode a -mkCompiledCode plcBS pirBS ci = SerializedCode plcBS (Just pirBS) (fold . unflat $ ci) +mkCompiledCode :: forall a . BS.ByteString -> BS.ByteString -> BS.ByteString -> Maybe CertPath -> CompiledCode a +mkCompiledCode plcBS pirBS ci mcp = SerializedCode plcBS (Just pirBS) (fold . unflat $ ci) mcp -- | Make a 'NameInfo' mapping the given set of TH names to their -- 'GHC.TyThing's for later reference. diff --git a/plutus-tx/src/PlutusTx/Code.hs b/plutus-tx/src/PlutusTx/Code.hs index a7187aedf0e..57082158c3d 100644 --- a/plutus-tx/src/PlutusTx/Code.hs +++ b/plutus-tx/src/PlutusTx/Code.hs @@ -45,16 +45,20 @@ type role CompiledCodeIn representational representational nominal -- if you want to put it on the chain you must normalize the types first. data CompiledCodeIn uni fun a = -- | Serialized UPLC code and possibly serialized PIR code with metadata used for program coverage. - SerializedCode BS.ByteString (Maybe BS.ByteString) CoverageIndex + SerializedCode BS.ByteString (Maybe BS.ByteString) CoverageIndex (Maybe CertPath) -- | Deserialized UPLC program, and possibly deserialized PIR program with metadata used for program coverage. | DeserializedCode (UPLC.Program UPLC.NamedDeBruijn uni fun SrcSpans) (Maybe (PIR.Program PLC.TyName PLC.Name uni fun SrcSpans)) CoverageIndex + (Maybe CertPath) -- | 'CompiledCodeIn' instantiated with default built-in types and functions. type CompiledCode = CompiledCodeIn PLC.DefaultUni PLC.DefaultFun +-- | Type alias for the path to the certified compilation certificate, if one exists. +type CertPath = FilePath + -- | Apply a compiled function to a compiled argument. Will fail if the versions don't match. applyCode :: (PLC.Closed uni @@ -87,7 +91,9 @@ applyCode fun arg = do <> display argPir (Nothing, Nothing) -> Left "Missing PIR for both the function program and the argument." - pure $ DeserializedCode uplc pir (getCovIdx fun <> getCovIdx arg) + -- I don't think it makes sense to compose certificates, so we just + -- return Nothing here. + pure $ DeserializedCode uplc pir (getCovIdx fun <> getCovIdx arg) Nothing -- | Apply a compiled function to a compiled argument. Will throw if the versions don't match, -- should only be used in non-production code. @@ -122,10 +128,10 @@ getPlc :: (PLC.Closed uni, uni `PLC.Everywhere` Flat, Flat fun) => CompiledCodeIn uni fun a -> UPLC.Program UPLC.NamedDeBruijn uni fun SrcSpans getPlc wrapper = case wrapper of - SerializedCode plc _ _ -> case unflat (BSL.fromStrict plc) of + SerializedCode plc _ _ _ -> case unflat (BSL.fromStrict plc) of Left e -> throw $ ImpossibleDeserialisationFailure e Right (UPLC.UnrestrictedProgram p) -> p - DeserializedCode plc _ _ -> plc + DeserializedCode plc _ _ _ -> plc getPlcNoAnn :: (PLC.Closed uni, uni `PLC.Everywhere` Flat, Flat fun) @@ -137,12 +143,12 @@ getPir :: (PLC.Closed uni, uni `PLC.Everywhere` Flat, Flat fun) => CompiledCodeIn uni fun a -> Maybe (PIR.Program PIR.TyName PIR.Name uni fun SrcSpans) getPir wrapper = case wrapper of - SerializedCode _ pir _ -> case pir of + SerializedCode _ pir _ _ -> case pir of Just bs -> case unflat (BSL.fromStrict bs) of Left e -> throw $ ImpossibleDeserialisationFailure e Right p -> Just p Nothing -> Nothing - DeserializedCode _ pir _ -> pir + DeserializedCode _ pir _ _ -> pir getPirNoAnn :: (PLC.Closed uni, uni `PLC.Everywhere` Flat, Flat fun) @@ -151,5 +157,10 @@ getPirNoAnn = fmap void . getPir getCovIdx :: CompiledCodeIn uni fun a -> CoverageIndex getCovIdx wrapper = case wrapper of - SerializedCode _ _ idx -> idx - DeserializedCode _ _ idx -> idx + SerializedCode _ _ idx _ -> idx + DeserializedCode _ _ idx _ -> idx + +getCertPath :: CompiledCodeIn uni fun a -> Maybe CertPath +getCertPath wrapper = case wrapper of + SerializedCode _ _ _ certPath -> certPath + DeserializedCode _ _ _ certPath -> certPath diff --git a/plutus-tx/src/PlutusTx/Lift.hs b/plutus-tx/src/PlutusTx/Lift.hs index 2da3d16665c..8c55b0743f4 100644 --- a/plutus-tx/src/PlutusTx/Lift.hs +++ b/plutus-tx/src/PlutusTx/Lift.hs @@ -222,7 +222,8 @@ safeLiftCode safeLiftCode v = fmap ( \(pir, uplc) -> - DeserializedCode (mempty <$ uplc) (Just (mempty <$ pir)) mempty + -- TODO: maybe fix? + DeserializedCode (mempty <$ uplc) (Just (mempty <$ pir)) mempty mempty ) . safeLiftProgram v @@ -245,7 +246,8 @@ safeLiftCodeUnopt safeLiftCodeUnopt v = fmap ( \(pir, uplc) -> - DeserializedCode (mempty <$ uplc) (Just (mempty <$ pir)) mempty + -- TODO: maybe fix? + DeserializedCode (mempty <$ uplc) (Just (mempty <$ pir)) mempty mempty ) . safeLiftProgramUnopt v @@ -446,4 +448,5 @@ typeCode p prog = do flip runReaderT PLC.defaultCompilationOpts $ PLC.compileProgram prog db <- traverseOf UPLC.progTerm UPLC.deBruijnTerm compiled - pure $ DeserializedCode (mempty <$ db) Nothing mempty + -- TODO: maybe fix? + pure $ DeserializedCode (mempty <$ db) Nothing mempty mempty diff --git a/plutus-tx/src/PlutusTx/Plugin/Utils.hs b/plutus-tx/src/PlutusTx/Plugin/Utils.hs index 84f38746894..8e1fedece89 100644 --- a/plutus-tx/src/PlutusTx/Plugin/Utils.hs +++ b/plutus-tx/src/PlutusTx/Plugin/Utils.hs @@ -29,5 +29,5 @@ a Proxy to avoid this. -- | Marks the given expression for compilation to PLC. plc :: forall (loc::Symbol) a . Proxy loc -> a -> CompiledCode a -- this constructor is only really there to get rid of the unused warning -plc _ _ = SerializedCode (mustBeReplaced "plc") (mustBeReplaced "pir") (mustBeReplaced "covidx") +plc _ _ = SerializedCode (mustBeReplaced "plc") (mustBeReplaced "pir") (mustBeReplaced "covidx") (mustBeReplaced "certpath") {-# OPAQUE plc #-} diff --git a/plutus-tx/src/PlutusTx/TH.hs b/plutus-tx/src/PlutusTx/TH.hs index 810d41c03b2..49fecdef14b 100644 --- a/plutus-tx/src/PlutusTx/TH.hs +++ b/plutus-tx/src/PlutusTx/TH.hs @@ -28,7 +28,8 @@ loadFromFile fp = TH.liftCode $ do -- We don't have a 'Lift' instance for 'CompiledCode' (we could but it would be tedious), -- so we lift the bytestring and construct the value in the quote. bs <- liftIO $ BS.readFile fp - TH.examineCode [|| SerializedCode bs Nothing mempty ||] + -- TODO: maybe fix? + TH.examineCode [|| SerializedCode bs Nothing mempty mempty ||] {- Note [Typed TH] It's nice to use typed TH! However, we sadly can't *quite* use it thoroughly, because we From efe43685a7b7927a945c4222a65ddfb3be7b2ca8 Mon Sep 17 00:00:00 2001 From: Ana Pantilie Date: Wed, 21 May 2025 13:27:54 +0300 Subject: [PATCH 2/6] Maybe fix --- .../src/PlutusTx/Compiler/Types.hs | 58 ++++++++++++++++++- plutus-tx-plugin/src/PlutusTx/Plugin.hs | 3 +- plutus-tx/src/PlutusTx/Coverage.hs | 19 ------ 3 files changed, 58 insertions(+), 22 deletions(-) diff --git a/plutus-tx-plugin/src/PlutusTx/Compiler/Types.hs b/plutus-tx-plugin/src/PlutusTx/Compiler/Types.hs index 44aed68ffe8..89c1942114f 100644 --- a/plutus-tx-plugin/src/PlutusTx/Compiler/Types.hs +++ b/plutus-tx-plugin/src/PlutusTx/Compiler/Types.hs @@ -35,6 +35,8 @@ import Control.Monad.Reader import Control.Monad.State import Control.Monad.Writer +import Flat (Flat (..)) + import Data.Map qualified as Map import Data.Set (Set) import Data.Set qualified as Set @@ -191,6 +193,60 @@ stableModuleCmp m1 m2 = -- See Note [Stable name comparisons] (GHC.moduleUnit m1 `GHC.stableUnitCmp` GHC.moduleUnit m2) +newtype CertificatePath = CertificatePath + { getCertPath :: Maybe FilePath + } + +instance Flat CertificatePath where + encode (CertificatePath mp) = encode mp + decode = CertificatePath <$> decode + size (CertificatePath mp) = size mp + +instance Semigroup CertificatePath where + CertificatePath p1 <> CertificatePath p2 = + case (p1, p2) of + (Nothing, Nothing) -> CertificatePath Nothing + (Nothing, Just p) -> CertificatePath (Just p) + (Just p, Nothing) -> CertificatePath (Just p) + -- Overwrite the old path with the new path + (Just _, Just p) -> CertificatePath (Just p) + +instance Monoid CertificatePath where + mempty = CertificatePath Nothing + +data CompileOutput = CompileOutput + { coCoverageIndex :: CoverageIndex + , coCertPath :: CertificatePath + } + +instance Semigroup CompileOutput where + CompileOutput i1 c1 <> CompileOutput i2 c2 = + CompileOutput (i1 <> i2) (c1 <> c2) + +instance Monoid CompileOutput where + mempty = CompileOutput mempty mempty + +instance Flat CompileOutput where + encode (CompileOutput i c) = encode i <> encode c + decode = CompileOutput <$> decode <*> decode + size (CompileOutput i c) x = size i x + size c x + +-- | Include a location coverage annotation in the index +addLocationToCoverageIndex :: MonadWriter CompileOutput m => CovLoc -> m CoverageAnnotation +addLocationToCoverageIndex src = do + let ann = CoverLocation src + tell $ CompileOutput (CoverageIndex $ Map.singleton ann mempty) mempty + pure ann + +-- | Include a boolean coverage annotation in the index +addBoolCaseToCoverageIndex :: MonadWriter CompileOutput m + => CovLoc -> Bool -> CoverageMetadata -> m CoverageAnnotation +addBoolCaseToCoverageIndex src b meta = do + let ann = CoverBool src b + tell $ CompileOutput (CoverageIndex (Map.singleton ann meta)) mempty + pure ann + + -- See Note [Scopes] type Compiling uni fun m ann = ( MonadError (CompileError uni fun ann) m @@ -199,7 +255,7 @@ type Compiling uni fun m ann = , MonadState CompileState m , MonadDefs LexName uni fun Ann m -- TODO: fix - , MonadWriter (CoverageIndex, Maybe FilePath) m + , MonadWriter CompileOutput m ) -- Packing up equality constraints gives us a nice way of writing type signatures as this way diff --git a/plutus-tx-plugin/src/PlutusTx/Plugin.hs b/plutus-tx-plugin/src/PlutusTx/Plugin.hs index 246ac0257ef..e465ddaef18 100644 --- a/plutus-tx-plugin/src/PlutusTx/Plugin.hs +++ b/plutus-tx-plugin/src/PlutusTx/Plugin.hs @@ -22,7 +22,6 @@ import PlutusTx.Compiler.Error import PlutusTx.Compiler.Expr import PlutusTx.Compiler.Trace import PlutusTx.Compiler.Types -import PlutusTx.Coverage import PlutusTx.Function qualified import PlutusTx.Optimize.Inline qualified import PlutusTx.PIRTypes @@ -446,7 +445,7 @@ runCompiler :: , fun ~ PLC.DefaultFun , MonadReader (CompileContext uni fun) m , MonadState CompileState m - , MonadWriter (CoverageIndex, Maybe CertPath) m + , MonadWriter CompileOutput m , MonadQuote m , MonadError (CompileError uni fun Ann) m , MonadIO m diff --git a/plutus-tx/src/PlutusTx/Coverage.hs b/plutus-tx/src/PlutusTx/Coverage.hs index dc6984bdf3b..9f4d5fd48d2 100644 --- a/plutus-tx/src/PlutusTx/Coverage.hs +++ b/plutus-tx/src/PlutusTx/Coverage.hs @@ -23,8 +23,6 @@ module PlutusTx.Coverage ( CoverageAnnotation(..) , coverageMetadata , coveredAnnotations , addCoverageMetadata - , addLocationToCoverageIndex - , addBoolCaseToCoverageIndex , coverageDataFromLogMsg ) where @@ -44,8 +42,6 @@ import Data.Set qualified as Set import Data.String import Text.Read -import Control.Monad.Writer - import Prettyprinter import Prelude @@ -143,21 +139,6 @@ instance Semigroup CoverageIndex where instance Monoid CoverageIndex where mempty = CoverageIndex Map.empty --- | Include a location coverage annotation in the index -addLocationToCoverageIndex :: MonadWriter CoverageIndex m => CovLoc -> m CoverageAnnotation -addLocationToCoverageIndex src = do - let ann = CoverLocation src - tell $ CoverageIndex $ Map.singleton ann mempty - pure ann - --- | Include a boolean coverage annotation in the index -addBoolCaseToCoverageIndex :: MonadWriter CoverageIndex m - => CovLoc -> Bool -> CoverageMetadata -> m CoverageAnnotation -addBoolCaseToCoverageIndex src b meta = do - let ann = CoverBool src b - tell $ CoverageIndex (Map.singleton ann meta) - pure ann - -- | Add metadata to a coverage annotation. Does nothing if the annotation is not in the index. addCoverageMetadata :: CoverageAnnotation -> Metadata -> CoverageIndex -> CoverageIndex addCoverageMetadata ann meta idx = idx From bdc6e179547a8abc5634b354871a7a4b876150d5 Mon Sep 17 00:00:00 2001 From: Ana Pantilie Date: Wed, 21 May 2025 13:54:08 +0300 Subject: [PATCH 3/6] Add cert path to CompiledCode --- plutus-metatheory/src/Certifier.hs | 1 + .../src/PlutusTx/Compiler/Types.hs | 4 +++ plutus-tx-plugin/src/PlutusTx/Plugin.hs | 29 +++++++++++-------- 3 files changed, 22 insertions(+), 12 deletions(-) diff --git a/plutus-metatheory/src/Certifier.hs b/plutus-metatheory/src/Certifier.hs index fd04632168d..083c6dbd37e 100644 --- a/plutus-metatheory/src/Certifier.hs +++ b/plutus-metatheory/src/Certifier.hs @@ -4,6 +4,7 @@ module Certifier ( , prettyCertifierError , prettyCertifierSuccess , CertifierError (..) + , CertifierSuccess (..) ) where import Control.Monad ((>=>)) diff --git a/plutus-tx-plugin/src/PlutusTx/Compiler/Types.hs b/plutus-tx-plugin/src/PlutusTx/Compiler/Types.hs index 89c1942114f..e97f4bb4974 100644 --- a/plutus-tx-plugin/src/PlutusTx/Compiler/Types.hs +++ b/plutus-tx-plugin/src/PlutusTx/Compiler/Types.hs @@ -246,6 +246,10 @@ addBoolCaseToCoverageIndex src b meta = do tell $ CompileOutput (CoverageIndex (Map.singleton ann meta)) mempty pure ann +addCertificatePath :: MonadWriter CompileOutput m => FilePath -> m () +addCertificatePath path = do + let certPath = CertificatePath (Just path) + tell $ CompileOutput mempty certPath -- See Note [Scopes] type Compiling uni fun m ann = diff --git a/plutus-tx-plugin/src/PlutusTx/Plugin.hs b/plutus-tx-plugin/src/PlutusTx/Plugin.hs index e465ddaef18..b3b03feebc5 100644 --- a/plutus-tx-plugin/src/PlutusTx/Plugin.hs +++ b/plutus-tx-plugin/src/PlutusTx/Plugin.hs @@ -418,14 +418,15 @@ compileMarkedExpr locStr codeTy origE = do -- See Note [Occurrence analysis] let origE' = GHC.occurAnalyseExpr origE - ((pirP,uplcP), covIdx) <- runWriterT . runQuoteT . flip runReaderT ctx . flip evalStateT st $ + ((pirP,uplcP), compOut) <- runWriterT . runQuoteT . flip runReaderT ctx . flip evalStateT st $ traceCompilation 1 ("Compiling expr at" GHC.<+> GHC.text locStr) $ runCompiler moduleNameStr opts origE' -- serialize the PIR, PLC, and coverageindex outputs into a bytestring. bsPir <- makeByteStringLiteral $ flat pirP bsPlc <- makeByteStringLiteral $ flat (UPLC.UnrestrictedProgram uplcP) - covIdxFlat <- makeByteStringLiteral $ flat covIdx + compOutFlat <- makeByteStringLiteral $ flat compOut + builder <- lift . lift . GHC.lookupId =<< thNameToGhcNameOrFail 'mkCompiledCode @@ -435,7 +436,7 @@ compileMarkedExpr locStr codeTy origE = do `GHC.App` GHC.Type codeTy `GHC.App` bsPlc `GHC.App` bsPir - `GHC.App` covIdxFlat + `GHC.App` compOutFlat -- | The GHC.Core to PIR to PLC compiler pipeline. Returns both the PIR and PLC output. -- It invokes the whole compiler chain: Core expr -> PIR expr -> PLC expr -> UPLC expr. @@ -559,15 +560,19 @@ runCompiler moduleName opts expr = do let optCertify = opts ^. posCertify (uplcP, simplTrace) <- flip runReaderT plcOpts $ PLC.compileProgramWithTrace plcP - liftIO $ case optCertify of - Just certName -> do - result <- runCertifier $ mkCertifier simplTrace certName - case result of - Right certSuccess -> - hPutStrLn stderr $ prettyCertifierSuccess certSuccess - Left err -> - hPutStrLn stderr $ prettyCertifierError err - Nothing -> pure () + certP <- + liftIO $ case optCertify of + Just certName -> do + result <- runCertifier $ mkCertifier simplTrace certName + case result of + Right certSuccess -> do + hPutStrLn stderr $ prettyCertifierSuccess certSuccess + pure $ Just (certDir certSuccess) + Left err -> do + hPutStrLn stderr $ prettyCertifierError err + pure Nothing + Nothing -> pure Nothing + maybe (pure ()) addCertificatePath certP dbP <- liftExcept $ traverseOf UPLC.progTerm UPLC.deBruijnTerm uplcP when (opts ^. posDumpUPlc) . liftIO $ dumpFlat From 39d9b0ba65db25b21d2398a289e7e22716adb1a6 Mon Sep 17 00:00:00 2001 From: Ana Pantilie Date: Wed, 21 May 2025 23:13:10 +0300 Subject: [PATCH 4/6] WIP: add first test --- plutus-benchmark/plutus-benchmark.cabal | 9 +++++---- .../src/PlutusBenchmark/V2/Data/ScriptContexts.hs | 11 +++++++++-- plutus-benchmark/script-contexts/test/V2/Spec.hs | 4 +++- .../testlib/PlutusTx/Test/Util/Compiled.hs | 6 ++++++ plutus-tx/src/PlutusTx.hs | 9 ++++++--- 5 files changed, 29 insertions(+), 10 deletions(-) diff --git a/plutus-benchmark/plutus-benchmark.cabal b/plutus-benchmark/plutus-benchmark.cabal index df3f1f0aa52..88329af1a57 100644 --- a/plutus-benchmark/plutus-benchmark.cabal +++ b/plutus-benchmark/plutus-benchmark.cabal @@ -447,10 +447,11 @@ library script-contexts-internal PlutusBenchmark.V3.ScriptContexts build-depends: - , base >=4.9 && <5 - , plutus-ledger-api ^>=1.46 - , plutus-tx ^>=1.46 - , plutus-tx-plugin ^>=1.46 + , base >=4.9 && <5 + , plutus-ledger-api ^>=1.46 + , plutus-tx ^>=1.46 + , plutus-tx-plugin ^>=1.46 + , plutus-tx-test-util test-suite plutus-benchmark-script-contexts-tests import: lang, ghc-version-support, os-support diff --git a/plutus-benchmark/script-contexts/src/PlutusBenchmark/V2/Data/ScriptContexts.hs b/plutus-benchmark/script-contexts/src/PlutusBenchmark/V2/Data/ScriptContexts.hs index 6f873704c09..3e94d7b280e 100644 --- a/plutus-benchmark/script-contexts/src/PlutusBenchmark/V2/Data/ScriptContexts.hs +++ b/plutus-benchmark/script-contexts/src/PlutusBenchmark/V2/Data/ScriptContexts.hs @@ -4,6 +4,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:certify=ScriptContextCert #-} module PlutusBenchmark.V2.Data.ScriptContexts where @@ -20,6 +21,8 @@ import PlutusTx.Data.List qualified as DataList import PlutusTx.Plugin () import PlutusTx.Prelude qualified as PlutusTx +import PlutusTx.Test.Util.Compiled (compiledCodeToCertPath) + -- | A very crude deterministic generator for 'ScriptContext's with size -- approximately proportional to the input integer. mkScriptContext :: Integer -> ScriptContext @@ -276,10 +279,14 @@ forwardWithStakeTrickManual r_stake_cred r_ctx = mkForwardWithStakeTrickManualCode :: StakingCredential -> ScriptContext - -> PlutusTx.CompiledCode () + -> (Maybe FilePath, PlutusTx.CompiledCode ()) mkForwardWithStakeTrickManualCode cred ctx = let c = PlutusTx.toBuiltinData cred sc = PlutusTx.toBuiltinData ctx - in $$(PlutusTx.compile [|| forwardWithStakeTrickManual ||]) + code = $$(PlutusTx.compile [|| forwardWithStakeTrickManual ||]) + in + ( compiledCodeToCertPath code + , code `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef c `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef sc + ) diff --git a/plutus-benchmark/script-contexts/test/V2/Spec.hs b/plutus-benchmark/script-contexts/test/V2/Spec.hs index 4dd0c7c7039..832a44e38d5 100644 --- a/plutus-benchmark/script-contexts/test/V2/Spec.hs +++ b/plutus-benchmark/script-contexts/test/V2/Spec.hs @@ -193,12 +193,14 @@ testDataFwdStakeTrick = testDataFwdStakeTrickManual :: TestTree testDataFwdStakeTrickManual = + -- testGroup "testing" $ runTestGhcSOP [ Tx.goldenPirReadable "dataFwdStakeTrickManual" testAbsCode , Tx.goldenUPlcReadable "dataFwdStakeTrickManual" testAbsCode , Tx.goldenBudget "dataFwdStakeTrickManual" testCode , Tx.goldenEvalCekCatch "dataFwdStakeTrickManual" [testCode] ] + -- : [testCase "testCert" $ ] where testCredential = Data.SC.mkStakingCredential "someCredential" @@ -206,7 +208,7 @@ testDataFwdStakeTrickManual = Data.SC.mkScriptContextWithStake 20 20 (Just (testCredential, 1)) testAbsCode = $$(PlutusTx.compile [|| Data.SC.forwardWithStakeTrickManual ||]) - testCode = + (mcert, testCode) = Data.SC.mkForwardWithStakeTrickManualCode testCredential testScriptContext allTests :: TestTree diff --git a/plutus-tx-test-util/testlib/PlutusTx/Test/Util/Compiled.hs b/plutus-tx-test-util/testlib/PlutusTx/Test/Util/Compiled.hs index 4c0eea2de58..bdd16bb5171 100644 --- a/plutus-tx-test-util/testlib/PlutusTx/Test/Util/Compiled.hs +++ b/plutus-tx-test-util/testlib/PlutusTx/Test/Util/Compiled.hs @@ -10,6 +10,7 @@ module PlutusTx.Test.Util.Compiled , toAnonDeBruijnProg , toNamedDeBruijnTerm , compiledCodeToTerm + , compiledCodeToCertPath , haskellValueToTerm , unsafeRunTermCek , runTermCek @@ -56,6 +57,11 @@ compiledCodeToTerm :: Tx.CompiledCodeIn DefaultUni DefaultFun a -> Term compiledCodeToTerm (Tx.getPlcNoAnn -> UPLC.Program _ _ body) = body +{- | Extract the path to the generated certificate, if one exists. -} +compiledCodeToCertPath + :: Tx.CompiledCodeIn DefaultUni DefaultFun a -> Maybe FilePath +compiledCodeToCertPath (Tx.getCertPath -> mpath) = mpath + {- | Lift a Haskell value to a PLC term. The constraints get a bit out of control if we try to do this over an arbitrary universe.-} haskellValueToTerm diff --git a/plutus-tx/src/PlutusTx.hs b/plutus-tx/src/PlutusTx.hs index 3eaab51052e..4088e544702 100644 --- a/plutus-tx/src/PlutusTx.hs +++ b/plutus-tx/src/PlutusTx.hs @@ -25,13 +25,16 @@ module PlutusTx ( makeLift, safeLiftCode, liftCode, - liftCodeDef) where + liftCodeDef, + getCovIdx, + getCertPath, + ) where import PlutusCore.Data (Data (..)) import PlutusTx.Blueprint.TH (makeIsDataSchemaIndexed) import PlutusTx.Builtins (BuiltinData, builtinDataToData, dataToBuiltinData) -import PlutusTx.Code (CompiledCode, CompiledCodeIn, applyCode, getPir, getPirNoAnn, getPlc, - getPlcNoAnn, unsafeApplyCode) +import PlutusTx.Code (CompiledCode, CompiledCodeIn, applyCode, getCertPath, getCovIdx, getPir, + getPirNoAnn, getPlc, getPlcNoAnn, unsafeApplyCode) import PlutusTx.IsData (FromData (..), ToData (..), UnsafeFromData (..), fromData, makeIsDataIndexed, toData, unstableMakeIsData) import PlutusTx.Lift (liftCode, liftCodeDef, makeLift, safeLiftCode) From 90ea66584a84a4c252fea2493eb58924df7b1430 Mon Sep 17 00:00:00 2001 From: Ana Pantilie Date: Tue, 27 May 2025 13:59:33 +0300 Subject: [PATCH 5/6] Remove from plutus-benchmark --- plutus-benchmark/plutus-benchmark.cabal | 11 ++++++----- .../src/PlutusBenchmark/V2/Data/ScriptContexts.hs | 12 ++++-------- plutus-benchmark/script-contexts/test/V2/Spec.hs | 7 +++---- 3 files changed, 13 insertions(+), 17 deletions(-) diff --git a/plutus-benchmark/plutus-benchmark.cabal b/plutus-benchmark/plutus-benchmark.cabal index 88329af1a57..9baeb70b4f2 100644 --- a/plutus-benchmark/plutus-benchmark.cabal +++ b/plutus-benchmark/plutus-benchmark.cabal @@ -447,11 +447,12 @@ library script-contexts-internal PlutusBenchmark.V3.ScriptContexts build-depends: - , base >=4.9 && <5 - , plutus-ledger-api ^>=1.46 - , plutus-tx ^>=1.46 - , plutus-tx-plugin ^>=1.46 - , plutus-tx-test-util + , base >=4.9 && <5 + , plutus-ledger-api ^>=1.46 + , plutus-tx ^>=1.46 + , plutus-tx-plugin ^>=1.46 + +-- , plutus-tx-test-util test-suite plutus-benchmark-script-contexts-tests import: lang, ghc-version-support, os-support diff --git a/plutus-benchmark/script-contexts/src/PlutusBenchmark/V2/Data/ScriptContexts.hs b/plutus-benchmark/script-contexts/src/PlutusBenchmark/V2/Data/ScriptContexts.hs index 3e94d7b280e..6a282dff64f 100644 --- a/plutus-benchmark/script-contexts/src/PlutusBenchmark/V2/Data/ScriptContexts.hs +++ b/plutus-benchmark/script-contexts/src/PlutusBenchmark/V2/Data/ScriptContexts.hs @@ -4,7 +4,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:certify=ScriptContextCert #-} +-- {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:certify=ScriptContextCert #-} module PlutusBenchmark.V2.Data.ScriptContexts where @@ -21,7 +21,7 @@ import PlutusTx.Data.List qualified as DataList import PlutusTx.Plugin () import PlutusTx.Prelude qualified as PlutusTx -import PlutusTx.Test.Util.Compiled (compiledCodeToCertPath) +-- import PlutusTx.Test.Util.Compiled (compiledCodeToCertPath) -- | A very crude deterministic generator for 'ScriptContext's with size -- approximately proportional to the input integer. @@ -279,14 +279,10 @@ forwardWithStakeTrickManual r_stake_cred r_ctx = mkForwardWithStakeTrickManualCode :: StakingCredential -> ScriptContext - -> (Maybe FilePath, PlutusTx.CompiledCode ()) + -> PlutusTx.CompiledCode () mkForwardWithStakeTrickManualCode cred ctx = let c = PlutusTx.toBuiltinData cred sc = PlutusTx.toBuiltinData ctx - code = $$(PlutusTx.compile [|| forwardWithStakeTrickManual ||]) - in - ( compiledCodeToCertPath code - , code + in $$(PlutusTx.compile [|| forwardWithStakeTrickManual ||]) `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef c `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef sc - ) diff --git a/plutus-benchmark/script-contexts/test/V2/Spec.hs b/plutus-benchmark/script-contexts/test/V2/Spec.hs index 82a2b058e4d..2a6e8434e0b 100644 --- a/plutus-benchmark/script-contexts/test/V2/Spec.hs +++ b/plutus-benchmark/script-contexts/test/V2/Spec.hs @@ -167,13 +167,12 @@ testDataFwdStakeTrick = testDataFwdStakeTrickManual :: TestTree testDataFwdStakeTrickManual = - -- testGroup "testing" $ - runTestGhcSOP + (runTestGhcSOP [ Tx.goldenPirReadable "dataFwdStakeTrickManual" testAbsCode , Tx.goldenUPlcReadable "dataFwdStakeTrickManual" testAbsCode , Tx.goldenEvalCekCatchBudget "dataFwdStakeTrickManual" testCode ] - -- : [testCase "testCert" $ ] + ) where testCredential = Data.SC.mkStakingCredential "someCredential" @@ -181,7 +180,7 @@ testDataFwdStakeTrickManual = Data.SC.mkScriptContextWithStake 20 20 (Just (testCredential, 1)) testAbsCode = $$(PlutusTx.compile [|| Data.SC.forwardWithStakeTrickManual ||]) - (mcert, testCode) = + testCode = Data.SC.mkForwardWithStakeTrickManualCode testCredential testScriptContext allTests :: TestTree From 9d415502721eabcbc9e7c9505133236f5f482f03 Mon Sep 17 00:00:00 2001 From: Ana Pantilie Date: Tue, 27 May 2025 15:49:34 +0300 Subject: [PATCH 6/6] WIP: add plugin tests --- plutus-benchmark/plutus-benchmark.cabal | 3 +- plutus-executables/plutus-executables.cabal | 9 ++++- plutus-executables/test/certifier/Spec.hs | 2 + .../test/certifier/Test/Certifier/Plugin.hs | 38 +++++++++++++++++++ 4 files changed, 49 insertions(+), 3 deletions(-) create mode 100644 plutus-executables/test/certifier/Test/Certifier/Plugin.hs diff --git a/plutus-benchmark/plutus-benchmark.cabal b/plutus-benchmark/plutus-benchmark.cabal index 9baeb70b4f2..5182a13d4e6 100644 --- a/plutus-benchmark/plutus-benchmark.cabal +++ b/plutus-benchmark/plutus-benchmark.cabal @@ -438,6 +438,7 @@ benchmark bls12-381-benchmarks library script-contexts-internal import: lang, ghc-version-support, os-support hs-source-dirs: script-contexts/src + visibility: public exposed-modules: PlutusBenchmark.V1.Data.ScriptContexts PlutusBenchmark.V1.ScriptContexts @@ -452,8 +453,6 @@ library script-contexts-internal , plutus-tx ^>=1.46 , plutus-tx-plugin ^>=1.46 --- , plutus-tx-test-util - test-suite plutus-benchmark-script-contexts-tests import: lang, ghc-version-support, os-support type: exitcode-stdio-1.0 diff --git a/plutus-executables/plutus-executables.cabal b/plutus-executables/plutus-executables.cabal index d3de421c090..6bc902bb48e 100644 --- a/plutus-executables/plutus-executables.cabal +++ b/plutus-executables/plutus-executables.cabal @@ -156,11 +156,18 @@ test-suite test-certifier type: exitcode-stdio-1.0 main-is: Spec.hs hs-source-dirs: test/certifier - other-modules: Test.Certifier.Executable + other-modules: + Test.Certifier.Executable + Test.Certifier.Plugin + build-depends: , base , directory , filepath + , plutus-benchmark:script-contexts-internal + , plutus-tx + , plutus-tx-plugin + , plutus-tx-test-util , process , tasty , tasty-hunit diff --git a/plutus-executables/test/certifier/Spec.hs b/plutus-executables/test/certifier/Spec.hs index 36da623b869..1b772d109ad 100644 --- a/plutus-executables/test/certifier/Spec.hs +++ b/plutus-executables/test/certifier/Spec.hs @@ -9,6 +9,7 @@ import GHC.IO.Encoding (setLocaleEncoding, utf8) import Test.Tasty import Test.Certifier.Executable (executableTests) +import Test.Certifier.Plugin (pluginTests) main :: IO () main = do @@ -16,4 +17,5 @@ main = do defaultMain $ testGroup "Certification" [ executableTests + , pluginTests ] diff --git a/plutus-executables/test/certifier/Test/Certifier/Plugin.hs b/plutus-executables/test/certifier/Test/Certifier/Plugin.hs new file mode 100644 index 00000000000..3091bde085c --- /dev/null +++ b/plutus-executables/test/certifier/Test/Certifier/Plugin.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} + +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:certify=ScriptContextCert #-} + +module Test.Certifier.Plugin where + +import PlutusTx.Test.Util.Compiled (compiledCodeToCertPath) + +import Test.Certifier.Executable (runAgda) + +import PlutusBenchmark.V2.Data.ScriptContexts qualified as Data (forwardWithStakeTrick) + +import PlutusTx qualified + +import Data.Maybe (fromJust) +import System.Directory (removeDirectoryRecursive) +import System.Exit + +import Test.Tasty +import Test.Tasty.HUnit + +mkCertTest :: String -> PlutusTx.CompiledCode a -> TestTree +mkCertTest name code = testCase name $ do + let cPath = fromJust $ compiledCodeToCertPath code + (resECode, resText) <- runAgda cPath + -- removeDirectoryRecursive cPath + putStrLn cPath + assertBool + (name <> " creates an invalid certificate:" <> resText) + (resECode == ExitSuccess) + +pluginTests :: TestTree +pluginTests = + testGroup "Certifier with plugin tests" $ + [ mkCertTest "TESTING Data.forwardWithStakeTrick" $$(PlutusTx.compile [|| Data.forwardWithStakeTrick ||]) + -- Add more tests here as needed + ]