PactDB Compaction

bench/Chainweb/Pact/Backend/ForkingBench.hs

@@ -1,10 +1,12 @@
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE ImportQualifiedPost #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE RecordWildCards #-}
@@ -33,6 +35,7 @@ import Data.FileEmbed
 import Data.Foldable (toList)
 import Data.IORef
 import Data.List (uncons)
+import Data.List qualified as List
 import Data.List.NonEmpty (NonEmpty)
 import qualified Data.List.NonEmpty as NEL
 import Data.Map.Strict (Map)
@@ -49,6 +52,7 @@ import qualified Data.Yaml as Y
 import GHC.Generics hiding (from, to)
 
 import System.Environment
+import System.Logger.Types qualified
 import System.LogLevel
 import System.Random
 
@@ -74,11 +78,13 @@ import Chainweb.BlockCreationTime
 import Chainweb.BlockHeader
 import Chainweb.BlockHeaderDB
 import Chainweb.BlockHeaderDB.Internal
+import Chainweb.BlockHeight (BlockHeight(..))
 import Chainweb.ChainId
 import Chainweb.Graph
 import Chainweb.Logger
 import Chainweb.Mempool.Mempool (BlockFill(..))
 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
@@ -90,7 +96,7 @@ import Chainweb.Pact.Utils (toTxCreationTime)
 import Chainweb.Payload
 import Chainweb.Payload.PayloadStore
 import Chainweb.Payload.PayloadStore.InMemory
-import Chainweb.Test.TestVersions
+import Chainweb.Test.TestVersions (slowForkingCpmTestVersion)
 import Chainweb.Time
 import Chainweb.Transaction
 import Chainweb.Utils
@@ -111,28 +117,48 @@ _run args = withTempRocksDb "forkingbench" $ \rdb ->
 -- -------------------------------------------------------------------------- --
 -- Benchmarks
 
+data BenchConfig = BenchConfig
+  { numPriorBlocks :: Word64
+    -- ^ number of blocks to create prior to benchmarking
+  , validate :: Validate
+    -- ^ whether or not to validate the blocks as part of the benchmark
+  , compact :: Compact
+    -- ^ whether or not to compact the pact database prior to benchmarking
+  }
+
+defBenchConfig :: BenchConfig
+defBenchConfig = BenchConfig
+  { numPriorBlocks = 100
+  , validate = DontValidate
+  , compact = DontCompact
+  }
+
+data Compact = DoCompact | DontCompact
+  deriving stock (Eq)
+
+data Validate = DoValidate | DontValidate
+  deriving stock (Eq)
+
 bench :: RocksDb -> C.Benchmark
-bench rdb = C.bgroup "PactService"
+bench rdb = C.bgroup "PactService" $
     [ forkingBench
     , doubleForkingBench
-    , oneBlock True 1
-    , oneBlock True 10
-    , oneBlock True 50
-    , oneBlock True 100
-    , oneBlock False 0
-    , oneBlock False 1
-    , oneBlock False 10
-    , oneBlock False 50
-    , oneBlock False 100
-    ]
+    ] ++ map (oneBlock defBenchConfig) [1, 10, 50, 100]
+      ++ map (oneBlock validateCfg) [0, 1, 10, 50, 100]
+      ++ map (oneBlock compactCfg) [0, 1, 10, 50, 100]
+      ++ map (oneBlock compactValidateCfg) [1, 10, 50, 100]
   where
-    forkingBench = withResources rdb 10 Quiet
+    validateCfg = defBenchConfig { validate = DoValidate }
+    compactCfg = defBenchConfig { compact = DoCompact }
+    compactValidateCfg = compactCfg { validate = DoValidate }
+
+    forkingBench = withResources rdb 10 Quiet DontCompact
         $ \mainLineBlocks pdb bhdb nonceCounter pactQueue _ ->
             C.bench "forkingBench"  $ C.whnfIO $ do
               let (T3 _ join1 _) = mainLineBlocks !! 5
               void $ playLine pdb bhdb 5 join1 pactQueue nonceCounter
 
-    doubleForkingBench = withResources rdb 10 Quiet
+    doubleForkingBench = withResources rdb 10 Quiet DontCompact
         $ \mainLineBlocks pdb bhdb nonceCounter pactQueue _ ->
             C.bench "doubleForkingBench"  $ C.whnfIO $ do
               let (T3 _ join1 _) = mainLineBlocks !! 5
@@ -141,15 +167,21 @@ bench rdb = C.bgroup "PactService"
               void $ playLine pdb bhdb forkLength1 join1 pactQueue nonceCounter
               void $ playLine pdb bhdb forkLength2 join1 pactQueue nonceCounter
 
-    oneBlock validate txCount = withResources rdb 3 Error go
+    oneBlock :: BenchConfig -> Int -> C.Benchmark
+    oneBlock cfg txCount = withResources rdb cfg.numPriorBlocks Error cfg.compact go
       where
-        go mainLineBlocks _pdb _bhdb _nonceCounter pactQueue txsPerBlock =
+        go mainLineBlocks _pdb _bhdb _nonceCounter pactQueue txsPerBlock = do
           C.bench name $ C.whnfIO $ do
             writeIORef txsPerBlock txCount
             let (T3 _ join1 _) = last mainLineBlocks
-            createBlock validate (ParentHeader join1) (Nonce 1234) pactQueue
-        name = "block-new" ++ (if validate then "-validated" else "") ++
-               "[" ++ show txCount ++ "]"
+            createBlock cfg.validate (ParentHeader join1) (Nonce 1234) pactQueue
+        name = "block-new ["
+          ++ List.intercalate ","
+               [ "txCount=" ++ show txCount
+               , "validate=" ++ show (cfg.validate == DoValidate)
+               , "compact=" ++ show (cfg.compact == DoCompact)
+               ]
+          ++ "]"
 
 -- -------------------------------------------------------------------------- --
 -- Benchmark Function
@@ -188,14 +220,14 @@ mineBlock
     -> PactQueue
     -> IO (T3 ParentHeader BlockHeader PayloadWithOutputs)
 mineBlock parent nonce pdb bhdb pact = do
-    !r@(T3 _ newHeader payload) <- createBlock True parent nonce pact
+    r@(T3 _ newHeader payload) <- createBlock DoValidate parent nonce pact
     addNewPayload pdb payload
     -- NOTE: this doesn't validate the block header, which is fine in this test case
     unsafeInsertBlockHeaderDb bhdb newHeader
     return r
 
 createBlock
-    :: Bool
+    :: Validate
     -> ParentHeader
     -> Nonce
     -> PactQueue
@@ -216,7 +248,7 @@ createBlock validate parent nonce pact = do
               creationTime
               parent
 
-     when validate $ do
+     when (validate == DoValidate) $ do
        mv' <- validateBlock bh (payloadWithOutputsToPayloadData payload) pact
        void $ assertNotLeft =<< takeMVar mv'
 
@@ -250,9 +282,10 @@ withResources :: ()
   => RocksDb
   -> Word64
   -> LogLevel
+  -> Compact
   -> RunPactService
   -> C.Benchmark
-withResources rdb trunkLength logLevel f = C.envWithCleanup create destroy unwrap
+withResources rdb trunkLength logLevel compact f = C.envWithCleanup create destroy unwrap
   where
 
     unwrap ~(NoopNFData (Resources {..})) =
@@ -270,6 +303,13 @@ withResources rdb trunkLength logLevel f = C.envWithCleanup create destroy unwra
           startPact testVer logger blockHeaderDb payloadDb mp sqlEnv
         mainTrunkBlocks <-
           playLine payloadDb blockHeaderDb trunkLength genesisBlock (snd pactService) nonceCounter
+        when (compact == DoCompact) $ do
+          C.withDefaultLogger System.Logger.Types.Error $ \lgr -> do
+            let flags = [C.NoGrandHash]
+            let db = _sConn sqlEnv
+            let bh = BlockHeight trunkLength
+            void $ C.compact (C.Target bh) lgr db flags
+
         return $ NoopNFData $ Resources {..}
 
     destroy (NoopNFData (Resources {..})) = do

cabal.project

@@ -125,6 +125,12 @@ source-repository-package
     tag: 174af3523616c8fe01449da5ccbb9f16df097ac3
     --sha256: sha256-kVFIy+Aj3TNJpsM1Cs/5uGmzeWwHKYWjjCQ+L1/XOj8=
 
+source-repository-package
+    type: git
+    location: https://github.com/chessai/patience
+    tag: 2f67d546ea6608fc6ebe5f2f6976503cbf340442
+    --sha256: 0x137akvbh4kr3qagksw74xdj2xz5vjnx1fbr41bb54a0lkcb8mm
+
 -- -------------------------------------------------------------------------- --
 -- Relaxed Bounds
 

chainweb.cabal

@@ -274,6 +274,8 @@ library
         -- pact
         , Chainweb.Pact.Backend.ChainwebPactDb
         , Chainweb.Pact.Backend.DbCache
+        , Chainweb.Pact.Backend.Compaction
+        , Chainweb.Pact.Backend.PactState
         , Chainweb.Pact.Backend.RelationalCheckpointer
         , Chainweb.Pact.Backend.SQLite.DirectV2
         , Chainweb.Pact.Backend.SQLite.V2
@@ -403,6 +405,7 @@ library
         , tls-session-manager >= 0.0
         , token-bucket >= 0.1
         , transformers >= 0.5
+        , unliftio ^>= 0.2
         , unordered-containers >= 0.2.16
         , uuid >= 1.3.15
         , wai >= 3.2.2.1
@@ -540,6 +543,7 @@ test-suite chainweb-tests
         , merkle-log >=0.2
         , mtl >= 2.3
         , network >= 3.1.2
+        , patience >= 0.3
         , http-client-tls >=0.3
         , pact
         , pact-json >= 0.1

src/Chainweb/Chainweb.hs

@@ -328,9 +328,9 @@ validatingMempoolConfig cid v gl gp mv = Mempool.InMemConfig
         f (This _) = Left (T2 (Mempool.TransactionHash "") (Mempool.InsertErrorOther "preInsertBatch: align mismatch 1"))
 
 
-data StartedChainweb logger
-    = forall cas. (CanReadablePayloadCas cas, Logger logger) => StartedChainweb !(Chainweb logger cas)
-    | Replayed !Cut !Cut
+data StartedChainweb logger where
+  StartedChainweb :: (CanReadablePayloadCas cas, Logger logger) => !(Chainweb logger cas) -> StartedChainweb logger
+  Replayed :: !Cut -> !Cut -> StartedChainweb logger
 
 data ChainwebStatus
     = ProcessStarted
@@ -427,6 +427,7 @@ withChainwebInternal conf logger peer serviceSock rocksDb pactDbDir backupDir re
       , _pactBlockGasLimit = maybe id min maxGasLimit (_configBlockGasLimit conf)
       , _pactLogGas = _configLogGas conf
       , _pactModuleCacheLimit = _configModuleCacheLimit conf
+      , _pactFullHistoryRequired = _configRosetta conf -- this could be OR'd with other things that require full history
       }
 
     pruningLogger :: T.Text -> logger