Use deleteRange to clean up testRocksDb

This makes our rocksdb smaller, which makes certain tests faster, especially
the Cut property tests like meetAssociative which mine a lot of
blocks.
Change-Id: Id000000077e9012e622fc8577efd411f2fbb3993

libs/chainweb-storage/src/Chainweb/Storage/Table/RocksDB.hs

@@ -84,6 +84,7 @@ module Chainweb.Storage.Table.RocksDB
   -- * RocksDB-specific tools
   , checkpointRocksDb
   , deleteRangeRocksDb
+  , deleteNamespaceRocksDb
   , compactRangeRocksDb
   ) where
 
@@ -696,6 +697,18 @@ deleteRangeRocksDb table range = do
                 minKeyPtr (fromIntegral minKeyLen :: CSize)
                 maxKeyPtr (fromIntegral maxKeyLen :: CSize)
 
+-- | Batch delete all contents of rocksdb
+deleteNamespaceRocksDb :: HasCallStack => RocksDb -> IO ()
+deleteNamespaceRocksDb rdb = do
+    let R.DB dbPtr = _rocksDbHandle rdb
+    R.withCWriteOpts R.defaultWriteOptions $ \optsPtr ->
+        BU.unsafeUseAsCStringLen (namespaceFirst $ _rocksDbNamespace rdb) $ \(minKeyPtr, minKeyLen) ->
+        BU.unsafeUseAsCStringLen (namespaceLast $ _rocksDbNamespace rdb) $ \(maxKeyPtr, maxKeyLen) ->
+        checked "Chainweb.Storage.Table.RocksDB.deleteAllContentsRocksDb" $
+            C.rocksdb_delete_range dbPtr optsPtr
+                minKeyPtr (fromIntegral minKeyLen :: CSize)
+                maxKeyPtr (fromIntegral maxKeyLen :: CSize)
+
 compactRangeRocksDb :: HasCallStack => RocksDbTable k v -> (Maybe k, Maybe k) -> IO ()
 compactRangeRocksDb table range =
     BU.unsafeUseAsCStringLen (fst range') $ \(minKeyPtr, minKeyLen) ->

test/lib/Chainweb/Test/Cut.hs

@@ -97,8 +97,9 @@ import Chainweb.Cut
 import Chainweb.Cut.Create
 import Chainweb.Graph
 import Chainweb.Payload
-import Chainweb.Test.Utils.BlockHeader
 import Chainweb.Test.TestVersions
+import Chainweb.Test.Utils.BlockHeader
+import Chainweb.Test.Utils
 import Chainweb.Time (Micros(..), Time, TimeSpan)
 import qualified Chainweb.Time as Time (second)
 import Chainweb.Utils
@@ -665,9 +666,10 @@ ioTest
     -> ChainwebVersion
     -> (WebBlockHeaderDb -> T.PropertyM IO Bool)
     -> T.Property
-ioTest db v f = T.monadicIO $
-    liftIO (initWebBlockHeaderDb db v) >>= f >>= T.assert
+ioTest baseDb v f = T.monadicIO $ do
+    db' <- liftIO $ testRocksDb "Chainweb.Test.Cut" baseDb
+    liftIO (initWebBlockHeaderDb db' v) >>= f >>= T.assert
+    liftIO $ deleteNamespaceRocksDb db'
 
 pickBlind :: T.Gen a -> T.PropertyM IO a
 pickBlind = fmap T.getBlind . T.pick . fmap T.Blind
-

test/lib/Chainweb/Test/Cut/TestBlockDb.hs

@@ -10,7 +10,6 @@
 
 module Chainweb.Test.Cut.TestBlockDb
   ( TestBlockDb(..)
-  , withTestBlockDb
   , mkTestBlockDb
   , addTestBlockDb
   , getParentTestBlockDb
@@ -24,15 +23,18 @@ module Chainweb.Test.Cut.TestBlockDb
 
 import Control.Concurrent.MVar
 import Control.Lens
+import Control.Monad
 import Control.Monad.Catch
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Resource
 import qualified Data.HashMap.Strict as HM
 
 import Chainweb.Block
 import Chainweb.BlockHeader
 import Chainweb.BlockHeaderDB
 import Chainweb.ChainId
 import Chainweb.Cut
-import Chainweb.Test.Utils (testRocksDb)
+import Chainweb.Test.Utils
 import Chainweb.Test.Cut (GenBlockTime, testMine', MineFailure(BadAdjacents))
 import Chainweb.Payload
 import Chainweb.Payload.PayloadStore
@@ -43,7 +45,6 @@ import Chainweb.WebBlockHeaderDB
 
 import Chainweb.Storage.Table.RocksDB
 import Chainweb.BlockHeight
-import Control.Monad
 
 data TestBlockDb = TestBlockDb
   { _bdbWebBlockHeaderDb :: WebBlockHeaderDb
@@ -55,22 +56,17 @@ instance HasChainwebVersion TestBlockDb where
   _chainwebVersion = _chainwebVersion . _bdbWebBlockHeaderDb
 
 -- | Initialize TestBlockDb.
-withTestBlockDb :: ChainwebVersion -> (TestBlockDb -> IO a) -> IO a
-withTestBlockDb cv a = do
-  withTempRocksDb "TestBlockDb" $ \rdb -> do
-    bdb <- mkTestBlockDb cv rdb
-    a bdb
-
--- | Initialize TestBlockDb.
-mkTestBlockDb :: ChainwebVersion -> RocksDb -> IO TestBlockDb
+mkTestBlockDb :: ChainwebVersion -> RocksDb -> ResourceT IO TestBlockDb
 mkTestBlockDb cv rdb = do
-    testRdb <- testRocksDb "mkTestBlockDb" rdb
+  testRdb <- withTestRocksDb "mkTestBlockDb" rdb
+  liftIO $ do
     wdb <- initWebBlockHeaderDb testRdb cv
     let pdb = newPayloadDb testRdb
     initializePayloadDb cv pdb
     initCut <- newMVar $ genesisCut cv
     return $! TestBlockDb wdb pdb initCut
 
+
 -- | Add a block.
 --
 -- Returns False when mining fails due to BadAdjacents, which usually means that

test/lib/Chainweb/Test/Pact4/Utils.hs

@@ -100,7 +100,6 @@ module Chainweb.Test.Pact4.Utils
 , freeGasModel
 , testPactServiceConfig
 , withBlockHeaderDb
-, withTemporaryDir
 , withSqliteDb
 -- * Mempool utils
 , delegateMemPoolAccess
@@ -160,8 +159,6 @@ import Database.SQLite3.Direct (Database)
 import GHC.Generics
 
 import Streaming.Prelude qualified as S
-import System.Directory
-import System.IO.Temp (createTempDirectory)
 import System.LogLevel
 
 import Test.Tasty
@@ -947,11 +944,6 @@ withBlockHeaderDb iordb b = withResource start stop
         testBlockHeaderDb rdb b
     stop = closeBlockHeaderDb
 
-withTemporaryDir :: (IO FilePath -> TestTree) -> TestTree
-withTemporaryDir = withResource
-    (getTemporaryDirectory >>= \d -> createTempDirectory d "test-pact")
-    removeDirectoryRecursive
-
 -- | Single-chain Pact via service queue.
 --
 --   The difference between this and 'withPactTestBlockDb' is that,
@@ -969,7 +961,7 @@ withPactTestBlockDb'
     -> (IO (SQLiteEnv,PactQueue,TestBlockDb) -> TestTree)
     -> TestTree
 withPactTestBlockDb' version cid rdb sqlEnvIO mempoolIO pactConfig f =
-  withResource' (mkTestBlockDb version rdb) $ \bdbio ->
+  withResourceT (mkTestBlockDb version rdb) $ \bdbio ->
   withResource (startPact bdbio) stopPact $ f . fmap (view _2)
   where
     startPact bdbio = do
@@ -1023,8 +1015,8 @@ withPactTestBlockDb
     -> (IO (SQLiteEnv,PactQueue,TestBlockDb) -> TestTree)
     -> TestTree
 withPactTestBlockDb version cid rdb mempoolIO pactConfig f =
-  withTemporaryDir $ \iodir ->
-  withResource' (mkTestBlockDb version rdb) $ \bdbio ->
+  withResourceT (withTempDir "pact-dir") $ \iodir ->
+  withResourceT (mkTestBlockDb version rdb) $ \bdbio ->
   withResource (startPact bdbio iodir) stopPact $ f . fmap (view _2)
   where
     startPact bdbio iodir = do

test/lib/Chainweb/Test/Pact4/VerifierPluginTest/Transaction.hs

@@ -12,6 +12,7 @@ module Chainweb.Test.Pact4.VerifierPluginTest.Transaction
 
 import Control.Lens hiding ((.=))
 import Control.Monad.Reader
+import Data.IORef
 import qualified Data.Vector as V
 import Test.Tasty
 import Test.Tasty.HUnit
@@ -28,18 +29,19 @@ import Pact.Types.Verifier hiding (verifierName)
 
 import Chainweb.Miner.Pact
 import Chainweb.Pact.Types
+import Chainweb.Storage.Table.RocksDB
 import Chainweb.Test.Cut.TestBlockDb
 import Chainweb.Test.Pact4.Utils
+import Chainweb.Test.Utils
+import Chainweb.Version
 
 import qualified Chainweb.Test.Pact4.VerifierPluginTest.Transaction.Message.After225 as After225
 import qualified Chainweb.Test.Pact4.VerifierPluginTest.Transaction.Message.Before225 as Before225
 import Chainweb.Test.Pact4.VerifierPluginTest.Transaction.Utils
-import Data.IORef
-import Chainweb.Version
 
 
-tests :: TestTree
-tests = testGroup testName
+tests :: RocksDb -> TestTree
+tests rdb = testGroup testName
   [ test generousConfig "verifierTest" verifierTest
 
   , test generousConfig "recoverValidatorAnnouncementSuccess" hyperlaneRecoverValidatorAnnouncementSuccess
@@ -49,8 +51,8 @@ tests = testGroup testName
       hyperlaneRecoverValidatorAnnouncementDifferentSignerFailure
 
   , testGroup "Message"
-    [ Before225.tests
-    , After225.tests
+    [ Before225.tests rdb
+    , After225.tests rdb
     ]
   ]
   where
@@ -60,8 +62,9 @@ tests = testGroup testName
     generousConfig = testPactServiceConfig { _pactNewBlockGasLimit = 300_000 }
 
     test pactConfig tname f =
-      testCaseSteps tname $ \step ->
-        withTestBlockDb testVersion $ \bdb -> do
+      withResourceT (mkTestBlockDb testVersion rdb) $ \bdbIO -> do
+        testCaseSteps tname $ \step -> do
+          bdb <- bdbIO
           let logger = hunitDummyLogger step
           mempools <- onAllChains testVersion $ \_ -> do
             mempoolRef <- newIORef mempty

test/lib/Chainweb/Test/Pact4/VerifierPluginTest/Transaction/Message/After225.hs

@@ -28,8 +28,10 @@ import Pact.Types.Verifier hiding (verifierName)
 
 import Chainweb.Miner.Pact
 import Chainweb.Pact.Types
+import Chainweb.Storage.Table.RocksDB
 import Chainweb.Test.Cut.TestBlockDb
 import Chainweb.Test.Pact4.Utils
+import Chainweb.Test.Utils
 import Chainweb.Utils
 import Chainweb.Utils.Serialization
 import Chainweb.VerifierPlugin.Hyperlane.Binary
@@ -39,8 +41,8 @@ import Chainweb.Test.Pact4.VerifierPluginTest.Transaction.Utils
 import Chainweb.Version
 import Data.IORef
 
-tests :: TestTree
-tests = testGroup "After225"
+tests :: RocksDb -> TestTree
+tests rdb = testGroup "After225"
   [ test generousConfig "verifySuccess" hyperlaneVerifySuccess
   , test generousConfig "verifyMoreValidatorsSuccess" hyperlaneVerifyMoreValidatorsSuccess
   , test generousConfig "verifyThresholdZeroError" hyperlaneVerifyThresholdZeroError
@@ -55,16 +57,16 @@ tests = testGroup "After225"
     -- we can be generous.
     generousConfig = testPactServiceConfig { _pactNewBlockGasLimit = 300_000 }
 
-    test pactConfig tname f =
-      testCaseSteps tname $ \step ->
-        withTestBlockDb testVersion $ \bdb -> do
-          let logger = hunitDummyLogger step
-          mempools <- onAllChains testVersion $ \_ -> do
-            mempoolRef <- newIORef mempty
-            return (mempoolRef, delegateMemPoolAccess mempoolRef)
-          withWebPactExecutionService logger testVersion pactConfig bdb (snd <$> mempools) $ \(pact,_) ->
-            runReaderT f $
-            SingleEnv bdb pact (mempools ^?! atChain cid . _1) noMiner cid
+    test pactConfig tname f = withResourceT (mkTestBlockDb testVersion rdb) $ \bdbIO ->
+      testCaseSteps tname $ \step -> do
+        bdb <- bdbIO
+        let logger = hunitDummyLogger step
+        mempools <- onAllChains testVersion $ \_ -> do
+          mempoolRef <- newIORef mempty
+          return (mempoolRef, delegateMemPoolAccess mempoolRef)
+        withWebPactExecutionService logger testVersion pactConfig bdb (snd <$> mempools) $ \(pact,_) ->
+          runReaderT f $
+          SingleEnv bdb pact (mempools ^?! atChain cid . _1) noMiner cid
 
 -- hyperlane message tests
 

test/lib/Chainweb/Test/Pact4/VerifierPluginTest/Transaction/Message/Before225.hs

@@ -27,8 +27,10 @@ import Pact.Types.Verifier hiding (verifierName)
 
 import Chainweb.Miner.Pact
 import Chainweb.Pact.Types
+import Chainweb.Storage.Table.RocksDB
 import Chainweb.Test.Cut.TestBlockDb
 import Chainweb.Test.Pact4.Utils
+import Chainweb.Test.Utils
 import Chainweb.Utils
 import Chainweb.Utils.Serialization
 import Chainweb.VerifierPlugin.Hyperlane.Binary
@@ -38,8 +40,8 @@ import Chainweb.Test.Pact4.VerifierPluginTest.Transaction.Utils
 import Data.IORef
 import Chainweb.Version
 
-tests :: TestTree
-tests = testGroup "Before225"
+tests :: RocksDb -> TestTree
+tests rdb = testGroup "Before225"
   [ testGroup "MessageId metadata tests"
     [ test generousConfig "verifySuccess" hyperlaneVerifyMessageIdSuccess
     , test generousConfig "verifyEmptyRecoveredSignaturesSuccess" hyperlaneVerifyMessageIdEmptyRecoveredSignaturesSuccess
@@ -58,8 +60,9 @@ tests = testGroup "Before225"
     generousConfig = testPactServiceConfig { _pactNewBlockGasLimit = 300_000 }
 
     test pactConfig tname f =
-      testCaseSteps tname $ \step ->
-        withTestBlockDb testVersion $ \bdb -> do
+      withResourceT (mkTestBlockDb testVersion rdb) $ \bdbIO ->
+        testCaseSteps tname $ \step -> do
+          bdb <- bdbIO
           let logger = hunitDummyLogger step
           mempools <- onAllChains testVersion $ \_ -> do
             mempoolRef <- newIORef mempty