Fix name resolution within module redeploy (#1235)

* wip * add tests * add DisablePact48 flag * Factor out BareName resolve * address review comments * simplification * Fix incorrect module name * Use lens * Correct spelling * Add old behavior test case * add additional test * fix resolving of names without a namespace * add additional tests * add even more tests * cleanup * add missing tests * rephrase tests * fix spelling Signed-off-by: Robert Soeldner <r.soeldner@gmail.com> * address comments * add missing test redepl --------- Signed-off-by: Robert Soeldner <r.soeldner@gmail.com>
kadena-io · Jun 27, 2023 · 640e39d · 640e39d
1 parent e67bde8
commit 640e39d
Show file tree

Hide file tree

Showing 4 changed files with 131 additions and 17 deletions.
diff --git a/docs/en/pact-functions.md b/docs/en/pact-functions.md
@@ -1928,7 +1928,7 @@ Retreive any accumulated events and optionally clear event state. Object returne
  *&rarr;*&nbsp;`[string]`
 
 
-Queries, or with arguments, sets execution config flags. Valid flags: ["AllowReadInLocal","DisableHistoryInTransactionalMode","DisableInlineMemCheck","DisableModuleInstall","DisableNewTrans","DisablePact40","DisablePact420","DisablePact43","DisablePact431","DisablePact44","DisablePact45","DisablePact46","DisablePact47","DisablePactEvents","DisableRuntimeReturnTypeChecking","EnforceKeyFormats","OldReadOnlyBehavior","PreserveModuleIfacesBug","PreserveModuleNameBug","PreserveNsModuleInstallBug","PreserveShowDefs"]
+Queries, or with arguments, sets execution config flags. Valid flags: ["AllowReadInLocal","DisableHistoryInTransactionalMode","DisableInlineMemCheck","DisableModuleInstall","DisableNewTrans","DisablePact40","DisablePact420","DisablePact43","DisablePact431","DisablePact44","DisablePact45","DisablePact46","DisablePact47","DisablePact48","DisablePactEvents","DisableRuntimeReturnTypeChecking","EnforceKeyFormats","OldReadOnlyBehavior","PreserveModuleIfacesBug","PreserveModuleNameBug","PreserveNsModuleInstallBug","PreserveShowDefs"]
 ```lisp
 pact> (env-exec-config ['DisableHistoryInTransactionalMode]) (env-exec-config)
 ["DisableHistoryInTransactionalMode"]

diff --git a/src/Pact/Eval.hs b/src/Pact/Eval.hs
@@ -89,6 +89,7 @@ import Pact.Types.Purity
 import Pact.Types.Runtime
 import Pact.Types.SizeOf
 import Pact.Types.Namespace
+import Control.Applicative (liftA2)
 
 
 evalBeginTx :: Info -> Eval e (Maybe TxId)
@@ -320,6 +321,11 @@ eval' (TModule _tm@(MDModule m) bod i) =
         capMName <-
           ifExecutionFlagSet' FlagPreserveNsModuleInstallBug (_mName m) (_mName mangledM)
         void $ acquireModuleAdminCapability capMName $ return ()
+
+        unlessExecutionFlagSet FlagDisablePact48 $ do
+          evalRefs.rsLoadedModules %= HM.delete (_mName mangledM)
+          evalRefs.rsQualifiedDeps %= HM.filterWithKey (\k _ -> _fqModule k /= _mName mangledM)
+
     -- build/install module from defs
     (g,govM) <- loadModule mangledM bod i g0
     szVer <- getSizeOfVersion
@@ -737,27 +743,42 @@ fullyQualifyDefs info mdef defs = do
     checkAddDep = \case
       Direct (TVar (FQName fq) _) -> modify' (Set.insert (_fqModule fq))
       _ -> pure ()
-    -- | traverse to find deps and form graph
-    traverseGraph allDefs memo = fmap stronglyConnCompR $ forM (HM.toList allDefs) $ \(defName,defTerm) -> do
-      let defName' = FullyQualifiedName defName (_mName mdef) (moduleHash mdef)
-      defTerm' <- forM defTerm $ \(f :: Name) -> do
+
+    resolveBareName memo f@(BareName fn _) = case HM.lookup fn defs of
+      Just _ -> do
+        let name' = FullyQualifiedName fn (_mName mdef) (moduleHash mdef)
+        return (Left name') -- decl found
+      Nothing -> lift (resolveBareModRef info f fn memo (MDModule mdef)) >>= \case
+        Just mr -> return (Right mr) -- mod ref found
+        Nothing -> resolveError f
+
+    resolveError f = lift (evalError' f $ "Cannot resolve " <> dquotes (pretty f))
+
+    resolveName flagPact48Disabled memo = \case
+      (QName (QualifiedName (ModuleName mn mNs) fn i))
+        | not flagPact48Disabled
+          && mn == _mnName (_mName mdef)
+          && isNsMatch -> resolveBareName memo (BareName fn i)
+          where
+            isNsMatch = fromMaybe True (liftA2 (==) modNs mNs)
+            modNs = _mnNamespace (_mName mdef)
+      f  -> do
         dm <- lift (resolveRefFQN f f) -- lookup ref, don't try modules for barenames
         case (dm, f) of
           (Just t, _) -> checkAddDep t *> return (Right t) -- ref found
-          -- for barenames, check decls and finally modules
-          (Nothing, Name (BareName fn _)) ->
-            case HM.lookup fn allDefs of
-              Just _ -> do
-                let name' = FullyQualifiedName fn (_mName mdef) (moduleHash mdef)
-                return (Left name') -- decl found
-              Nothing -> lift (resolveBareModRef info f fn memo (MDModule mdef)) >>= \r -> case r of
-                Just mr -> return (Right mr) -- mod ref found
-                Nothing ->
-                  lift (evalError' f $ "Cannot resolve " <> dquotes (pretty f))
-          -- for qualified names, simply fail
-          (Nothing, _) -> lift (evalError' f $ "Cannot resolve " <> dquotes (pretty f))
+            -- for barenames, check decls and finally modules
+          (Nothing, Name bn@BareName{}) -> resolveBareName memo bn
+              -- for qualified names, simply fail
+          (Nothing, _) -> resolveError f
+
+    -- | traverse to find deps and form graph
+    traverseGraph allDefs memo = fmap stronglyConnCompR $ forM (HM.toList allDefs) $ \(defName,defTerm) -> do
+      let defName' = FullyQualifiedName defName (_mName mdef) (moduleHash mdef)
+      disablePact48 <- lift (isExecutionFlagSet FlagDisablePact48)
+      defTerm' <- forM defTerm $ \(f :: Name) -> resolveName disablePact48 memo f
 
       return (defTerm', defName', mapMaybe (either Just (const Nothing)) $ toList defTerm')
+
     moduleHash = _mhHash . _mHash
 
 

diff --git a/src/Pact/Types/Runtime.hs b/src/Pact/Types/Runtime.hs
@@ -189,6 +189,8 @@ data ExecutionFlag
   | FlagDisablePact47
   -- | Disable runtime return type checking.
   | FlagDisableRuntimeReturnTypeChecking
+  -- | Disable Pact 4.8 Features
+  | FlagDisablePact48
   deriving (Eq,Ord,Show,Enum,Bounded)
 
 -- | Flag string representation

diff --git a/tests/pact/fqns.repl b/tests/pact/fqns.repl
@@ -77,3 +77,94 @@
 
 (expect "selects correct test" (modB.get-test) "hello")
 (commit-tx)
+
+;;
+;; Module redeploy name resolution
+;;
+
+; In the following tests, we define a module `test-mod-redeploy-ref`, and then
+; redeploy the same module with the change to one capability: `test`.
+; In the old version, the `test` capability fails, in the new one it passes.
+
+(begin-tx)
+; First, demonstrate the behavior prior to pact-4.8.
+(env-exec-config ["DisablePact48"])
+
+(namespace 'free)
+(module test-mod-redeploy-ref g
+  (defcap g () true)
+
+  (defcap test ()
+    (enforce false "boom"))
+
+  (defun f ()
+    (with-capability (test)
+      1))
+  )
+; Before pact-4.8, the updated capability will be ignored, and calls to a function
+; requiring that capability will fail.
+(expect-failure "Demonstrate defcap resolution." (f))
+
+(commit-tx)
+
+; The following module redeployment changed the capability `test` to pass.
+(begin-tx)
+(namespace 'free)
+(module test-mod-redeploy-ref g
+  (defcap g () true)
+  (defcap test ()
+    true)
+
+  (defun f ()
+    (with-capability (free.test-mod-redeploy-ref.test)
+      1))
+
+  (defun f1 ()
+    (with-capability (test-mod-redeploy-ref.test)
+      1))
+
+  )
+; Before pact-4.8, the capability update (passing `test`) was ignored as the
+; full-qualified reference referenced the previously deployed version of the module.
+(expect-failure "Reproduce upgrade resolution bug with fully-qualified reference." (f))
+(expect-failure "Reproduce upgrade resolution bug with non-namespace-qualified reference." (f1))
+(commit-tx)
+
+
+;; Check Pact48 behaviour
+
+(begin-tx)
+(namespace 'free)
+(module test-mod-redeploy-ref g
+  (defcap g () true)
+
+  (defcap test ()
+    (enforce false "boom"))
+
+  (defun f ()
+    (with-capability (test)
+      1))
+  )
+(commit-tx)
+
+(begin-tx)
+(namespace 'free)
+(env-exec-config []) ; reset
+
+(module test-mod-redeploy-ref g
+  (defcap g () true)
+  (defcap test ()
+    true)
+  (defun f ()
+    (with-capability (free.test-mod-redeploy-ref.test)
+      1))
+
+  (defun f1 ()
+    (with-capability (test-mod-redeploy-ref.test)
+      1))
+  )
+; These tests show that f now references the updated version of the capability.
+(expect "Demonstrate correct resolution with fully-qualified reference." 1 (f))
+(expect "Demonstrate correct resolution with non-namespace-qualified reference." 1 (f1))
+
+(commit-tx)