diff --git a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal.hs b/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal.hs index f98b57f9..21903573 100644 --- a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal.hs +++ b/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 - good <- try @_ @NCQFsckException (ncqFileFastCheck path) + flip fix 0 $ \again i -> do - let corrupted = isLeft good + good <- try @_ @NCQFsckException (ncqFileFastCheck path) - when corrupted $ liftIO do - warn $ red "trim" <+> pretty s <+> red (pretty (fromIntegral s - realSize)) <+> pretty (takeFileName path) - PFS.setFileSize path (fromIntegral s) + let corrupted = isLeft good - debug $ yellow "indexing" <+> pretty dataFile <+> pretty s <+> color (pretty realSize) + if not corrupted then do + debug $ yellow "indexing" <+> pretty dataFile + 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 - ncqIndexFile me dataFile 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 diff --git a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Fossil.hs b/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Fossil.hs index e4a5a7b5..98e2fa7e 100644 --- a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Fossil.hs +++ b/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 diff --git a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/State.hs b/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/State.hs index fb663c6d..33991fd7 100644 --- a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/State.hs +++ b/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 diff --git a/hbs2-tests/test/NCQ3.hs b/hbs2-tests/test/NCQ3.hs index 337f3830..e7c33e43 100644 --- a/hbs2-tests/test/NCQ3.hs +++ b/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