test harness for probes db

hbs2-storage-ncq/lib/HBS2/Storage/NCQ2.hs

@@ -287,6 +287,9 @@ ncqNewUniqFileName  me@NCQStorage2{..} pref suff = liftIO $ withSem ncqMiscSem d
 ncqEmptyKey :: ByteString
 ncqEmptyKey = BS.replicate ncqKeyLen 0
 
+ncqGetProbesDir :: NCQStorage2 -> FilePath
+ncqGetProbesDir me = ncqGetFileName me ".probes"
+
 ncqGetNewFossilName :: MonadIO m => NCQStorage2 -> m FilePath
 ncqGetNewFossilName me = ncqNewUniqFileName me "fossil-" ".data"
 
@@ -675,6 +678,9 @@ ncqStorageRun2 ncq@NCQStorage2{..} = flip runContT pure do
                 when (n == n0) STM.retry
 
 
+  spawnActivity probesDB
+
+
   ContT $ bracket none $ const $ liftIO do
     fhh <- atomically (STM.flushTQueue closeQ)
     for_ fhh ( closeFd . snd )
@@ -800,6 +806,16 @@ ncqStorageRun2 ncq@NCQStorage2{..} = flip runContT pure do
         alpha = 0.1
         step  = 1.00
 
+    probesDB = do
+      let dir = ncqGetProbesDir ncq
+      debug $ yellow "probesDB started" <+> pretty dir
+      mkdir dir
+
+      forever do
+        debug $ yellow "probesDB wip"
+        pause @'Seconds 10
+
+
 ncqSpawnJob :: forall m . MonadIO m => NCQStorage2 -> IO () -> m ()
 ncqSpawnJob NCQStorage2{..} m = atomically $ writeTQueue ncqJobQ m
 

hbs2-tests/test/TestNCQ.hs

@@ -1781,6 +1781,45 @@ main = do
           e -> throwIO $ BadFormException @C (mkList e)
 
 
+        entry $ bindMatch "test:ncq2:probes-db1" $ nil_ $ \e -> do
+
+          notice "test:ncq2:probes-db1"
+          runTest $ \TestEnv{..} -> do
+            g <- liftIO MWC.createSystemRandom
+            let dir = testEnvDir
+            let n = 30000
+            let p = 0.15
+
+            sizes <- replicateM n (uniformRM (4096, 256*1024) g)
+
+            hashes <- newTVarIO (mempty :: IntMap HashRef)
+
+            ncqWithStorage dir $ \sto -> void $ flip runContT pure do
+              notice $ "write" <+> pretty (List.length sizes) <+> pretty "random blocks"
+
+              ContT $ withAsync $ forever do
+                pause @'Seconds 0.5
+                p1 <-  uniformRM (0,1) g
+                when (p1 <= p) do
+                  hss <- readTVarIO hashes
+                  let s = maybe 0 fst $ IntMap.lookupMax hss
+                  i <- uniformRM (0,s) g
+                  let hm = IntMap.lookup i hss
+                  for_ hm $ \h -> do
+                    ncqDelEntry sto h
+                    atomically $ modifyTVar hashes (IntMap.delete i)
+
+              liftIO $ pooledForConcurrentlyN_ 8  sizes $ \s ->  do
+                h <- ncqPutBS sto (Just B) Nothing =<< genRandomBS g s
+                atomically do
+                  i <- readTVar hashes <&> IntMap.size
+                  modifyTVar hashes (IntMap.insert i h)
+
+              notice $ "written" <+> pretty n
+
+              pause @'Seconds 300
+
+
         hidden do
           internalEntries
           entry $ bindMatch "#!" $ nil_ $ const none