test, check entry hash on read

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

@@ -11,6 +11,8 @@ module HBS2.Storage.NCQ3
   , ncqLocate
   , ncqDelEntry
   , ncqEntrySize
+  , ncqEntryUnwrapValue
+  , ncqEntryUnwrap
   )
   where
 
@@ -21,5 +23,7 @@ import HBS2.Storage.NCQ3.Internal.Run
 import HBS2.Storage.NCQ3.Internal.State
 import HBS2.Storage.NCQ3.Internal.Memtable
 import HBS2.Storage.NCQ3.Internal.Index
+import HBS2.Storage.NCQ3.Internal.Fossil
+
 
 

hbs2-tests/test/NCQ3.hs

@@ -334,14 +334,19 @@ ncq3Tests = do
 
       let path = path0 </> show p
 
-      notice $ "Run" <+> pretty testEnvDir <+> pretty (sec2 s)
+      p <- ContT $ withProcessWait (proc self ["debug off"
-
+                                              , "and"
-      p <- ContT $ withProcessWait (proc self ["test:ncq3:long-write", show (pretty seconds), path])
+                                              , "test:ncq3:long-write", show (pretty seconds), path
+                                              ])
 
       pid <- liftIO (PT.getPid p) `orDie` "oopsie!"
 
-      delta <- liftIO $ uniformRM (0.25, s - 0.10) g
+      delta <- liftIO $ uniformRM (0.25, s + 0.10) g
-      notice $ green "PID" <+> viaShow pid <+>  "wait" <+> pretty delta
+
+      notice $ "Run" <+> "test:ncq3:long-write"
+              <+> green "pid" <+> viaShow pid
+              <+> pretty testEnvDir
+              <+> pretty (sec2 s)
 
       pause @'Seconds (realToFrac delta)
 
@@ -351,10 +356,7 @@ ncq3Tests = do
 
       pause @'Seconds 2
 
-      notice "Try open storage"
+      lift $ ncqWithStorage3 path $ \sto@NCQStorage3{..} -> do
-
-      lift $ ncqWithStorage3 path $ \sto -> do
-        notice "okay?"
         let log = ncqGetFileName sto "written.log"
         hashes <- liftIO (readFile log) <&> fmap words . lines
 
@@ -372,10 +374,31 @@ ncq3Tests = do
             what <- ncqLocate sto h >>= mapM (ncqGetEntryBS sto) <&> join
 
             case what of
-              Just{}  -> do
+              Just bs  -> do
-                atomically do
+
-                  modifyTVar found succ
+                ok <- case ncqEntryUnwrap bs of
-                  modifyTVar foundBytes (+s)
+                           (_, Left{}) -> pure False
+
+                           (k, Right (B, bss)) -> do
+                             let good = HashRef (hashObject @HbSync bss) == h
+                             -- debug $ "WTF?" <+> pretty (coerce @_ @HashRef k)
+                             --                 <+> pretty good
+                             --                 <+> pretty s
+                             --                 <+> pretty (BS.length bss)
+                             pure good
+
+                           (_,Right (_, s)) -> pure True
+
+                if ok then do
+
+                  atomically do
+                    modifyTVar found succ
+                    modifyTVar foundBytes (+s)
+                else do
+                  atomically do
+                    modifyTVar missedN succ
+                    modifyTVar missedBytes (+s)
+                  -- err $ red "Entry corrupted!"
 
               Nothing -> do
                 atomically do
@@ -390,9 +413,12 @@ ncq3Tests = do
         mb <- readTVarIO missedBytes
         mn <- readTVarIO missedN
 
-        notice  $ "results (found/lost)" <+> pretty f <+> pretty fb <+> "/" <+> pretty mn <+> pretty mb
+        let okay = if mb <= ncqFsync then green "OK" else red "FAIL"
 
-    none
+        notice $ okay <+> "(found/lost)"
+              <+> pretty f <+> pretty fb <+>
+              "/"
+              <+> pretty mn <+> pretty mb
 
   entry $ bindMatch "test:ncq3:concurrent1" $ nil_ $ \case
     [ LitIntVal tn, LitIntVal n ] -> do