add test cases demonstrating key collisions

Author: paulbrauner-da

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

@@ -18,9 +18,14 @@ import qualified V1.ChangedMaintainersExpr as V1
 import qualified V2.ChangedMaintainersExpr as V2
 import qualified V1.UpgradedContractKeys as V1
 import qualified V2.UpgradedContractKeys as V2
+import qualified V1.InvalidKeyUpgrade as V1
+import qualified V2.InvalidKeyUpgrade as V2
+import qualified V1.InvalidKeyRenaming as V1
+import qualified V2.InvalidKeyRenaming as V2
 import qualified V1.ContractKeyPresence as V1
 import qualified V2.ContractKeyPresence as V2
 import qualified V1.IfaceMod as Iface
+import qualified V1.KeyUpgradeClient as Client
 
 {- PACKAGE
 name: contract-key-upgrades-iface
@@ -107,14 +112,26 @@ main = tests
         ]
       ]
     ]
-  , subtree "Changed key type"
+  , subtree "Changed key type, valid upgrade"
     [ 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)
       ]
     ]
+  , subtree "Changed key type, invalid upgrade"
+    [ broken ("queryContractKeyCmd, global", queryInvalidKeyUpgradeGlobal)
+    , broken ("exerciseByKeyCmd, global", exerciseInvalidKeyUpgradeGlobal)
+    , broken ("fetch, local", fetchInvalidKeyUpgradeLocal)
+    , broken ("exerciseByKey, local", exerciseInvalidKeyUpgradeLocal)
+    ]
+  , subtree "Renamed key label, invalid upgrade"
+    [ broken ("queryContractKeyCmd, global", queryInvalidKeyRenamingGlobal)
+    , broken ("exerciseByKeyCmd, global", exerciseInvalidKeyRenamingGlobal)
+    , broken ("fetch, local", fetchInvalidKeyRenamingLocal)
+    , broken ("exerciseByKey, local", exerciseInvalidKeyRenamingLocal)
+    ]
   , subtree "Changed key presence"
     [ subtree "Key in v1, no key in v2"
       [ ("fetch", fetchTemplateWithUnexpectedKey)
@@ -666,6 +683,182 @@ exerciseUpdateKeyUpgraded = test $ do
   res <- a `submit` createAndExerciseCmd (V2.UpgradedKeyHelper a) (V2.UpgradedKeyExercise $ V2.UpgradedKeyKey a 1 None)
   res === "V2"
 
+{- MODULE
+package: contract-key-upgrades
+contents: |
+  module InvalidKeyUpgrade where
+
+  data InvalidKeyUpgradeKey = InvalidKeyUpgradeKey with
+      p : Party
+      n : Int                -- @V 1
+      n : Bool               -- @V 2
+    deriving (Eq, Show)
+
+  template InvalidKeyUpgrade
+    with
+      party : Party
+    where
+      signatory party
+      key (InvalidKeyUpgradeKey party 0) : InvalidKeyUpgradeKey     -- @V 1
+      key (InvalidKeyUpgradeKey party False) : InvalidKeyUpgradeKey -- @V 2
+      maintainer key.p
+
+      choice InvalidKeyUpgradeCall : Text
+        controller party
+        do pure (show (key this).n)
+-}
+
+{- MODULE
+package: contract-key-upgrades
+contents: |
+  module InvalidKeyRenaming where
+
+  data InvalidKeyRenamingKey = InvalidKeyRenamingKey with
+      p : Party
+      n : Int                -- @V 1
+      m : Int                -- @V 2
+    deriving (Eq, Show)
+
+  template InvalidKeyRenaming
+    with
+      party : Party
+    where
+      signatory party
+      key (InvalidKeyRenamingKey party 42) : InvalidKeyRenamingKey
+      maintainer key.p
+
+      choice InvalidKeyRenamingCall : Int
+        controller party
+        do
+          pure (key this).n  -- @V 1
+          pure (key this).m  -- @V 2
+-}
+
+{- PACKAGE
+name: contract-key-upgrades-client
+versions: 1
+depends: |
+  contract-key-upgrades-1.0.0
+  contract-key-upgrades-2.0.0
+-}
+
+{- MODULE
+package: contract-key-upgrades-client
+contents: |
+  module KeyUpgradeClient where
+
+  import V1.InvalidKeyUpgrade as V1
+  import V2.InvalidKeyUpgrade as V2
+  import V1.InvalidKeyRenaming as V1
+  import V2.InvalidKeyRenaming as V2
+
+  template KeyUpgradeClient
+    with
+      party : Party
+    where
+      signatory party
+
+      -- InvalidKeyUpgrade
+
+      choice InvalidKeyUpgradeFetch : (ContractId V2.InvalidKeyUpgrade, V2.InvalidKeyUpgrade)
+        controller party
+        do
+          cid <- create (V1.InvalidKeyUpgrade party)
+          fetchByKey (V2.InvalidKeyUpgradeKey party False)
+
+      choice InvalidKeyUpgradeExercise : Text
+        controller party
+        do
+          cid <- create (V1.InvalidKeyUpgrade party)
+          exerciseByKey @V2.InvalidKeyUpgrade (V2.InvalidKeyUpgradeKey party False) V2.InvalidKeyUpgradeCall
+
+      -- InvalidKeyRenaming
+
+      choice InvalidKeyRenamingFetch : (ContractId V2.InvalidKeyRenaming, V2.InvalidKeyRenaming)
+        controller party
+        do
+          cid <- create (V1.InvalidKeyRenaming party)
+          fetchByKey (V2.InvalidKeyRenamingKey party 42)
+
+      choice InvalidKeyRenamingExercise : Int
+        controller party
+        do
+          cid <- create (V1.InvalidKeyRenaming party)
+          exerciseByKey @V2.InvalidKeyRenaming (V2.InvalidKeyRenamingKey party 42) V2.InvalidKeyRenamingCall
+-}
+
+-- InvalidKeyUpgrade
+
+queryInvalidKeyUpgradeGlobal : Test
+queryInvalidKeyUpgradeGlobal = test $ do
+  a <- allocateParty "alice"
+  cid <- a `submit` createExactCmd (V1.InvalidKeyUpgrade a)
+  keyRes <- queryContractKey @V2.InvalidKeyUpgrade a $ V2.InvalidKeyUpgradeKey a False
+  case keyRes of
+    None -> pure ()
+    _ -> assertFail ("Expected None (key not found), but got: " <> show keyRes)
+
+exerciseInvalidKeyUpgradeGlobal : Test
+exerciseInvalidKeyUpgradeGlobal = test $ do
+  a <- allocateParty "alice"
+  cid <- a `submit` createExactCmd (V1.InvalidKeyUpgrade a)
+  res <- a `trySubmit` exerciseByKeyExactCmd @V2.InvalidKeyUpgrade (V2.InvalidKeyUpgradeKey a False) V2.InvalidKeyUpgradeCall
+  case res of
+    Left (ContractKeyNotFound _) -> pure ()
+    _ -> assertFail ("Expected ContractKeyNotFound, but got: " <> show res)
+    
+fetchInvalidKeyUpgradeLocal : Test
+fetchInvalidKeyUpgradeLocal = test $ do
+  a <- allocateParty "alice"
+  res <- a `trySubmit` createAndExerciseCmd (Client.KeyUpgradeClient a) Client.InvalidKeyUpgradeFetch
+  case res of
+    Left (ContractKeyNotFound _) -> pure ()
+    _ -> assertFail ("Expected ContractKeyNotFound, but got: " <> show res)
+
+exerciseInvalidKeyUpgradeLocal : Test
+exerciseInvalidKeyUpgradeLocal = test $ do
+  a <- allocateParty "alice"
+  res <- a `trySubmit` createAndExerciseCmd (Client.KeyUpgradeClient a) Client.InvalidKeyUpgradeExercise
+  case res of
+    Left (ContractKeyNotFound _) -> pure ()
+    _ -> assertFail ("Expected ContractKeyNotFound, but got: " <> show res)
+
+-- InvalidKeyRenaming
+
+queryInvalidKeyRenamingGlobal : Test
+queryInvalidKeyRenamingGlobal = test $ do
+  a <- allocateParty "alice"
+  cid <- a `submit` createExactCmd (V1.InvalidKeyRenaming a)
+  keyRes <- queryContractKey @V2.InvalidKeyRenaming a $ V2.InvalidKeyRenamingKey a 42
+  case keyRes of
+    None -> pure ()
+    _ -> assertFail ("Expected None (key not found), but got: " <> show keyRes)
+
+exerciseInvalidKeyRenamingGlobal : Test
+exerciseInvalidKeyRenamingGlobal = test $ do
+  a <- allocateParty "alice"
+  cid <- a `submit` createExactCmd (V1.InvalidKeyRenaming a)
+  res <- a `trySubmit` exerciseByKeyExactCmd @V2.InvalidKeyRenaming (V2.InvalidKeyRenamingKey a 42) V2.InvalidKeyRenamingCall
+  case res of
+    Left (ContractKeyNotFound _) -> pure ()
+    _ -> assertFail ("Expected ContractKeyNotFound, but got: " <> show res)
+
+fetchInvalidKeyRenamingLocal : Test
+fetchInvalidKeyRenamingLocal = test $ do
+  a <- allocateParty "alice"
+  res <- a `trySubmit` createAndExerciseCmd (Client.KeyUpgradeClient a) Client.InvalidKeyRenamingFetch
+  case res of
+    Left (ContractKeyNotFound _) -> pure ()
+    _ -> assertFail ("Expected ContractKeyNotFound, but got: " <> show res)
+
+exerciseInvalidKeyRenamingLocal : Test
+exerciseInvalidKeyRenamingLocal = test $ do
+  a <- allocateParty "alice"
+  res <- a `trySubmit` createAndExerciseCmd (Client.KeyUpgradeClient a) Client.InvalidKeyRenamingExercise
+  case res of
+    Left (ContractKeyNotFound _) -> pure ()
+    _ -> assertFail ("Expected ContractKeyNotFound, but got: " <> show res)
+
 {- MODULE
 package: contract-key-upgrades
 contents: |