Fix namespaced module resolution in Pact (#988)

Co-authored-by: Doug Beardsley <[email protected]>

cabal.project

@@ -11,7 +11,7 @@ debug-info: True
 source-repository-package
     type: git
     location: https://github.com/kadena-io/pact.git
-    tag: a8836793539156b5b22680419746452d99f0fc8f
+    tag: f89b5cc0d6e6fea6e429cdae13abeb5fbea4bb56
 
 source-repository-package
     type: git
@@ -39,4 +39,3 @@ allow-newer:
 
 package vault
     documentation: false
-

dep/kpkgs/github.json

@@ -3,6 +3,6 @@
   "repo": "kpkgs",
   "branch": "master",
   "private": false,
-  "rev": "2a4407de9d1b7786db2343a8a6c6d147f2f4f817",
-  "sha256": "16xsil9lgzd8v6psqycvl79mlw882q31j6mhs8fk0bl8fbhlh89s"
+  "rev": "72bdda3e5f4ec4e4e5acd7055dfa50551f771c79",
+  "sha256": "0aq02kas4cpc8sjy6s2z3057yw4xsh1jihs5cqw9pdbz3cfv5fx0"
 }

src/Chainweb/Pact/TransactionExec.hs

@@ -152,7 +152,8 @@ applyCmd v logger pdbenv miner gasModel pd spv cmdIn mcache0 =
 
     executionConfigNoHistory = mkExecutionConfig
       $ FlagDisableHistoryInTransactionalMode
-      : [ FlagOldReadOnlyBehavior | isPactBackCompatV16 ]
+      : ( [ FlagOldReadOnlyBehavior | isPactBackCompatV16 ]
+          ++ [ FlagPreserveModuleNameBug | not isModuleNameFix ] )
 
     cenv = TransactionEnv Transactional pdbenv logger pd spv nid gasPrice
       requestKey (fromIntegral gasLimit) executionConfigNoHistory
@@ -163,6 +164,7 @@ applyCmd v logger pdbenv miner gasModel pd spv cmdIn mcache0 =
     gasLimit = gasLimitOf cmd
     initialGas = initialGasOf (_cmdPayload cmdIn)
     nid = networkIdOf cmd
+    isModuleNameFix = enableModuleNameFix v (fromIntegral $ _pdBlockHeight pd)
     isPactBackCompatV16 = pactBackCompat_v16 v (BlockHeight $ _pdBlockHeight pd)
 
     redeemAllGas r = do

src/Chainweb/Version.hs

@@ -673,8 +673,8 @@ enableModuleNameFix
 enableModuleNameFix v bh = case v of
   Mainnet01 -> forHeight 448501 -- ~ 2020-04-02T12:00:00Z
   Testnet04 -> forHeight 286110 -- ~ 2020-04-02T01:00:00Z
-  Development -> forHeight 200
-  _ -> forHeight 1
+  Development -> forHeight 100
+  _ -> forHeight 2
   where
     forHeight h = bh >= h
 

stack.yaml

@@ -35,7 +35,7 @@ extra-deps:
 
   # --- Custom Pins --- #
   - github: kadena-io/pact
-    commit: a8836793539156b5b22680419746452d99f0fc8f
+    commit: f89b5cc0d6e6fea6e429cdae13abeb5fbea4bb56
   - github: kadena-io/chainweb-storage
     commit: 17a5fb130926582eff081eeb1b94cb6c7097c67a
 

test/Chainweb/Test/Pact/Checkpointer.hs

@@ -123,16 +123,20 @@ testModuleName = withResource initializeSQLite freeSQLiteResource $
       void $ _cpRestore _cpeCheckpointer Nothing
       _cpSave _cpeCheckpointer hash00
 
-      -- block 1: write module records
       let hash01 = getArbitrary 1
-      (PactDbEnv' (PactDbEnv pactdb mvar)) <- _cpRestore _cpeCheckpointer (Just (1, hash00))
+          hash02 = getArbitrary 2
+      void $ _cpRestore _cpeCheckpointer (Just (1, hash00))
+      _cpSave _cpeCheckpointer hash01
+      (PactDbEnv' (PactDbEnv pactdb mvar)) <- _cpRestore _cpeCheckpointer (Just (2, hash01))
+
 
+      -- block 2: write module records
       (_,_,mod') <- loadModule
       -- write qualified
       _writeRow pactdb Insert Modules "nsname.qualmod" mod' mvar
       -- write unqualified
       _writeRow pactdb Insert Modules "baremod" mod' mvar
-      _cpSave _cpeCheckpointer hash01
+      _cpSave _cpeCheckpointer hash02
 
       r1 <- qry_ _sConn "SELECT rowkey FROM [SYS:Modules] WHERE rowkey LIKE '%qual%'" [RText]
       assertEqual "correct namespaced module name" [[SText "nsname.qualmod"]] r1

test/Chainweb/Test/Pact/PactInProcApi.hs

@@ -83,6 +83,7 @@ tests = ScheduledTest testName $ go
          , test Warn $ newBlockRewindValidate
          , test Quiet $ badlistNewBlockTest
          , test Warn $ mempoolCreationTimeTest
+         , test Warn $ moduleNameFork
          ]
       where
         test logLevel f =
@@ -152,6 +153,45 @@ newBlockRewindValidate mpRefIO reqIO = testCase "newBlockRewindValidate" $ do
             $ mkExec' "(chain-data)"
       }
 
+moduleNameFork :: IO (IORef MemPoolAccess) -> IO (PactQueue,TestBlockDb) -> TestTree
+moduleNameFork mpRefIO reqIO = testCase "moduleNameFork" $ do
+
+  (q,bdb) <- reqIO
+
+  -- install in free in block 1
+  setMempool mpRefIO (moduleNameMempool "free" "test")
+  void $ runBlock q bdb second "moduleNameFork-1"
+
+  -- install in user in block 2
+  setMempool mpRefIO (moduleNameMempool "user" "test")
+  void $ runBlock q bdb second "moduleNameFork-1"
+
+  -- do something else post-fork
+  setMempool mpRefIO (moduleNameMempool "free" "test2")
+  void $ runBlock q bdb second "moduleNameFork-1"
+  setMempool mpRefIO (moduleNameMempool "user" "test2")
+  void $ runBlock q bdb second "moduleNameFork-1"
+
+  -- TODO this test doesn't actually validate, I turn on Debug and make sure it
+  -- goes well.
+
+moduleNameMempool :: T.Text -> T.Text -> MemPoolAccess
+moduleNameMempool ns mn = mempty
+    { mpaGetBlock = getTestBlock
+    }
+  where
+    getTestBlock _ _ _ bh = do
+        let txs =
+              [ "(namespace '" <> ns <> ") (module " <> mn <> " G (defcap G () (enforce false 'cannotupgrade)))"
+              , ns <> "." <> mn <> ".G"
+              ]
+        fmap V.fromList $ forM (zip txs [0..]) $ \(code,n :: Int) ->
+          buildCwCmd $
+          set cbSigners [mkSigner' sender00 []] $
+          set cbCreationTime (toTxCreationTime $ _bct $ _blockCreationTime bh) $
+          mkCmd ("1" <> sshow n) $
+          mkExec' code
+
 
 mempoolCreationTimeTest :: IO (IORef MemPoolAccess) -> IO (PactQueue,TestBlockDb) -> TestTree
 mempoolCreationTimeTest mpRefIO reqIO = testCase "mempoolCreationTimeTest" $ do