Add divulgence warning and test in script service. (#10179)

* Add divulgence warning and test in script service.

Part of #9947, building on the key visibility checks from #10136

This PR adds a divulgence warning inside the traceLog.
I wasn't sure whether:

1. these warnings should be kept in a separate structure from the
   traceLog, and therefore transmitted separately, or
2. these warnings should be kept together with traces, but the severity
   should be tracked and also transmitted over grpc, and warnings should
   be logged as warnings instead of as debug messages, or
3. these warnings should be kept together with traces, but
   logged as warnings instead of debug messages,
4. these warnings should be treated exactly like traces

I'm leaning toward #2, but this PR implements #3.

This PR tests the warning via the script service tests.

changelog_begin
changelog_end

* scalafmt

* Address Moritz's review

* Rename traceLog.add to traceLog.addDebug

* fix test

* Add test using exercise

* add single transaction test

compiler/damlc/tests/src/DA/Test/ScriptService.hs

@@ -596,6 +596,116 @@ main =
                     , "  \"logClient2\"\n"
                     , "  \"please don't die\""
                     ],
+              testCase "divulgence warning" $ do
+                rs <-
+                  runScripts
+                    scriptService
+                    [ "module Test where"
+                    , "import Daml.Script"
+                    , "template T"
+                    , "  with"
+                    , "    p1 : Party"
+                    , "    p2 : Party"
+                    , "  where"
+                    , "    signatory p1"
+                    , "    choice C : ()"
+                    , "      controller p2"
+                    , "      do pure ()"
+                    , "template Delegate"
+                    , "  with"
+                    , "    p1 : Party"
+                    , "    p2 : Party"
+                    , "    cid : ContractId T"
+                    , "  where"
+                    , "    signatory p1"
+                    , "    observer p2"
+                    , "    nonconsuming choice Fetch : T"
+                    , "      controller p2"
+                    , "      do fetch cid"
+                    , "    choice Exercise : ()"
+                    , "      controller p2"
+                    , "      do exercise cid C"
+                    , "template Divulge"
+                    , "  with"
+                    , "    p1 : Party"
+                    , "    p2 : Party"
+                    , "    cid : ContractId T"
+                    , "  where"
+                    , "    signatory p2"
+                    , "    observer p1"
+                    , "    choice Accept : T"
+                    , "      controller p1"
+                    , "      do fetch cid"
+                    , ""
+                    , "template CreateAndDelegate"
+                    , "  with"
+                    , "    p1 : Party" -- p1 is creator of template T
+                    , "    p2 : Party" -- p2 is target for delegation
+                    , "    p3 : Party" -- p3 is pulling the strings
+                    , "  where"
+                    , "    signatory p1"
+                    , "    observer p3"
+                    , "    choice AcceptCAD : ContractId Delegate"
+                    , "      controller p3"
+                    , "      do cid <- create (T p1 p2)"
+                    , "         create (Delegate p1 p2 cid)"
+                    , "template UseDelegate"
+                    , "  with"
+                    , "    p2 : Party"
+                    , "    p3 : Party"
+                    , "  where"
+                    , "    signatory p2"
+                    , "    observer p3"
+                    , "    choice GoUseDelegate : ()"
+                    , "      with delegateCid : ContractId Delegate"
+                    , "      controller p3"
+                    , "      do exercise delegateCid Fetch"
+                    , "         exercise delegateCid Exercise"
+                    , "template PullTheStrings"
+                    , "  with"
+                    , "    p3 : Party"
+                    , "    cadCid : ContractId CreateAndDelegate"
+                    , "    useDelegateCid : ContractId UseDelegate"
+                    , "  where"
+                    , "    signatory p3"
+                    , "    choice GoPullTheStrings : ()"
+                    , "      controller p3"
+                    , "      do delegateCid <- exercise cadCid AcceptCAD"
+                    , "         exercise useDelegateCid (GoUseDelegate delegateCid)"
+                    , ""
+                    , "testDivulge = do"
+                    , "  debug \"start-test\""
+                    , "  p1 <- allocateParty \"p1\""
+                    , "  p2 <- allocateParty \"p2\""
+                    , "  p3 <- allocateParty \"p3\""
+                    , "  cid <- submit p1 (createCmd (T p1 p2))"
+                    , "  divulgeCid <- submit p2 (createCmd (Divulge p1 p2 cid))"
+                    , "  submit p1 (exerciseCmd divulgeCid Accept)"
+                    , "  delegateCid <- submit p1 (createCmd (Delegate p1 p2 cid))"
+                    -- fetch divulged contract generates warning:
+                    , "  submit p2 (exerciseCmd delegateCid Fetch)"
+                    -- exercise divulged contract generates warning:
+                    , "  submit p2 (exerciseCmd delegateCid Exercise)"
+                    -- create, fetch, exercise in same transaction, so no warning expected:
+                    , "  cadCid <- submit p1 (createCmd (CreateAndDelegate p1 p2 p3))"
+                    , "  useDelegateCid <- submit p2 (createCmd (UseDelegate p2 p3))"
+                    , "  submit p3 (createAndExerciseCmd (PullTheStrings p3 cadCid useDelegateCid) GoPullTheStrings)"
+                    , "  debug \"end-test\""
+                    , "  pure ()"
+                    ]
+                expectScriptSuccess rs (vr "testDivulge") $ \r ->
+                  matchRegex r $ T.concat
+
+                    [ "Trace: \n"
+                    , "  \"start-test\"\n"
+                    , "  Warning: Tried to fetch or exercise -homePackageId-:Test:T contract ContractId\\([0-9a-f]*\\) "
+                    , "but none of the reading parties actAs = Set\\(p2\\), readAs = Set\\(\\) are a stakeholder TreeSet\\(p1\\). "
+                    , "Use of divulged contracts is deprecated and incompatible with pruning\n"
+                    , "  Warning: Tried to fetch or exercise -homePackageId-:Test:T contract ContractId\\([0-9a-f]*\\) "
+                    , "but none of the reading parties actAs = Set\\(p2\\), readAs = Set\\(\\) are a stakeholder TreeSet\\(p1\\). "
+                    , "Use of divulged contracts is deprecated and incompatible with pruning\n"
+                    , "  \"end-test\""
+                    ],
               testCase "multi-party query" $ do
                 rs <-
                   runScripts

daml-lf/interpreter/src/main/scala/com/digitalasset/daml/lf/speedy/SBuiltin.scala

@@ -1360,7 +1360,7 @@ private[lf] object SBuiltin {
         machine: Machine,
     ): Unit = {
       val message = getSText(args, 0)
-      machine.traceLog.add(message, machine.lastLocation)
+      machine.traceLog.addDebug(message, machine.lastLocation)
       machine.returnValue = args.get(1)
     }
   }

daml-lf/interpreter/src/main/scala/com/digitalasset/daml/lf/speedy/Speedy.scala

@@ -104,7 +104,9 @@ private[lf] object Speedy {
       signatories: Set[Party],
       observers: Set[Party],
       key: Option[Node.KeyWithMaintainers[V[Nothing]]],
-  )
+  ) {
+    private[lf] val stakeholders: Set[Party] = signatories union observers;
+  }
 
   private[lf] final case class OnLedger(
       val validating: Boolean,
@@ -743,6 +745,16 @@ private[lf] object Speedy {
       returnValue = go(typ0, value0)
     }
 
+    def checkContractVisibility(onLedger: OnLedger, cid: V.ContractId, contract: CachedContract) = {
+      onLedger.visibleToStakeholders(contract.stakeholders) match {
+        case SVisibleToStakeholders.Visible => ()
+        case SVisibleToStakeholders.NotVisible(actAs, readAs) =>
+          this.traceLog.addWarning(
+            s"Tried to fetch or exercise ${contract.templateId} contract ${cid} but none of the reading parties actAs = ${actAs}, readAs = ${readAs} are a stakeholder ${contract.stakeholders}. Use of divulged contracts is deprecated and incompatible with pruning",
+            this.lastLocation,
+          )
+      }
+    }
   }
 
   object Machine {
@@ -1272,6 +1284,7 @@ private[lf] object Speedy {
     def execute(sv: SValue): Unit = {
       val cached = SBuiltin.extractCachedContract(templateId, sv)
       machine.withOnLedger("KCacheContract") { onLedger =>
+        machine.checkContractVisibility(onLedger, cid, cached);
         onLedger.cachedContracts = onLedger.cachedContracts.updated(cid, cached)
         machine.returnValue = cached.value
       }

daml-lf/interpreter/src/main/scala/com/digitalasset/daml/lf/speedy/TraceLog.scala

@@ -7,7 +7,8 @@ import com.daml.lf.data.Ref.Location
 import org.slf4j.Logger
 
 private[lf] trait TraceLog {
-  def add(message: String, optLocation: Option[Location]): Unit
+  def addDebug(message: String, optLocation: Option[Location]): Unit
+  def addWarning(message: String, optLocation: Option[Location]): Unit
   def iterator: Iterator[(String, Option[Location])]
 }
 
@@ -17,16 +18,27 @@ private[lf] final case class RingBufferTraceLog(logger: Logger, capacity: Int) e
   private var pos: Int = 0
   private var size: Int = 0
 
-  def add(message: String, optLocation: Option[Location]): Unit = {
-    if (logger.isDebugEnabled) {
-      logger.debug(s"${Pretty.prettyLoc(optLocation).renderWideStream.mkString}: $message")
-    }
+  private def addToBuffer(message: String, optLocation: Option[Location]): Unit = {
     buffer(pos) = (message, optLocation)
     pos = (pos + 1) % capacity
     if (size < capacity)
       size += 1
   }
 
+  def addDebug(message: String, optLocation: Option[Location]): Unit = {
+    if (logger.isDebugEnabled) {
+      logger.debug(s"${Pretty.prettyLoc(optLocation).renderWideStream.mkString}: $message")
+    }
+    addToBuffer(message, optLocation)
+  }
+
+  def addWarning(message: String, optLocation: Option[Location]): Unit = {
+    if (logger.isWarnEnabled) {
+      logger.warn(message)
+    }
+    addToBuffer(s"Warning: $message", optLocation)
+  }
+
   def iterator: Iterator[(String, Option[Location])] =
     new RingIterator(if (size < capacity) 0 else pos, size, buffer)
 }

daml-lf/interpreter/src/test/scala/com/digitalasset/daml/lf/speedy/InterpreterTest.scala

@@ -158,17 +158,17 @@ class InterpreterTest extends AnyWordSpec with Matchers with TableDrivenProperty
     }
     "half full" in {
       val log = RingBufferTraceLog(logger, 2)
-      log.add("test", None)
+      log.addDebug("test", None)
       val iter = log.iterator
       iter.hasNext shouldBe true
       iter.next() shouldBe (("test", None))
       iter.hasNext shouldBe false
     }
     "overflow" in {
       val log = RingBufferTraceLog(logger, 2)
-      log.add("test1", None)
-      log.add("test2", None)
-      log.add("test3", None) // should replace "test1"
+      log.addDebug("test1", None)
+      log.addDebug("test2", None)
+      log.addDebug("test3", None) // should replace "test1"
       val iter = log.iterator
       iter.hasNext shouldBe true
       iter.next() shouldBe (("test2", None))