[Forward-port][Upgrades testing] Add cases for unchanged key type with changed key expression

sdk/daml-script/test/daml/upgrades/ContractKeys.daml

@@ -3,15 +3,64 @@
 
 module ContractKeys (main) where
 
+import DA.Text (isInfixOf)
+
 import UpgradeTestLib
+
 import qualified V1.ContractKeys as V1
 import qualified V2.ContractKeys as V2
+import qualified V1.ChangedKeyExpr as V1
+import qualified V2.ChangedKeyExpr as V2
+import qualified V1.UpgradedContractKeys as V1
+import qualified V2.UpgradedContractKeys as V2
 
 {- PACKAGE
 name: contract-key-upgrades
 versions: 2
 -}
 
+main : TestTree
+main = tests
+  [ subtree "Unchanged key type"
+    [ subtree "Unchanged key expression"
+      [ ("queryContractKey, src=v1 tgt=v2", queryKeyUnchanged)
+      , ("exerciseByKeyCmd, src=v1 tgt=v2", exerciseCmdKeyUnchanged)
+      , ("fetchByKey, src=v1 tgt=v2 ", fetchKeyUnchanged)
+      , ("exerciseByKey, src=v1 tgt=v2", exerciseUpdateKeyUnchanged)
+      ]
+    , subtree "Changed key expression"
+      [ subtree "Unchanged key value"
+        [ ("queryContractId, src=v1 tgt=v2", queryKeyChangedExprSameValue)
+        , ("queryContractKey, src=v1 tgt=v2", qckKeyChangedExprSameValue)
+        , ("fetch, src=v1 tgt=v2", fetchKeyChangedExprSameValue)
+        , ("fetchByKey, src=v1 tgt=v2", fbkKeyChangedExprSameValue)
+        , ("exercise, src=v1 tgt=v2", exerciseKeyChangedExprSameValue)
+        , ("exerciseByKey, src=v1 tgt=v2", ebkKeyChangedExprSameValue)
+        , ("exerciseCmd, src=v1 tgt=v2", exerciseCmdKeyChangedExprSameValue)
+        , ("exerciseByKeyCmd, src=v1 tgt=v2", ebkCmdKeyChangedExprSameValue)
+        ]
+      , subtree "Changed key value"
+        [ broken ("queryContractId, src=v1 tgt=v2", queryKeyChangedExprChangedValue)
+        , broken ("queryContractKey, src=v1 tgt=v2", qckKeyChangedExprChangedValue)
+        , ("fetch, src=v1 tgt=v2", fetchKeyChangedExprChangedValue)
+        , broken ("fetchByKey, src=v1 tgt=v2", fbkKeyChangedExprChangedValue)
+        , ("exercise, src=v1 tgt=v2", exerciseKeyChangedExprChangedValue)
+        , broken ("exerciseByKey, src=v1 tgt=v2", ebkKeyChangedExprChangedValue)
+        , ("exerciseCmd, src=v1 tgt=v2", exerciseCmdKeyChangedExprChangedValue)
+        , broken ("exerciseByKeyCmd, src=v1 tgt=v2", ebkCmdKeyChangedExprChangedValue)
+        ]
+      ]
+    ]
+  , subtree "Changed key type"
+    [ subtree "Unchanged key value (modulo trailing `None`s)"
+      [ ("queryContractKey, src=v1 tgt=v2", queryKeyUpgraded)
+      , ("exerciseByKeyCmd, src=v1 tgt=v2", exerciseCmdKeyUpgraded)
+      , ("fetch, src=v1 tgt=v2", fetchKeyUpgraded)
+      , ("exerciseByKey, src=v1 tgt=v2", exerciseUpdateKeyUpgraded)
+      ]
+    ]
+  ]
+
 {- MODULE
 package: contract-key-upgrades
 contents: |
@@ -53,14 +102,6 @@ contents: |
         do exerciseByKey @UnchangedKey k UnchangedKeyCall
 -}
 
-main : TestTree
-main = tests
-  [ ("Query an unchanged old key for a new contract", queryKeyUnchanged)
-  , ("ExerciseByKey command an unchanged old key for a new contract", exerciseCmdKeyUnchanged)
-  , ("Fetching an unchanged old key for a new contract", fetchKeyUnchanged)
-  , ("ExerciseByKey in Update an unchanged old key for a new contract", exerciseUpdateKeyUnchanged)
-  ]
-
 queryKeyUnchanged : Test
 queryKeyUnchanged = test $ do
   a <- allocateParty "alice"
@@ -92,3 +133,258 @@ exerciseUpdateKeyUnchanged = test $ do
   res <- a `submit` createAndExerciseCmd (V2.UnchangedKeyHelper a) (V2.UnchangedKeyExercise $ V2.UnchangedKeyKey a 1)
   res === "V2"
 
+{- MODULE
+package: contract-key-upgrades
+contents: |
+  module ChangedKeyExpr where
+
+  data ChangedKeyExprKey = ChangedKeyExprKey with
+      p : Party
+      b : Bool
+    deriving (Eq, Show)
+
+  template ChangedKeyExpr
+    with
+      party : Party
+      b : Bool
+    where
+      signatory party
+      key (ChangedKeyExprKey party False) : ChangedKeyExprKey -- @V 1
+      key (ChangedKeyExprKey party b)     : ChangedKeyExprKey -- @V  2
+      maintainer key.p
+
+      choice ChangedKeyExprCall : Text
+        controller party
+        do pure "V1"                                          -- @V 1
+        do pure "V2"                                          -- @V  2
+
+  template ChangedKeyExprHelper
+    with
+      party : Party
+    where
+      signatory party
+
+      choice ChangedKeyExprFetch : ChangedKeyExpr with
+          cid : ContractId ChangedKeyExpr
+        controller party
+        do fetch cid
+
+      choice ChangedKeyExprFetchByKey : (ContractId ChangedKeyExpr, ChangedKeyExpr) with
+          k : ChangedKeyExprKey
+        controller party
+        do fetchByKey k
+
+      choice ChangedKeyExprExercise : Text with
+          cid : ContractId ChangedKeyExpr
+        controller party
+        do exercise @ChangedKeyExpr cid ChangedKeyExprCall
+
+      choice ChangedKeyExprExerciseByKey : Text with
+          k : ChangedKeyExprKey
+        controller party
+        do exerciseByKey @ChangedKeyExpr k ChangedKeyExprCall
+-}
+
+qckKeyChangedExprSameValue : Test
+qckKeyChangedExprSameValue = test $ do
+  a <- allocateParty "alice"
+  cid <- a `submit` createExactCmd (V1.ChangedKeyExpr a False)
+  keyRes <- queryContractKey a $ V2.ChangedKeyExprKey a False
+  case keyRes of
+    Some (foundCid, foundContract) | show foundCid == show cid && foundContract == V2.ChangedKeyExpr a False -> pure ()
+    _ -> assertFail $ "Didn't find correct contract, expected " <> show (cid, V2.ChangedKeyExpr a False) <> ", got " <> show keyRes
+
+queryKeyChangedExprSameValue : Test
+queryKeyChangedExprSameValue = test $ do
+  a <- allocateParty "alice"
+  cid <- a `submit` createExactCmd (V1.ChangedKeyExpr a False)
+  res <- queryContractId a (coerceContractId @_ @V2.ChangedKeyExpr cid)
+  case res of
+    Some foundContract | foundContract == V2.ChangedKeyExpr a False -> pure ()
+    _ -> assertFail $ "Didn't find correct contract, expected " <> show (V2.ChangedKeyExpr a False) <> ", got " <> show res
+
+qckKeyChangedExprChangedValue : Test
+qckKeyChangedExprChangedValue = test $ do
+  a <- allocateParty "alice"
+  cid <- a `submit` createExactCmd (V1.ChangedKeyExpr a True)
+  -- the following query works, even though the key value changed!
+  r <- queryContractKey @V2.ChangedKeyExpr a $ V2.ChangedKeyExprKey a False
+  r === None
+
+queryKeyChangedExprChangedValue : Test
+queryKeyChangedExprChangedValue = test $ do
+  a <- allocateParty "alice"
+  cid <- a `submit` createExactCmd (V1.ChangedKeyExpr a True)
+  -- the following query works, even though the key value changed!
+  r <- queryContractId a (coerceContractId @_ @V2.ChangedKeyExpr cid)
+  r === None
+
+fetchKeyChangedExprSameValue : Test
+fetchKeyChangedExprSameValue = test $ do
+  a <- allocateParty "alice"
+  cid <- a `submit` createExactCmd (V1.ChangedKeyExpr a False)
+  foundContract <- a `submit` createAndExerciseCmd (V2.ChangedKeyExprHelper a) (V2.ChangedKeyExprFetch $ coerceContractId cid)
+  foundContract === V2.ChangedKeyExpr a False
+
+fetchKeyChangedExprChangedValue : Test
+fetchKeyChangedExprChangedValue = test $ do
+  a <- allocateParty "alice"
+  cid <- a `submit` createExactCmd (V1.ChangedKeyExpr a True)
+  expectKeyChangedError =<<
+    a `trySubmit` createAndExerciseCmd (V2.ChangedKeyExprHelper a) (V2.ChangedKeyExprFetch $ coerceContractId cid)
+
+fbkKeyChangedExprSameValue : Test
+fbkKeyChangedExprSameValue = test $ do
+  a <- allocateParty "alice"
+  cid <- a `submit` createExactCmd (V1.ChangedKeyExpr a False)
+  (foundCid, foundContract) <- a `submit` createAndExerciseCmd (V2.ChangedKeyExprHelper a) (V2.ChangedKeyExprFetchByKey $ V2.ChangedKeyExprKey a False)
+  foundContract === V2.ChangedKeyExpr a False
+  show foundCid === show cid
+
+fbkKeyChangedExprChangedValue : Test
+fbkKeyChangedExprChangedValue = test $ do
+  a <- allocateParty "alice"
+  cid <- a `submit` createExactCmd (V1.ChangedKeyExpr a True)
+  -- the fetch inside the following command works, even though the key value changed!
+  expectKeyChangedError =<<
+    a `trySubmit` createAndExerciseCmd (V2.ChangedKeyExprHelper a) (V2.ChangedKeyExprFetchByKey $ V2.ChangedKeyExprKey a False)
+
+exerciseKeyChangedExprSameValue : Test
+exerciseKeyChangedExprSameValue = test $ do
+  a <- allocateParty "alice"
+  cid <- a `submit` createExactCmd (V1.ChangedKeyExpr a False)
+  res <- a `submit` createAndExerciseCmd (V2.ChangedKeyExprHelper a) (V2.ChangedKeyExprExercise $ coerceContractId cid)
+  res === "V2"
+
+ebkKeyChangedExprSameValue : Test
+ebkKeyChangedExprSameValue = test $ do
+  a <- allocateParty "alice"
+  _ <- a `submit` createExactCmd (V1.ChangedKeyExpr a False)
+  res <- a `submit` createAndExerciseCmd (V2.ChangedKeyExprHelper a) (V2.ChangedKeyExprExerciseByKey $ V2.ChangedKeyExprKey a False)
+  res === "V2"
+
+exerciseCmdKeyChangedExprSameValue : Test
+exerciseCmdKeyChangedExprSameValue = test $ do
+  a <- allocateParty "alice"
+  cid <- a `submit` createExactCmd (V1.ChangedKeyExpr a False)
+  res <- a `submit` exerciseExactCmd @V2.ChangedKeyExpr (coerceContractId cid) V2.ChangedKeyExprCall
+  res === "V2"
+
+ebkCmdKeyChangedExprSameValue : Test
+ebkCmdKeyChangedExprSameValue = test $ do
+  a <- allocateParty "alice"
+  _ <- a `submit` createExactCmd (V1.ChangedKeyExpr a False)
+  res <- a `submit` exerciseByKeyExactCmd @V2.ChangedKeyExpr (V2.ChangedKeyExprKey a False) V2.ChangedKeyExprCall
+  res === "V2"
+
+exerciseKeyChangedExprChangedValue : Test
+exerciseKeyChangedExprChangedValue = test $ do
+  a <- allocateParty "alice"
+  cid <- a `submit` createExactCmd (V1.ChangedKeyExpr a True)
+  expectKeyChangedError =<<
+    a `trySubmit` createAndExerciseCmd (V2.ChangedKeyExprHelper a) (V2.ChangedKeyExprExercise $ coerceContractId cid)
+
+ebkKeyChangedExprChangedValue : Test
+ebkKeyChangedExprChangedValue = test $ do
+  a <- allocateParty "alice"
+  _ <- a `submit` createExactCmd (V1.ChangedKeyExpr a True)
+  expectKeyChangedError =<<
+    a `trySubmit` createAndExerciseCmd (V2.ChangedKeyExprHelper a) (V2.ChangedKeyExprExerciseByKey $ V2.ChangedKeyExprKey a False)
+
+exerciseCmdKeyChangedExprChangedValue : Test
+exerciseCmdKeyChangedExprChangedValue = test $ do
+  a <- allocateParty "alice"
+  cid <- a `submit` createExactCmd (V1.ChangedKeyExpr a True)
+  expectKeyChangedError =<<
+    a `trySubmit` exerciseExactCmd @V2.ChangedKeyExpr (coerceContractId cid) V2.ChangedKeyExprCall
+
+ebkCmdKeyChangedExprChangedValue : Test
+ebkCmdKeyChangedExprChangedValue = test $ do
+  a <- allocateParty "alice"
+  _ <- a `submit` createExactCmd (V1.ChangedKeyExpr a True)
+  expectKeyChangedError =<<
+    a `trySubmit` exerciseByKeyExactCmd @V2.ChangedKeyExpr (V2.ChangedKeyExprKey a False) V2.ChangedKeyExprCall
+
+{- MODULE
+package: contract-key-upgrades
+contents: |
+  module UpgradedContractKeys where
+
+  data UpgradedKeyKey = UpgradedKeyKey with
+      p : Party
+      n : Int
+      m : Optional Int                                -- @V 2
+    deriving (Eq, Show)
+
+  template UpgradedKey
+    with
+      party : Party
+      n : Int
+      m : Optional Int                                -- @V 2
+    where
+      signatory party
+      key (UpgradedKeyKey party n) : UpgradedKeyKey   -- @V 1
+      key (UpgradedKeyKey party n m) : UpgradedKeyKey -- @V 2
+      maintainer key.p
+
+      choice UpgradedKeyCall : Text
+        controller party
+        do pure "V1"                                  -- @V 1
+        do pure "V2"                                  -- @V 2
+
+  template UpgradedKeyHelper
+    with
+      party : Party
+    where
+      signatory party
+      choice UpgradedKeyFetch : (ContractId UpgradedKey, UpgradedKey) with
+          k : UpgradedKeyKey
+        controller party
+        do fetchByKey k
+
+      choice UpgradedKeyExercise : Text with
+          k : UpgradedKeyKey
+        controller party
+        do exerciseByKey @UpgradedKey k UpgradedKeyCall
+-}
+
+queryKeyUpgraded : Test
+queryKeyUpgraded = test $ do
+  a <- allocateParty "alice"
+  cid <- a `submit` createExactCmd (V1.UpgradedKey a 1)
+  keyRes <- queryContractKey a $ V2.UpgradedKeyKey a 1 None
+  case keyRes of
+    Some (foundCid, foundContract) | show foundCid == show cid && foundContract == V2.UpgradedKey a 1 None -> pure ()
+    _ -> assertFail $ "Didn't find correct contract, expected " <> show (cid, V2.UpgradedKey a 1 None) <> ", got " <> show keyRes
+
+exerciseCmdKeyUpgraded : Test
+exerciseCmdKeyUpgraded = test $ do
+  a <- allocateParty "alice"
+  cid <- a `submit` createExactCmd (V1.UpgradedKey a 1)
+  res <- a `submit` exerciseByKeyExactCmd @V2.UpgradedKey (V2.UpgradedKeyKey a 1 None) V2.UpgradedKeyCall
+  res === "V2"
+
+fetchKeyUpgraded : Test
+fetchKeyUpgraded = test $ do
+  a <- allocateParty "alice"
+  cid <- a `submit` createCmd (V1.UpgradedKey a 1)
+  (foundCid, foundContract) <- a `submit` createAndExerciseCmd (V2.UpgradedKeyHelper a) (V2.UpgradedKeyFetch $ V2.UpgradedKeyKey a 1 None)
+  foundContract === V2.UpgradedKey a 1 None
+  show foundCid === show cid
+
+exerciseUpdateKeyUpgraded : Test
+exerciseUpdateKeyUpgraded = test $ do
+  a <- allocateParty "alice"
+  _ <- a `submit` createCmd (V1.UpgradedKey a 1)
+  res <- a `submit` createAndExerciseCmd (V2.UpgradedKeyHelper a) (V2.UpgradedKeyExercise $ V2.UpgradedKeyKey a 1 None)
+  res === "V2"
+
+------------------------------------------------------------------------------------------------------------------------
+
+expectKeyChangedError : Either SubmitError a -> Script ()
+expectKeyChangedError r = case r of
+    Right _ -> assertFail "Expected failure but got success"
+    Left (DevError Upgrade msg)
+      | "Verify that neither the signatories, nor the observers, nor the contract key, nor the key's maintainers have changed" `isInfixOf` msg
+      -> pure ()
+    Left e -> assertFail $ "Expected Upgrade error but got " <> show e