WIP RemotePactTests for Pact5. Multi chain is not working

Change-Id: I51223e1ab74f93b9eae4af1ec7eba40ed463e12b
kadena-io · Dec 14, 2024 · 099ee9f · 099ee9f
1 parent 10493c0
commit 099ee9f
Show file tree

Hide file tree

Showing 5 changed files with 239 additions and 83 deletions.
diff --git a/test/lib/Chainweb/Test/Pact5/CmdBuilder.hs b/test/lib/Chainweb/Test/Pact5/CmdBuilder.hs
@@ -1,16 +1,15 @@
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE ImportQualifiedPost #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ImportQualifiedPost #-}
-{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TupleSections #-}
@@ -22,7 +21,6 @@ module Chainweb.Test.Pact5.CmdBuilder where
 import Pact.Types.ChainMeta qualified as Pact4
 import Pact.Types.Command qualified as Pact4
 import Pact.JSON.Legacy.Value qualified as J
-import Data.Aeson qualified as Aeson
 import Chainweb.Pact4.Transaction qualified as Pact4
 import Control.Lens hiding ((.=))
 import Pact.Core.Command.Types
@@ -47,7 +45,7 @@ import Data.Maybe
 import Pact.Core.Command.Crypto
 import Pact.Core.Command.Util
 import qualified Data.Text as T
-import Pact.Core.Names (QualifiedName, DefPactId)
+import Pact.Core.Names (Field(..), QualifiedName, DefPactId)
 import Pact.Core.PactValue
 import Pact.Core.Signer
 import Data.Aeson
@@ -57,6 +55,8 @@ import Chainweb.Pact.RestAPI.Server (validatePact5Command)
 import Pact.Core.Command.Client (ApiKeyPair (..), mkCommandWithDynKeys)
 import System.Random
 import Control.Monad
+import Data.Vector qualified as Vector
+import Data.Map.Strict qualified as Map
 
 type TextKeyPair = (Text,Text)
 
@@ -89,10 +89,9 @@ allocation00KeyPair =
     , "c63cd081b64ae9a7f8296f11c34ae08ba8e1f8c84df6209e5dee44fa04bcb9f5"
     )
 
-
 -- | Make trivial keyset data
-mkKeySetData :: Key -> [TextKeyPair] -> Value
-mkKeySetData name keys = object [ name .= map fst keys ]
+mkKeySetData :: Text -> [TextKeyPair] -> PactValue
+mkKeySetData name keys = PObject $ Map.singleton (Field name) $ PList (Vector.fromList $ map (PString . fst) keys)
 
 sender00Ks :: KeySet
 sender00Ks = KeySet

diff --git a/test/lib/Chainweb/Test/Pact5/Utils.hs b/test/lib/Chainweb/Test/Pact5/Utils.hs
@@ -249,4 +249,5 @@ testLogFn ll msg = case ll of
 getTestLogger :: IO GenericLogger
 getTestLogger = do
     logLevel <- getTestLogLevel
-    return $ genericLogger logLevel (testLogFn logLevel)
+    return $ genericLogger logLevel (testLogFn logLevel)
+
diff --git a/test/unit/Chainweb/Test/Pact4/RemotePactTest.hs b/test/unit/Chainweb/Test/Pact4/RemotePactTest.hs
@@ -822,6 +822,7 @@ localPreflightSimTest t cenv step = do
       tx' <- buildTextCmd n v' tx
       pure (succ nn, tx')
 
+-- FIXME: Polling no longer checks request key validity, so this test probably does not pass anymore.
 pollingBadlistTest :: ClientEnv -> IO ()
 pollingBadlistTest cenv = do
     let rks = RequestKeys $ NEL.fromList [pactDeadBeef]

diff --git a/test/unit/Chainweb/Test/Pact5/CutFixture.hs b/test/unit/Chainweb/Test/Pact5/CutFixture.hs
@@ -30,6 +30,7 @@ module Chainweb.Test.Pact5.CutFixture
     )
     where
 
+import Chainweb.Storage.Table (Casify)
 import Chainweb.BlockCreationTime (BlockCreationTime(..))
 import Chainweb.BlockHash (BlockHash)
 import Chainweb.BlockHeader hiding (blockCreationTime, blockNonce)
@@ -49,7 +50,6 @@ import Chainweb.Pact.Types
 import Chainweb.Pact4.Transaction qualified as Pact4
 import Chainweb.Payload
 import Chainweb.Payload.PayloadStore
-import Chainweb.Payload.PayloadStore.RocksDB
 import Chainweb.Storage.Table.RocksDB
 import Chainweb.Sync.WebBlockHeaderStore
 import Chainweb.Test.Pact5.Utils
@@ -73,6 +73,7 @@ import Data.Function
 import Data.HashMap.Strict qualified as HashMap
 import Data.HashSet qualified as HashSet
 import Data.Text (Text)
+import Data.Text qualified as Text
 import Data.Vector (Vector)
 import GHC.Stack
 import Network.HTTP.Client qualified as HTTP
@@ -102,7 +103,8 @@ mkFixture v pactServiceConfig baseRdb = do
         withRunPactService logger v chain pactQueue mempool webBHDb payloadDb pactServiceConfig
         return (mempool, pactQueue)
     let webPact = mkWebPactExecutionService $ HashMap.map (mkPactExecutionService . snd) perChain
-    cutDb <- withTestCutDb logger baseRdb v webBHDb webPact
+    let cutHashesStore = cutHashesTable baseRdb
+    cutDb <- withTestCutDb logger v webBHDb payloadDb cutHashesStore webPact
 
     let fixture = Fixture
             { _fixtureCutDb = cutDb
@@ -118,20 +120,20 @@ mkFixture v pactServiceConfig baseRdb = do
 advanceAllChains :: (HasCallStack)
     => ChainwebVersion
     -> Fixture
-    -> IO (ChainMap (Vector (CommandResult Pact5.Hash Text)))
+    -> IO (Cut, ChainMap (Vector (CommandResult Pact5.Hash Text)))
 advanceAllChains v Fixture{..} = do
     latestCut <- liftIO $ _fixtureCutDb ^. cut
     let blockHeights = fmap (view blockHeight) $ latestCut ^. cutMap
     let latestBlockHeight = maximum blockHeights
-    assertBool "all block heights in the latest cut must be the same" $
-        all (== latestBlockHeight) blockHeights
+    --assertBool "all block heights in the latest cut must be the same" $
+    --    all (== latestBlockHeight) blockHeights
 
-    (_finalCut, perChainCommandResults) <- foldM
+    putStrLn ""
+
+    (finalCut, perChainCommandResults) <- foldM
         (\ (prevCut, !acc) cid -> do
-            putStrLn $ "accumulator: " ++ show acc
             (newCut, _minedChain, pwo) <- mine noMiner NewBlockFill _fixtureWebPactExecutionService _fixtureCutDb prevCut
-
-            putStrLn $ "PAYLOAD HASH: " <> sshow (_payloadWithOutputsPayloadHash pwo)
+            putStrLn $ "new cut after processing chain " ++ Text.unpack (chainIdToText cid) ++ " " ++ show (fmap (view blockHeight) $ newCut ^. cutMap)
 
             commandResults <- forM (_payloadWithOutputsTransactions pwo) $ \(_, txOut) -> do
                 decodeOrThrow' $ LBS.fromStrict $ _transactionOutputBytes txOut
@@ -143,28 +145,25 @@ advanceAllChains v Fixture{..} = do
         (latestCut, [])
         (HashSet.toList (chainIdsAt v (latestBlockHeight + 1)))
 
-    return (onChains perChainCommandResults)
+    return (finalCut, onChains perChainCommandResults)
 
 withTestCutDb :: (Logger logger)
     => logger
-    -> RocksDb
     -> ChainwebVersion
     -> WebBlockHeaderDb
+    -> PayloadDb RocksDbTable
+    -> Casify RocksDbTable CutHashes
     -> WebPactExecutionService
     -> ResourceT IO (CutDb RocksDbTable)
-withTestCutDb logger rdb v webBHDb webPact = snd <$> allocate create destroy
+withTestCutDb logger v webBHDb payloadDb cutHashesStore webPact = snd <$> allocate create destroy
     where
         create :: IO (CutDb RocksDbTable)
         create = do
-            rocks <- testRocksDb "withTestCutDb" rdb
-            let payloadDb = newPayloadDb rocks
-            --let cutHashesDb = cutHashesTable rocks
             initializePayloadDb v payloadDb
             httpManager <- HTTP.newManager HTTP.defaultManagerSettings
 
             headerStore <- newWebBlockHeaderStore httpManager webBHDb (logFunction logger)
             payloadStore <- newWebPayloadStore httpManager webPact payloadDb (logFunction logger)
-            let cutHashesStore = cutHashesTable rocks
 
             let cutFetchTimeout = 3_000_000
             cutDb <- startCutDb (defaultCutDbParams v cutFetchTimeout) (logFunction logger) headerStore payloadStore cutHashesStore