ncqFileTryRecover

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

@@ -7,6 +7,7 @@ import HBS2.Storage.NCQ3.Internal.State
 import HBS2.Storage.NCQ3.Internal.Run
 import HBS2.Storage.NCQ3.Internal.Memtable
 import HBS2.Storage.NCQ3.Internal.Files
+import HBS2.Storage.NCQ3.Internal.Fossil
 import HBS2.Storage.NCQ3.Internal.Index
 import HBS2.Storage.NCQ3.Internal.MMapCache
 
@@ -161,23 +162,35 @@ ncqTryLoadState me@NCQStorage3{..} = do
   atomically $ modifyTVar ncqState (<> new)
 
   for_ [ (d,s) | P (PData d s) <- Set.toList ncqStateFacts ] $ \(dataFile,s) -> do
+
     let path = ncqGetFileName me dataFile
     realSize <- fileSize path
 
     let sizewtf = realSize /= fromIntegral s
     let color = if sizewtf then red else id
 
+    flip fix 0 $ \again i -> do
+
       good <- try @_ @NCQFsckException (ncqFileFastCheck path)
 
       let corrupted = isLeft good
 
-    when corrupted $ liftIO do
+      if not corrupted then do
-      warn $ red "trim" <+> pretty s  <+> red (pretty (fromIntegral s - realSize)) <+> pretty (takeFileName path)
+        debug $ yellow "indexing" <+> pretty dataFile
-      PFS.setFileSize path (fromIntegral s)
-
-    debug $ yellow "indexing" <+> pretty dataFile <+> pretty s <+> color (pretty realSize)
-
         ncqIndexFile me dataFile
+      else do
+
+        o <- ncqFileTryRecover path
+        warn $ "ncqFileTryRecover" <+> pretty path <+> pretty o <+> parens (pretty realSize)
+
+        let best = if i < 1 then max s o else s
+
+        warn $ red "trim" <+> pretty s <+> pretty best  <+> red (pretty (fromIntegral best - realSize)) <+> pretty (takeFileName path)
+
+        liftIO $ PFS.setFileSize path (fromIntegral best)
+
+        if i <= 1 then again (succ i) else pure Nothing
+
 
   for_ (bad <> fmap snd rest) $ \f -> do
     let old = ncqGetFileName me (StateFile f)
@@ -204,19 +217,6 @@ ncqTryLoadState me@NCQStorage3{..} = do
 
 
 
-ncqEntryUnwrap :: ByteString
-               -> (ByteString, Either ByteString (NCQSectionType, ByteString))
-ncqEntryUnwrap source = do
-  let (k,v) = BS.splitAt ncqKeyLen (BS.drop 4 source)
-  (k, ncqEntryUnwrapValue v)
-{-# INLINE ncqEntryUnwrap #-}
-
-ncqEntryUnwrapValue :: ByteString
-                    -> Either ByteString (NCQSectionType, ByteString)
-ncqEntryUnwrapValue  v = case ncqIsMeta v of
-  Just meta -> Right (meta, BS.drop ncqPrefixLen v)
-  Nothing   -> Left v
-{-# INLINE ncqEntryUnwrapValue #-}
 
 
 class IsTomb a where

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

@@ -31,11 +31,26 @@ import System.Posix.Files ( getFileStatus
                           , setFileMode
                           )
 import System.Posix.Files qualified as PFS
-
+import Lens.Micro.Platform
 import UnliftIO.IO.File
 
 {-HLINT ignore "Functor law"-}
 
+ncqEntryUnwrap :: ByteString
+               -> (ByteString, Either ByteString (NCQSectionType, ByteString))
+ncqEntryUnwrap source = do
+  let (k,v) = BS.splitAt ncqKeyLen (BS.drop 4 source)
+  (k, ncqEntryUnwrapValue v)
+{-# INLINE ncqEntryUnwrap #-}
+
+ncqEntryUnwrapValue :: ByteString
+                    -> Either ByteString (NCQSectionType, ByteString)
+ncqEntryUnwrapValue  v = case ncqIsMeta v of
+  Just meta -> Right (meta, BS.drop ncqPrefixLen v)
+  Nothing   -> Left v
+{-# INLINE ncqEntryUnwrapValue #-}
+
+
 ncqFossilMergeStep :: forall m . MonadUnliftIO m
                => NCQStorage3
                -> m Bool
@@ -115,6 +130,62 @@ ncqFossilMergeStep me@NCQStorage3{..}  = withSem ncqServiceSem $ flip runContT p
 
   pure True
 
+ncqFileFastCheck :: MonadUnliftIO m => FilePath -> m ()
+ncqFileFastCheck fp = do
+
+  -- debug $ "ncqFileFastCheck" <+> pretty fp
+
+  mmaped <- liftIO $ mmapFileByteString fp Nothing
+  let size = BS.length mmaped
+  let s = BS.drop (size - 8) mmaped & N.word64
+
+  unless ( BS.length mmaped == fromIntegral s ) do
+    throwIO $ NCQFsckIssueExt (FsckInvalidFileSize (fromIntegral s))
+
+ncqFileTryRecover :: MonadUnliftIO m => FilePath -> m NCQOffset
+ncqFileTryRecover fp = do
+
+  debug $ yellow  "ncqFileTryRecover" <+> pretty fp
+
+  mmaped <- liftIO $ mmapFileByteString fp Nothing
+
+  r <- flip runContT pure $ callCC \exit -> do
+
+    flip fix (0,0,mmaped) $ \next (o,r,bs) -> do
+
+      when (BS.length bs < ncqSLen) $ exit r
+
+      let (s0,rest)  = BS.splitAt  ncqSLen bs & over _1 (fromIntegral . N.word32)
+
+      when (BS.length rest < fromIntegral s0 || BS.length rest < ncqKeyLen) $ exit r
+
+      let (entry, rest2) = BS.splitAt (ncqSLen + s0) bs
+
+      let nextOff = o + ncqSLen + s0
+
+      case ncqEntryUnwrap entry of
+        (_, Left bs)      -> next (nextOff,r,mempty)
+
+        (k, Right (M, s)) -> do
+          let w0 = N.word64 s
+          let w1 = w0 - zeroSyncEntrySize
+          let hk  = coerce @_ @HashRef k
+          let hhs = HashRef $ hashObject @HbSync s
+
+          let thisIsHead = nextOff == fromIntegral w0 && hk == hhs
+
+          -- debug $ yellow "HEAD?" <+> pretty thisIsHead
+          --                        <+> pretty nextOff <+> pretty hhs
+
+          if thisIsHead then
+            next (nextOff, nextOff, rest2)
+          else
+            next (nextOff, r, mempty)
+
+        (_, Right (t, _)) -> next (nextOff, r, rest2)
+
+  pure $ fromIntegral r
+
 
 writeFiltered :: forall m . MonadIO m
               => NCQStorage3

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

@@ -95,17 +95,6 @@ ncqStateDelIndexFile fk  = do
 sortIndexes :: NCQState -> NCQState
 sortIndexes = over #ncqStateIndex (List.sortOn fst)
 
-ncqFileFastCheck :: MonadUnliftIO m => FilePath -> m ()
-ncqFileFastCheck fp = do
-
-  -- debug $ "ncqFileFastCheck" <+> pretty fp
-
-  mmaped <- liftIO $ mmapFileByteString fp Nothing
-  let size = BS.length mmaped
-  let s = BS.drop (size - 8) mmaped & N.word64
-
-  unless ( BS.length mmaped == fromIntegral s ) do
-    throwIO $ NCQFsckIssueExt (FsckInvalidFileSize (fromIntegral s))
 
 ncqStateCapture :: forall m . MonadUnliftIO m
             => NCQStorage3

hbs2-tests/test/NCQ3.hs

@@ -304,16 +304,17 @@ ncq3Tests = do
               Just p -> pure p
               Nothing -> liftIO $ Temp.createTempDirectory "." "ncq-long-write-test"
 
-    let writtenLog = path </> "written.log"
-    touch writtenLog
 
     ncqWithStorage3 path $ \sto -> do
 
+      let writtenLog = ncqGetFileName sto "written.log"
+      touch writtenLog
+
       race (pause @'Seconds (realToFrac seconds) >> ncqStorageStop3 sto) $ forever do
         n <- liftIO  $ uniformRM (1, 256*1024) g
         s <- liftIO $ genRandomBS g n
         h <- ncqPutBS sto (Just B) Nothing s
-        liftIO $ appendFile writtenLog (show (pretty h <> line))
+        liftIO $ appendFile writtenLog (show (pretty h <+> pretty n <> line))
         none
 
 
@@ -354,7 +355,42 @@ ncq3Tests = do
 
       lift $ ncqWithStorage3 path $ \sto -> do
         notice "okay?"
-        pause @'Seconds 5
+        let log = ncqGetFileName sto "written.log"
+        hashes <- liftIO (readFile log) <&> fmap words . lines
+
+        found       <- newTVarIO 0
+        foundBytes  <- newTVarIO 0
+        missedN     <- newTVarIO 0
+        missedBytes <- newTVarIO 0
+
+        for_ hashes $ \case
+          [hs, slen] -> do
+
+            let h = fromString hs
+            let s = read slen :: Int
+
+            what <- ncqLocate sto h >>= mapM (ncqGetEntryBS sto) <&> join
+
+            case what of
+              Just{}  -> do
+                atomically do
+                  modifyTVar found succ
+                  modifyTVar foundBytes (+s)
+
+              Nothing -> do
+                atomically do
+                  modifyTVar missedN succ
+                  modifyTVar missedBytes (+s)
+
+
+          _ -> error "invalid record"
+
+        f  <- readTVarIO found
+        fb <- readTVarIO foundBytes
+        mb <- readTVarIO missedBytes
+        mn <- readTVarIO missedN
+
+        notice  $ "results (found/lost)" <+> pretty f <+> pretty fb <+> "/" <+> pretty mn <+> pretty mb
 
     none