DRAFT: daml for confirmation response traffic reimbursement

daml/splice-amulet/daml/Splice/AmuletRules.daml

@@ -233,6 +233,7 @@ template AmuletRules
           numPurchases = 1
           amuletSpent = trafficCostAmulet
           usdSpent =  trafficCostUsd
+          totalReimbursed = None
         -- return result
         return AmuletRules_BuyMemberTrafficResult with
           round = transferResult.round
@@ -270,6 +271,11 @@ template AmuletRules
                 numPurchases = acc.numPurchases + traffic.numPurchases
                 usdSpent = acc.usdSpent + traffic.usdSpent
                 amuletSpent = acc.amuletSpent + traffic.amuletSpent
+                totalReimbursed = case (acc.totalReimbursed, traffic.totalReimbursed) of
+                  (None, None) -> None
+                  (Some a, None) -> Some a
+                  (None, Some b) -> Some b
+                  (Some a, Some b) -> Some (a + b)
               ) (initialMemberTraffic dso first.memberId first.synchronizerId first.migrationId) traffics
         mergedTrafficCid <- create mergedTraffic
         return AmuletRules_MergeMemberTrafficContractsResult with ..

daml/splice-amulet/daml/Splice/DecentralizedSynchronizer.daml

@@ -64,6 +64,7 @@ template MemberTraffic with
     numPurchases : Int -- ^ Number of times extra traffic has been purchased
     amuletSpent : Decimal -- ^ Total Amulet spent on extra traffic
     usdSpent : Decimal -- ^ Total USD spent on extra traffic
+    totalReimbursed : Optional Int -- ^ The number of bytes of response traffic reimbursed to this member.
   where
     signatory dso
 
@@ -86,6 +87,7 @@ initialMemberTraffic dso memberId synchronizerId migrationId = MemberTraffic wit
     numPurchases = 0
     amuletSpent = 0.0
     usdSpent = 0.0
+    totalReimbursed = None
 
 data ForMemberTraffic = ForMemberTraffic with
     dso : Party

daml/splice-dso-governance-test/daml/Splice/Scripts/DsoTestUtils.daml

@@ -293,6 +293,19 @@ confirmAWC_MiningRound_Archive app = do
           confirmer = sv
         pure ()
 
+-- | Convenience function to confirm and execute an action requiring confirmation.
+confirmAndExecutionAction : AmuletApp -> ActionRequiringConfirmation -> Script ()
+confirmAndExecutionAction app action = do
+  [(dsoRulesCid, rules)] <- query @DsoRules app.dso
+  forA_ (Map.keys rules.svs) $ \sv -> do
+    -- mallory does not act
+    unless ("mallory" `T.isPrefixOf` partyToText sv) $ do
+      submitMulti [sv] [app.dso] $ exerciseCmd dsoRulesCid DsoRules_ConfirmAction with
+        action
+        confirmer = sv
+      pure ()
+  executeAllConfirmedActions app
+
 executeAllConfirmedActions : AmuletApp -> Script ()
 executeAllConfirmedActions app = do
   [(amuletRulesCid, _)] <- query @AmuletRules app.dso

daml/splice-dso-governance-test/daml/Splice/Scripts/TestResponseReimbursement.daml

@@ -0,0 +1,108 @@
+-- Copyright (c) 2024 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
+-- SPDX-License-Identifier: Apache-2.0
+
+module Splice.Scripts.TestResponseReimbursement where
+
+import DA.Assert
+import DA.List
+import Daml.Script
+import DA.Time
+
+import Splice.DsoRules
+import Splice.DSO.ResponseReimbursement -- FIXME: add Traffic to name
+import Splice.DSO.CryptoHash
+import Splice.DecentralizedSynchronizer
+
+import Splice.Scripts.Util
+import Splice.Scripts.DsoTestUtils
+
+
+-- | Tests that reimbursement works.
+test_confirmation_response_traffic_reimbursement : Script ()
+test_confirmation_response_traffic_reimbursement = do
+  (app, dso, (sv1, _, _, _)) <- initMainNet
+
+  setTime demoTime
+
+  [(dsoRulesCid, dsoRules)] <- query @DsoRules dso
+
+  -- setup demo data
+  let responseTrafficDataRaw = sortOn fst
+        [ ("PAR::1", 1000)
+        , ("PAR::2", 2000)
+        , ("PAR::3", 3000)
+        , ("PAR::4", 4000)
+        ]
+  let responseTrafficData = ResponseTrafficData with
+        responseTrafficTotals = map (uncurry ResponseTrafficTotal) responseTrafficDataRaw
+  let responseTrafficDataHash = hash responseTrafficData
+  let reimbursementConfirmation = ReimbursementConfirmation with
+        synchronizerId = dsoRules.config.decentralizedSynchronizer.activeSynchronizerId
+        migrationId = 0
+        responseTrafficDataHash
+
+  -- setup reimbursement workflow state
+  confirmAndExecutionAction app ARC_DsoRules with
+    dsoAction = SRARC_StartResponseTrafficReimbursement
+      DsoRules_StartResponseTrafficReimbursement
+
+  -- add a new interval
+  now <- getTime
+  let testIntervalEnd = now `addRelTime` hours 1
+  [(workflowStateCid, _)] <- query @ReimbursementWorkflowState dso
+  confirmAndExecutionAction app ARC_DsoRules with
+    dsoAction = SRARC_AddResponseTrafficReimbursementInterval
+      DsoRules_AddResponseTrafficReimbursementInterval with
+        nextIntervalEnd = testIntervalEnd
+        workflowStateCid
+
+  -- confirm data
+  [(intervalStateCid, _)] <- query @ReimbursementIntervalState dso
+  confirmAndExecutionAction app ARC_DsoRules with
+    dsoAction = SRARC_ConfirmResponseTrafficReimbursement
+      DsoRules_ConfirmResponseTrafficReimbursement with
+        intervalStateCid
+        reimbursementConfirmation
+
+  -- check that there are no member traffic contracts yet
+  [] <- query @MemberTraffic dso
+
+  -- reimburse responses
+  [(intervalStateCid, _)] <- query @ReimbursementIntervalState dso
+  submitMulti [sv1] [app.dso] $ exerciseCmd dsoRulesCid DsoRules_ReimburseResponseTraffic with
+    intervalStateCid
+    responseTrafficData
+    sv = sv1
+
+  -- check that the expected member traffic contracts were created
+  actualMemberTrafficContracts <- query @MemberTraffic dso
+  let expectedMemberTrafficContracts = do
+        (memberId, totalTraffic) <- responseTrafficDataRaw
+        pure MemberTraffic with
+          dso = dso
+          memberId
+          synchronizerId = reimbursementConfirmation.synchronizerId
+          migrationId = reimbursementConfirmation.migrationId
+          totalReimbursed = Some totalTraffic
+          totalPurchased = 0
+          amuletSpent = 0.0
+          usdSpent = 0.0
+          numPurchases = 0
+  sortOn (.memberId) (map snd actualMemberTrafficContracts) ===
+    expectedMemberTrafficContracts
+
+  -- record the completion
+  [(intervalStateCid, _)] <- query @ReimbursementIntervalState dso
+  [(workflowStateCid, _)] <- query @ReimbursementWorkflowState dso
+  submitMulti [sv1] [app.dso] $ exerciseCmd dsoRulesCid DsoRules_RecordCompletedResponseTrafficReimbursement with
+    intervalStateCid
+    workflowStateCid
+    sv = sv1
+
+  [] <- query @ReimbursementIntervalState dso
+  [(_, workflowState)] <- query @ReimbursementWorkflowState dso
+  (workflowState.earliestIntervalStart, workflowState.nextIntervalStart) ===
+    (testIntervalEnd, testIntervalEnd)
+
+
+  pure ()

daml/splice-dso-governance/daml/Splice/DSO/CryptoHash.daml

@@ -0,0 +1,108 @@
+-- Copyright (c) 2024 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
+-- SPDX-License-Identifier: Apache-2.0
+
+-- | Utilities to compute cryptographic hashes of Daml data structures.
+-- We use this for example for computing compact commitments for moving
+-- off-ledger data shared by the SV nodes on-ledger.
+module Splice.DSO.CryptoHash
+  (
+    Hash(..),
+    Hashable(..),
+    hashRecord,
+    hashUpgradedRecord,
+    hashVariant,
+    hashUpgradedVariant,
+  ) where
+
+import DA.Optional (isNone)
+import DA.Text qualified as T
+
+data Hash = Hash with value : Text
+  deriving (Eq, Show)
+
+-- | Compute the hash of a record.
+hashRecord : [Hash] -> Hash
+hashRecord = hashListInternal . map (.value)
+
+-- | Compute the hash of an upgraded record so that it agrees with the old record hash
+-- when ignoring trailing None fields.
+hashUpgradedRecord : [Hash] -> [Optional Hash] -> Hash
+hashUpgradedRecord oldFieldHashes newFieldHashes =
+  hashListInternal $
+    [ h.value | h <- oldFieldHashes ] ++
+    [ (hashOptionalInternal optField).value | optField <- dropTrailingNones newFieldHashes ]
+
+-- | Compute the hash of a variant.
+hashVariant : Text -> [Hash] -> Hash
+hashVariant tag fieldHashes = hashVariantInternal tag [ h.value | h <- fieldHashes ]
+
+-- | Compute the hash of an upgraded variant so that it agrees with the old variant hash
+-- when ignoring trailing None fields.
+hashUpgradedVariant : Text -> [Hash] -> [Optional Hash] -> Hash
+hashUpgradedVariant tag oldFieldHashes newFieldHashes =
+  hashVariantInternal tag $
+    [ h.value | h <- oldFieldHashes ] ++
+    [ (hashOptionalInternal optField).value | optField <- dropTrailingNones newFieldHashes ]
+
+class Hashable a where
+  hash : a -> Hash
+
+-- | Identity instance for Hash, which is useful for hash types like [Hash].
+instance Hashable Hash where
+  hash h = h
+
+instance Hashable Int where
+  hash = hashInt
+
+instance Hashable Text where
+  hash = hashText
+
+instance Hashable a => Hashable (Optional a) where
+  hash = hashOptionalInternal . fmap hash
+
+instance Hashable a => Hashable [a] where
+  hash = hashList hash
+
+
+-- internal helper functions
+----------------------------
+
+-- Design Note: we want these hashes to be easy to compute in many systems.
+-- Therefore we essentially encode the data structure as an S-expression and hash that
+-- one recursively. Concretely, we use the following rules:
+--
+--   - hash scalars by hashing their string rendering
+--   - hash lists by hashing the concatenation of the length and the element hashes
+--   - hash records by hashing the list of field hashes
+--   - hash variants by hashing the list of fields prefixed with tag for the variant constructor
+--
+-- The length prefix on lists also serves as a tag to distinguish different tree structures.
+-- We include the number of fields in the hash of a record, as the number of fields
+-- can change as part of a Smart Contract Upgrades.
+--
+-- Tags for variants must be unique within the scope where the hashes are used.
+
+
+hashList : (a -> Hash) -> [a] -> Hash
+hashList hashElem xs = hashListInternal [ (hashElem x).value | x <- xs ]
+
+hashInt : Int -> Hash
+hashInt n = Hash $ T.sha256 (show n)
+
+hashText : Text -> Hash
+hashText = Hash . T.sha256
+
+hashListInternal : [Text] -> Hash
+hashListInternal ts = Hash $ T.sha256 $ mconcat (show (length ts) :: "|" :: ts)
+
+hashVariantInternal : Text -> [Text] -> Hash
+hashVariantInternal tag fieldValues =
+  Hash $ T.sha256 $ mconcat (tag :: "|" :: show (length fieldValues) :: "|" :: fieldValues)
+
+-- we view optionals as lists of length 0 or 1 to simplify the encoding in other systems
+hashOptionalInternal : Optional Hash -> Hash
+hashOptionalInternal None = hashListInternal []
+hashOptionalInternal (Some h) = hashListInternal [h.value]
+
+dropTrailingNones : [Optional Hash] -> [Optional Hash]
+dropTrailingNones = reverse . dropWhile isNone . reverse