WIP: add certificate path to CompiledCode

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

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

plutus-benchmark/script-contexts/test/V2/Spec.hs

@@ -167,11 +167,12 @@ testDataFwdStakeTrick =
 
 testDataFwdStakeTrickManual :: TestTree
 testDataFwdStakeTrickManual =
-     runTestGhcSOP
+     (runTestGhcSOP
           [ Tx.goldenPirReadable "dataFwdStakeTrickManual" testAbsCode
           , Tx.goldenUPlcReadable "dataFwdStakeTrickManual" testAbsCode
           , Tx.goldenEvalCekCatchBudget "dataFwdStakeTrickManual" testCode
           ]
+     )
   where
      testCredential =
           Data.SC.mkStakingCredential "someCredential"

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

plutus-executables/test/certifier/Spec.hs

@@ -9,11 +9,13 @@ import GHC.IO.Encoding (setLocaleEncoding, utf8)
 import Test.Tasty
 
 import Test.Certifier.Executable (executableTests)
+import Test.Certifier.Plugin (pluginTests)
 
 main :: IO ()
 main = do
   setLocaleEncoding utf8
   defaultMain $
     testGroup "Certification"
     [ executableTests
+    , pluginTests
     ]

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
+    ]

plutus-metatheory/src/Certifier.hs

@@ -4,6 +4,7 @@ module Certifier (
   , prettyCertifierError
   , prettyCertifierSuccess
   , CertifierError (..)
+  , CertifierSuccess (..)
   ) where
 
 import Control.Monad ((>=>))

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
@@ -203,14 +205,73 @@ 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
+
+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 =
   ( MonadError (CompileError uni fun ann) m
   , MonadQuote m
   , MonadReader (CompileContext uni fun) m
   , MonadState CompileState m
   , MonadDefs LexName uni fun Ann m
-  , MonadWriter CoverageIndex m
+    -- TODO: fix
+  , MonadWriter CompileOutput m
   )
 
 -- Packing up equality constraints gives us a nice way of writing type signatures as this way

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
@@ -412,7 +411,7 @@ compileMarkedExpr locStr codeTy origE = do
            , 'useToOpaque
            , 'useFromOpaque
            , 'mkNilOpaque
-           , 'PlutusTx.Builtins.equalsInteger           
+           , 'PlutusTx.Builtins.equalsInteger
            ]
   modBreaks <- asks pcModuleModBreaks
   let coverage =
@@ -446,15 +445,16 @@ compileMarkedExpr locStr codeTy origE = do
   -- See Note [Occurrence analysis]
   let origE' = GHC.occurAnalyseExpr origE
 
-  ((pirP, uplcP), covIdx) <-
+  ((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
 
@@ -464,7 +464,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.
@@ -475,7 +475,7 @@ runCompiler
      , fun ~ PLC.DefaultFun
      , MonadReader (CompileContext uni fun) m
      , MonadState CompileState m
-     , MonadWriter CoverageIndex m
+     , MonadWriter CompileOutput m
      , MonadQuote m
      , MonadError (CompileError uni fun Ann) m
      , MonadIO m
@@ -613,15 +613,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
@@ -696,8 +700,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.

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

plutus-tx/src/PlutusTx.hs

@@ -26,13 +26,15 @@ module PlutusTx (
   safeLiftCode,
   liftCode,
   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)