Pact 5 merge

kadena-io · Dec 19, 2024 · 1b85691 · 1b85691
2 parents cf67a75 + f63bc8a
commit 1b85691
Show file tree

Hide file tree

Showing 191 changed files with 15,173 additions and 5,682 deletions.
diff --git a/.github/workflows/applications.yml b/.github/workflows/applications.yml
@@ -265,7 +265,7 @@ jobs:
         cabal --version
     - name: Install non-Haskell dependencies (ubuntu)
       if: contains(matrix.os, 'ubuntu')
-      run: sudo apt-get install -y libgflags-dev liblz4-dev libzstd-dev libsnappy-dev libbz2-dev
+      run: sudo apt-get install -y libgflags-dev liblz4-dev libzstd-dev libsnappy-dev libbz2-dev libmpfr-dev
     # Project Configuration
     - name: Create cabal.project.local
       run: |
@@ -781,6 +781,7 @@ jobs:
           libbz2-1.0 \
           libgflags2.2 \
           zstd \
+          libmpfr6 \
           locales &&
           rm -rf /var/lib/apt/lists/* &&
           locale-gen en_US.UTF-8 &&

diff --git a/.github/workflows/release.yml b/.github/workflows/release.yml
@@ -223,10 +223,9 @@ jobs:
 
             *   $UBUNTU_VERSION:
                 ```sh
-                apt-get install ca-certificates libgmp10 libssl3 libsnappy1v5 zlib1g liblz4-1 libbz2-1.0 libgflags2.2 zstd locales
-                
-                
+                apt-get install ca-certificates libgmp10 libssl3 libsnappy1v5 zlib1g liblz4-1 libbz2-1.0 libgflags2.2 zstd libmpfr6 locales
                 ```
+     
           ' >> CHANGELOG.md
           cat CHANGELOG.md
 

diff --git a/README.md b/README.md
@@ -85,12 +85,12 @@ The following packages must be installed on the host system:
 
 *   ubuntu-20.04:
     ```bash
-    apt-get install ca-certificates libgmp10 libssl1.1 libsnappy1v5 zlib1g liblz4-1 libbz2-1.0 libgflags2.2 zstd
+    apt-get install ca-certificates libmpfr6 libgmp10 libssl1.1 libsnappy1v5 zlib1g liblz4-1 libbz2-1.0 libgflags2.2 zstd
     ```
 
 *   ubuntu-22.04:
     ```bash
-    apt-get install ca-certificates libgmp10 libssl1.1 libsnappy1v5 zlib1g liblz4-1 libbz2-1.0 libgflags2.2 zstd
+    apt-get install ca-certificates libmpfr6 libgmp10 libssl1.1 libsnappy1v5 zlib1g liblz4-1 libbz2-1.0 libgflags2.2 zstd
     ```
 
 Chainweb-node binaries for ubuntu-20.04 and ubuntu-22.04 can be found
@@ -130,7 +130,7 @@ You need to install the development versions of the following libraries:
 On apt based distribution these can be installed as follows:
 
 ```
-apt-get install ca-certificates libssl-dev libgmp-dev libsnappy-dev zlib1g-dev liblz4-dev libbz2-dev libgflags-dev libzstd-dev
+apt-get install ca-certificates libssl-dev libmpfr-dev libgmp-dev libsnappy-dev zlib1g-dev liblz4-dev libbz2-dev libgflags-dev libzstd-dev
 ```
 
 To build a `chainweb-node` binary:

diff --git a/bench/Chainweb/Pact/Backend/Bench.hs b/bench/Chainweb/Pact/Backend/Bench.hs
@@ -52,14 +52,17 @@ import Chainweb.BlockHeader.Internal
 import Chainweb.Graph
 import Chainweb.Logger
 import Chainweb.MerkleLogHash
-import Chainweb.Pact.Backend.RelationalCheckpointer
+import Chainweb.Pact.PactService.Checkpointer.Internal
+
 import Chainweb.Pact.Backend.Types
 import Chainweb.Pact.Backend.Utils
 import Chainweb.Pact.Types
 import Chainweb.Test.TestVersions
 import Chainweb.Utils.Bench
 import Chainweb.Utils (sshow)
 import Chainweb.Version
+import qualified Chainweb.Pact4.Backend.ChainwebPactDb as Pact4
+import qualified Pact.Types.Command as Pact
 
 testVer :: ChainwebVersion
 testVer = instantCpmTestVersion petersonChainGraph
@@ -70,13 +73,13 @@ testChainId = unsafeChainId 0
 -- allowing a straightforward list of blocks to be passed to the API,
 -- and only exposing the PactDbEnv part of the block context
 cpRestoreAndSave
-  :: (Monoid q)
+  :: (Monoid q, Logger logger)
   => Checkpointer logger
   -> Maybe BlockHeader
-  -> [(BlockHeader, ChainwebPactDbEnv logger -> IO q)]
+  -> [(BlockHeader, PactDbEnv (Pact4.BlockEnv logger) -> IO q)]
   -> IO q
-cpRestoreAndSave cp pc blks = snd <$> _cpRestoreAndSave cp (ParentHeader <$> pc)
-  (traverse Stream.yield [RunnableBlock $ \dbEnv _ -> (,bh) <$> fun (_cpPactDbEnv dbEnv) | (bh, fun) <- blks])
+cpRestoreAndSave cp pc blks = snd <$> restoreAndSave cp (ParentHeader <$> pc)
+  (traverse Stream.yield [Pact4RunnableBlock $ \dbEnv _ -> (,bh) <$> fun (Pact4._cpPactDbEnv dbEnv) | (bh, fun) <- blks])
 
 -- | fabricate a `BlockHeader` for a block given its hash and its parent.
 childOf :: Maybe BlockHeader -> BlockHash -> BlockHeader
@@ -150,7 +153,7 @@ cpWithBench torun =
         let neverLogger = genericLogger Error (\_ -> return ())
         !sqliteEnv <- openSQLiteConnection dbFile chainwebPragmas
         !cenv <-
-          initRelationalCheckpointer defaultModuleCacheLimit sqliteEnv DoNotPersistIntraBlockWrites neverLogger testVer testChainId
+          initCheckpointerResources defaultModuleCacheLimit sqliteEnv DoNotPersistIntraBlockWrites neverLogger testVer testChainId
         return $ NoopNFData (sqliteEnv, cenv)
 
     teardown (NoopNFData (sqliteEnv, _cenv)) = closeSQLiteConnection sqliteEnv
@@ -159,7 +162,7 @@ cpWithBench torun =
     benches cpenv =
         [ torun cpenv ]
 
-cpBenchNoRewindOverBlock :: Int -> Checkpointer logger -> C.Benchmark
+cpBenchNoRewindOverBlock :: Logger logger => Int -> Checkpointer logger -> C.Benchmark
 cpBenchNoRewindOverBlock transactionCount cp = C.env setup' $ \ ~ut ->
   C.bench name $ C.nfIO $ do
       mv <- newMVar (initbytestring, pc01)
@@ -201,7 +204,7 @@ cpBenchNoRewindOverBlock transactionCount cp = C.env setup' $ \ ~ut ->
       where
         transaction db = incIntegerAtKey db ut f k 1
 
-cpBenchOverBlock :: Int -> Checkpointer logger -> C.Benchmark
+cpBenchOverBlock :: Logger logger => Int -> Checkpointer logger -> C.Benchmark
 cpBenchOverBlock transactionCount cp = C.env setup' $ \ ~(ut) ->
     C.bench benchname $ C.nfIO (go ut)
   where
@@ -335,7 +338,7 @@ benchUserTableForKeys numSampleEvents dbEnv =
           writeRow db Update ut f rowkeyb a
 
 
-_cpBenchKeys :: Int -> Checkpointer logger -> C.Benchmark
+_cpBenchKeys :: Logger logger => Int -> Checkpointer logger -> C.Benchmark
 _cpBenchKeys numKeys cp =
     C.env setup' $ \ ~(ut) -> C.bench name $ C.nfIO (go ut)
   where
@@ -368,7 +371,7 @@ _cpBenchKeys numKeys cp =
             let rowkey = RowKey $ "k" <> sshow numkey
             incIntegerAtKey db ut f rowkey 1
 
-cpBenchSampleKeys :: Int -> Checkpointer logger -> C.Benchmark
+cpBenchSampleKeys :: Logger logger => Int -> Checkpointer logger -> C.Benchmark
 cpBenchSampleKeys numSampleEvents cp =
     C.env setup' $ \ ~(ut) -> C.bench name $ C.nfIO (go ut)
   where
@@ -414,7 +417,7 @@ cpBenchSampleKeys numSampleEvents cp =
           )]
 
 
-cpBenchLookupProcessedTx :: Int -> Checkpointer logger -> C.Benchmark
+cpBenchLookupProcessedTx :: Logger logger => Int -> Checkpointer logger -> C.Benchmark
 cpBenchLookupProcessedTx transactionCount cp = C.env setup' $ \ ~(ut) ->
     C.bench benchname $ C.nfIO (go ut)
   where
@@ -442,5 +445,5 @@ cpBenchLookupProcessedTx transactionCount cp = C.env setup' $ \ ~(ut) ->
     pc02 = childOf (Just pc01) hash02
 
     go (NoopNFData _) = do
-        _cpReadFrom (_cpReadCp cp) (Just (ParentHeader pc02)) $ \dbEnv ->
-          _cpLookupProcessedTx dbEnv (V.fromList [Pact.TypedHash "" | _ <- [1..transactionCount]])
+        readFrom cp (Just (ParentHeader pc02)) Pact4T $ \dbEnv _ ->
+          Pact4._cpLookupProcessedTx dbEnv (V.fromList [Pact.RequestKey (Pact.toUntypedHash $ Pact.TypedHash "") | _ <- [1..transactionCount]])
diff --git a/bench/Chainweb/Pact/Backend/ForkingBench.hs b/bench/Chainweb/Pact/Backend/ForkingBench.hs
@@ -15,6 +15,8 @@
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
 
 module Chainweb.Pact.Backend.ForkingBench ( bench ) where
 
@@ -31,6 +33,7 @@ import Data.Aeson hiding (Error)
 import Data.ByteString (ByteString)
 import Data.Char
 import Data.Decimal
+import Data.Either
 import Data.FileEmbed
 import Data.Foldable (toList)
 import Data.IORef
@@ -81,23 +84,23 @@ import Chainweb.BlockHeight (BlockHeight(..))
 import Chainweb.ChainId
 import Chainweb.Graph
 import Chainweb.Logger
-import Chainweb.Mempool.Mempool (BlockFill(..))
+import Chainweb.Mempool.Mempool
 import Chainweb.Miner.Pact
 import Chainweb.Pact.Backend.Compaction qualified as C
+
 import Chainweb.Pact.Backend.Types
 import Chainweb.Pact.Backend.Utils
 import Chainweb.Pact.PactService
 import Chainweb.Pact.Service.BlockValidation
 import Chainweb.Pact.Service.PactQueue
-import Chainweb.Pact.Service.Types
 import Chainweb.Pact.Types
 import Chainweb.Pact.Utils (toTxCreationTime)
 import Chainweb.Payload
 import Chainweb.Payload.PayloadStore
 import Chainweb.Payload.PayloadStore.InMemory
 import Chainweb.Test.TestVersions (slowForkingCpmTestVersion)
 import Chainweb.Time
-import Chainweb.Transaction
+import qualified Chainweb.Pact4.Transaction as Pact4
 import Chainweb.Utils
 import Chainweb.Utils.Bench
 import Chainweb.Version
@@ -242,7 +245,7 @@ createBlock validate parent nonce pact = do
      -- assemble block without nonce and timestamp
 
      bip <- throwIfNoHistory =<< newBlock noMiner NewBlockFill parent pact
-     let payload = blockInProgressToPayloadWithOutputs bip
+     let payload = forAnyPactVersion finalizeBlock bip
 
      let creationTime = add second $ view blockCreationTime $ _parentHeader parent
      let bh = newBlockHeader
@@ -341,7 +344,7 @@ withResources rdb trunkLength logLevel compact p f = C.envWithCleanup create des
     startPact version l bhdb pdb mempool sqlEnv = do
         reqQ <- newPactQueue pactQueueSize
         a <- async $ runPactService version cid l Nothing reqQ mempool bhdb pdb sqlEnv testPactServiceConfig
-            { _pactBlockGasLimit = 180_000
+            { _pactNewBlockGasLimit = 180_000
             , _pactPersistIntraBlockWrites = p
             }
 
@@ -383,15 +386,16 @@ withResources rdb trunkLength logLevel compact p f = C.envWithCleanup create des
 testMemPoolAccess :: IORef Int -> MVar (Map Account (NonEmpty (DynKeyPair, [SigCapability]))) -> IO MemPoolAccess
 testMemPoolAccess txsPerBlock accounts = do
   return $ mempty
-    { mpaGetBlock = \bf validate bh hash header -> do
+    { mpaGetBlock = \bf validate bh hash bct -> do
         if _bfCount bf /= 0 then pure mempty else do
-          testBlock <- getTestBlock accounts (_bct $ view blockCreationTime header) validate bh hash
+          testBlock <- getTestBlock accounts (_bct bct) validate bh hash
           pure testBlock
     }
   where
 
     setTime time pb = pb { _pmCreationTime = toTxCreationTime time }
 
+    getTestBlock :: _ -> _ -> MempoolPreBlockCheck Pact4.UnparsedTransaction to -> _ -> _ -> IO (V.Vector to)
     getTestBlock mVarAccounts txOrigTime validate bHeight hash
         | bHeight == 1 = do
             meta <- setTime txOrigTime <$> makeMeta cid
@@ -402,10 +406,10 @@ testMemPoolAccess txsPerBlock accounts = do
                   modifyMVar' mVarAccounts
                     (const $ M.fromList $ zip as kss)
 
-                  vs <- validate bHeight hash (V.fromList $ toList r)
+                  vs <- validate bHeight hash (V.fromList $ toList $ Pact4.unparseTransaction <$> r)
                   -- TODO: something better should go here
-                  unless (and vs) $ throwM $ userError $ "at blockheight 1: tx validation failed " <> sshow vs
-                  return $! V.fromList $ toList r
+                  unless (all isRight vs) $ throwM $ userError $ "at blockheight 1: tx validation failed " <> sshow r
+                  return $! V.fromList [v | Right v <- toList vs]
 
         | otherwise = do
           withMVar mVarAccounts $ \accs -> do
@@ -419,7 +423,9 @@ testMemPoolAccess txsPerBlock accounts = do
                 case eCmd of
                   Left e -> throwM $ userError e
                   Right tx -> return tx
-            return $! txs
+            vs <- validate bHeight hash (V.fromList $ toList $ Pact4.unparseTransaction <$> txs)
+            unless (all isRight vs) $ throwM $ userError $ "tx validation failed " <> sshow txs
+            return $! V.fromList [v | Right v <- toList vs]
 
     mkTransferCaps :: ReceiverName -> Amount -> (Account, NonEmpty (DynKeyPair, [SigCapability])) -> (Account, NonEmpty (DynKeyPair, [SigCapability]))
     mkTransferCaps (ReceiverName (Account r)) (Amount m) (s@(Account ss),ks) = (s, (caps <$) <$> ks)
@@ -509,10 +515,10 @@ safeCapitalize :: String -> String
 safeCapitalize = maybe [] (uncurry (:) . bimap toUpper (Prelude.map toLower)) . Data.List.uncons
 
 
--- TODO: Use the new `assertCommand` function.
-validateCommand :: Command Text -> Either String ChainwebTransaction
+-- TODO: Use the new `assertPact4Command` function.
+validateCommand :: Command Text -> Either String Pact4.Transaction
 validateCommand cmdText = case verifyCommand cmdBS of
-    ProcSucc cmd -> Right (mkPayloadWithTextOld <$> cmd)
+    ProcSucc cmd -> Right (Pact4.mkPayloadWithTextOld <$> cmd)
     ProcFail err -> Left err
   where
     cmdBS :: Command ByteString

diff --git a/cabal.project b/cabal.project
@@ -61,6 +61,11 @@ package pact
     -- avoid conflict with cryptonite during linking
     flags: +cryptonite-ed25519 -build-tool
 
+package pact-tng
+    ghc-options: -Wwarn
+    -- avoid conflict with cryptonite during linking
+    flags: +cryptonite-ed25519 -build-tool
+
 package rocksdb-haskell-kadena
     ghc-options: -Wwarn -optc-w -optcxx-w
 
@@ -87,6 +92,12 @@ source-repository-package
     tag: 1027a1f5fd0439c58522921e3a0532c4f5867a24
     --sha256: 18xgvzb3p8chch85747ln9a2191df09vwwrv9v3njr2h69n3rhxj
 
+source-repository-package
+    type: git
+    location: https://github.com/kadena-io/pact-5.git
+    tag: 52f41d6b48584e8fcbfae745a6e3abe640500885
+    --sha256: 06karzsrih0hjkdipc8s171v4vgk09j5w6fa7zm3rv6qjw6j6jar
+
 source-repository-package
     type: git
     location: https://github.com/kadena-io/pact-json.git
@@ -163,8 +174,6 @@ allow-newer: servant:*
 -- These packages are tightly bound to the GHC version and these
 -- settings ensure that we use the versions that are shipped with the
 -- GHC version that we are using.
-allow-newer: *:Cabal
-allow-newer: *:Cabal-syntax
 allow-newer: *:array
 allow-newer: *:base
 allow-newer: *:bytestring
@@ -204,6 +213,8 @@ allow-newer: webauthn:*
 -- many packages use an spurious <1.5 upper bound on hashable
 allow-newer: *:hashable
 
+allow-newer: lrucaching:base-compat
+
 -- -------------------------------------------------------------------------- --
 -- Temporary Dependency Overwrites
 --
@@ -219,4 +230,3 @@ allow-newer: *:hashable
 --
 -- Please add a comment for each entry that outlines why it is needed and when
 -- it can be removed.
-