From 3639ccec25657b406559750967b13797c752404e Mon Sep 17 00:00:00 2001 From: voidlizard Date: Thu, 22 May 2025 13:02:24 +0300 Subject: [PATCH] wip --- hbs2-cli/lib/HBS2/CLI/Run/Tree.hs | 11 + hbs2-peer/app/PeerMain.hs | 2 +- hbs2-storage-ncq/lib/HBS2/Storage/NCQ.hs | 171 ++++++++-- hbs2-tests/test/TCQ.hs | 11 + hbs2-tests/test/TestNCQ.hs | 313 +++++++++++++----- .../Data/Config/Suckless/Script/Internal.hs | 2 +- .../lib/Data/Config/Suckless/Syntax.hs | 3 + 7 files changed, 400 insertions(+), 113 deletions(-) diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Tree.hs b/hbs2-cli/lib/HBS2/CLI/Run/Tree.hs index 1614831e..2d9902a9 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/Tree.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/Tree.hs @@ -186,3 +186,14 @@ It's just an easy way to create a such thing, you may browse it by hbs2 cat -H _ -> throwIO (BadFormException @c nil) + brief "shallow scan of a block/tree" $ + entry $ bindMatch "hbs2:tree:scan:deep:stdout" $ nil_ \case + [HashLike href] -> do + sto <- getStorage + + deepScan ScanDeep (const none) (coerce href) (getBlock sto) $ \ha -> do + liftIO $ print $ pretty ha + + _ -> throwIO (BadFormException @c nil) + + diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index 24e296ca..7e452d26 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -846,7 +846,7 @@ runPeer opts = respawnOnError opts $ flip runContT pure do notice $ "run peer" <+> pretty (AsBase58 (view peerSignPk pc)) - debug $ "STORAGE PREFIX" <+> pretty pref + notice $ red "STORAGE PREFIX" <+> pretty pref -- error "STOP" diff --git a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ.hs b/hbs2-storage-ncq/lib/HBS2/Storage/NCQ.hs index 88d1e14e..54a6a22f 100644 --- a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ.hs +++ b/hbs2-storage-ncq/lib/HBS2/Storage/NCQ.hs @@ -170,6 +170,36 @@ data NCQStorage = } +-- Log structure: +-- (SD)* +-- S ::= word32be, section prefix +-- D ::= HASH PREFIX DATA +-- HASH ::= BYTESTRING(32) +-- PREFIX ::= BYTESTRING(4) +-- DATA ::= BYTESTRING(n) | n == S - LEN(WORD32) - LEN(HASH) - LEN(PREFIX) + +newtype NCQFullRecordLen a = + NCQFullRecordLen a + deriving newtype (Num,Enum,Integral,Real,Ord,Eq) + +-- including prefix +ncqFullDataLen :: forall a . Integral a => NCQFullRecordLen a -> a +ncqFullDataLen full = fromIntegral full - ncqKeyLen +{-# INLINE ncqFullDataLen #-} + +ncqKeyLen :: forall a . Integral a => a +ncqKeyLen = 32 +{-# INLINE ncqKeyLen #-} + +-- 'S' in SD, i.e size, i.e section header +ncqSLen:: forall a . Integral a => a +ncqSLen = 4 +{-# INLINE ncqSLen #-} + +ncqDataOffset :: forall a b . (Integral a, Integral b) => a -> b +ncqDataOffset base = fromIntegral base + ncqSLen + ncqKeyLen +{-# INLINE ncqDataOffset #-} + instance MonadUnliftIO m => Storage NCQStorage HbSync LBS.ByteString m where putBlock ncq lbs = fmap coerce <$> ncqStoragePutBlock ncq lbs enqueueBlock ncq lbs = fmap coerce <$> ncqStoragePutBlock ncq lbs @@ -412,6 +442,10 @@ ncqStorageRun ncq@NCQStorage{..} = flip runContT pure do atomically $ modifyTVar ncqCurrentUsage (IntMap.adjust pred (fromIntegral fd)) fdSeek fd AbsoluteSeek (fromIntegral $ 4 + 32 + off) bs <- Posix.fdRead fd (fromIntegral l) + + unless (BS.length bs == fromIntegral l) do + err $ "READ MISMATCH" <+> pretty l <+> pretty (BS.length bs) + atomically $ putTMVar answ bs link reader @@ -473,7 +507,7 @@ ncqStorageRun ncq@NCQStorage{..} = flip runContT pure do what' <- race (pause @'Seconds 1) $ atomically do stop <- readTVar ncqStopped q <- tryPeekTQueue indexQ - if not (stop || isJust q) then + if not ( stop || isJust q) then STM.retry else do STM.flushTQueue indexQ @@ -515,7 +549,6 @@ ncqStorageRun ncq@NCQStorage{..} = flip runContT pure do Nothing -> pure mempty Just (h,_,WQItem{..},rest) -> do - off <- fdSeek fh SeekFromEnd 0 -- we really have to write tomb prefix here let b = byteString (coerce @_ @ByteString h) @@ -524,7 +557,9 @@ ncqStorageRun ncq@NCQStorage{..} = flip runContT pure do let wbs = toLazyByteString b let len = LBS.length wbs let ws = N.bytestring32 (fromIntegral len) - let w = 4 + len + let w = ncqSLen + len + + off <- fdSeek fh SeekFromEnd 0 if isNothing wqData && wqNew then pure () @@ -539,9 +574,10 @@ ncqStorageRun ncq@NCQStorage{..} = flip runContT pure do fsize <- getFdStatus fh <&> PFS.fileSize pure (0,fromIntegral fsize) - now <- readTVarIO ncqIndexNow - if sz < ncqMinLog && now <= 0 then do + -- off <- fdSeek fh SeekFromEnd 0 <&> subtract (fromIntegral w) + + if sz < ncqMinLog then do ((h, (fromIntegral off, fromIntegral len)) : ) <$> next (written', rest) else do pure [(h, (fromIntegral off, fromIntegral len))] @@ -563,14 +599,15 @@ ncqStorageRun ncq@NCQStorage{..} = flip runContT pure do [] -> pure (q,w) ((h,(o,l)):xs) -> do modifyTVar wbytes (+l) - next (HPSQ.delete h q, HPSQ.insert h now1 (o,l) w,xs) + let recLen = ncqFullDataLen (NCQFullRecordLen l) + next (HPSQ.delete h q, HPSQ.insert h now1 (o,recLen) w,xs) writeTVar ncqWriteQueue rq modifyTVar ncqStaged (IntMap.insert (fromIntegral fdr) rw) bw <- readTVar wbytes writeTVar ncqNotWritten (max 0 (b0 - bw)) - indexNow <- atomically $ stateTVar ncqIndexNow (,0) + indexNow <- readTVarIO ncqIndexNow when (fromIntegral size >= ncqMinLog || indexNow > 0) do @@ -598,6 +635,7 @@ ncqStorageRun ncq@NCQStorage{..} = flip runContT pure do -- то есть должны отнять 1 после индексации. modifyTVar ncqCurrentUsage (IntMap.insertWith (+) (fromIntegral fdr) 1) writeTQueue indexQ (fdr, fossilized) + writeTVar ncqIndexNow 0 closeFd fh writeBinaryFileDurable (ncqGetCurrentSizeName ncq) (N.bytestring64 0) @@ -706,6 +744,15 @@ ncqStorageGetBlock ncq h = do Just lbs | not (ncqIsTomb lbs) -> pure (Just $ LBS.drop ncqPrefixLen lbs) _ -> pure Nothing +data NCQSectionType = B | R | T + deriving stock (Eq,Ord,Show) + +instance Pretty NCQSectionType where + pretty = \case + B -> "B" + T -> "T" + R -> "R" + ncqPrefixLen :: Integral a => a ncqPrefixLen = 4 {-# INLINE ncqPrefixLen #-} @@ -832,20 +879,20 @@ ncqStorageScanDataFile ncq fp' action = do flip runContT pure $ callCC \exit -> do flip fix (0,mmaped) $ \next (o,bs) -> do - when (BS.length bs < 4) $ exit () + when (BS.length bs < ncqSLen) $ exit () - let w = BS.take 4 bs & N.word32 & fromIntegral + let w = BS.take ncqSLen bs & N.word32 & fromIntegral - when (BS.length bs < 4 + w) $ exit () + when (BS.length bs < ncqSLen + w) $ exit () - let kv = BS.drop 4 bs + let kv = BS.drop ncqSLen bs - let k = BS.take 32 kv & coerce @_ @HashRef - let v = BS.take (w-32) $ BS.drop 32 kv + let k = BS.take ncqKeyLen kv & coerce @_ @HashRef + let v = BS.take (ncqFullDataLen (NCQFullRecordLen w)) $ BS.drop ncqKeyLen kv lift (action o (fromIntegral w) k v) - next (4 + o + fromIntegral w, BS.drop (w+4) bs) + next (ncqSLen + o + fromIntegral w, BS.drop (w+ncqSLen) bs) ncqStorageGet :: MonadUnliftIO m => NCQStorage -> HashRef -> m (Maybe LBS.ByteString) ncqStorageGet ncq h = runMaybeT do @@ -869,7 +916,7 @@ ncqStorageGet_ ncq@NCQStorage{..} = \case InFossil ce (o,l) -> do now <- getTimeCoarse atomically $ writeTVar (cachedTs ce) now - let chunk = BS.take (fromIntegral l) (BS.drop (fromIntegral o + 4 + 32) (cachedMmapedData ce)) + let chunk = BS.take (fromIntegral l) (BS.drop (ncqDataOffset o) (cachedMmapedData ce)) pure $ Just $ LBS.fromStrict chunk _ -> pure Nothing @@ -884,7 +931,7 @@ ncqStorageGetRef ncq ref = runMaybeT do lbs <- lift (ncqStorageGet ncq h) >>= toMPlus guard (not $ ncqIsTomb lbs) let hbs = LBS.toStrict (LBS.drop ncqPrefixLen lbs) - guard (BS.length hbs == 32) + guard (BS.length hbs == ncqKeyLen) pure $ coerce hbs where h = ncqRefHash ncq ref @@ -907,8 +954,9 @@ ncqStorageDel ncq@NCQStorage{..} h = flip runContT pure $ callCC \exit -> do now <- getTimeCoarse let writeTombstone wq = do + let recordPrefixLen = ncqSLen + ncqKeyLen + ncqPrefixLen modifyTVar ncqWriteQueue (HPSQ.insert h now wq) - modifyTVar ncqNotWritten (+ (4 + 32 + ncqPrefixLen)) + modifyTVar ncqNotWritten (+ recordPrefixLen) ncqLocate ncq h >>= atomically . \case Just (InFossil _ _) -> writeTombstone (WQItem False Nothing) @@ -1018,19 +1066,19 @@ ncqStorageOpen fp' = do items <- S.toList_ <$> flip runContT pure $ callCC \exit ->do flip fix (0,bs0) $ \next (o,bs) -> do - when (BS.length bs < 4) $ exit () - let w = BS.take 4 bs & N.word32 & fromIntegral - let p = BS.take w (BS.drop 4 bs) + when (BS.length bs < ncqSLen) $ exit () + let w = BS.take ncqSLen bs & N.word32 & fromIntegral + let p = BS.take w (BS.drop ncqSLen bs) when (BS.length p < w ) do throwIO NCQStorageBrokenCurrent - let k = BS.take 32 p & coerce . BS.copy - let vs = w - 32 + let k = BS.take ncqKeyLen p & coerce . BS.copy + let vs = ncqFullDataLen (NCQFullRecordLen w) lift $ S.yield (k,now, (fromIntegral o, fromIntegral vs)) - next (o+w+4, BS.drop (w+4) bs) + next (o+w+ncqSLen, BS.drop (w+ncqSLen) bs) atomically $ modifyTVar ncqStaged (IntMap.insert (fromIntegral fd) (HPSQ.fromList items)) @@ -1148,7 +1196,7 @@ ncqStorageInit_ check path = do <&> fromRight 0 <&> fromIntegral - if | currSz > lastSz -> do + if | currSz > lastSz -> do fossilized <- ncqGetNewFossilName ncq0 debug $ "NEW FOSSIL FILE" <+> pretty fossilized let fn = takeFileName fossilized @@ -1173,6 +1221,81 @@ ncqStorageInit_ check path = do pure ncq + +data NCQFsckException = + NCQFsckException + deriving stock (Show,Typeable) + +instance Exception NCQFsckException + +data NCQFsckIssueType = + FsckInvalidPrefix + | FsckInvalidContent + | FsckInvalidFileSize + deriving stock (Eq,Ord,Show,Data,Generic) + +data NCQFsckIssue = + NCQFsckIssue FilePath Word64 NCQFsckIssueType + deriving stock (Eq,Ord,Show,Data,Generic) + +ncqFsck :: MonadUnliftIO m => FilePath -> m [NCQFsckIssue] +ncqFsck fp = do + isFile <- doesFileExist fp + if isFile then + ncqFsckOne fp + else do + fs <- dirFiles fp <&> List.filter ((== ".data") . takeExtension) + concat <$> mapM ncqFsckOne fs + +ncqFsckOne :: MonadUnliftIO m => FilePath -> m [NCQFsckIssue] +ncqFsckOne fp = do + mmaped <- liftIO $ mmapFileByteString fp Nothing + + toff <- newTVarIO 0 + issuesQ <- newTQueueIO + + let + emit :: forall m . MonadIO m => NCQFsckIssue -> m () + emit = atomically . writeTQueue issuesQ + + handle (\(_ :: ReadLogError) -> none) do + runConsumeBS mmaped do + readSections $ \size bs -> do + let ssz = LBS.length bs + let (hash, rest1) = LBS.splitAt 32 bs & over _1 (coerce . LBS.toStrict) + let (prefix, rest2) = LBS.splitAt ncqPrefixLen rest1 & over _1 LBS.toStrict + + let (prefixOk,pt) = if | prefix == ncqBlockPrefix -> (True, Just B) + | prefix == ncqRefPrefix -> (True, Just R) + | prefix == ncqTombPrefix -> (True, Just T) + | otherwise -> (False, Nothing) + + let contentOk = case pt of + Just B -> hash == hashObject @HbSync rest2 + _ -> True + + off <- readTVarIO toff + + unless prefixOk $ emit (NCQFsckIssue fp off FsckInvalidPrefix) + + unless contentOk $ emit (NCQFsckIssue fp off FsckInvalidContent) + + liftIO $ atomically $ modifyTVar toff (\x -> x + 4 + fromIntegral (LBS.length bs)) + + debug $ pretty (takeFileName fp) + <+> pretty size + <+> pretty ssz + <+> brackets (pretty $ maybe "E" show pt) + <+> brackets (if contentOk then pretty hash else "invalid hash") + + lastOff <- readTVarIO toff + + unless (fromIntegral (BS.length mmaped) == lastOff) do + emit (NCQFsckIssue fp lastOff FsckInvalidFileSize) + + atomically $ STM.flushTQueue issuesQ + + ncqStorageFlush :: MonadUnliftIO m => NCQStorage -> m () ncqStorageFlush = ncqStorageSync diff --git a/hbs2-tests/test/TCQ.hs b/hbs2-tests/test/TCQ.hs index a35db230..8ea0bfaa 100644 --- a/hbs2-tests/test/TCQ.hs +++ b/hbs2-tests/test/TCQ.hs @@ -254,6 +254,17 @@ main = do e -> throwIO $ BadFormException @C (mkList e) + entry $ bindMatch "ncq:fsck" $ nil_ \case + [ StringLike fpath ] -> lift do + issues <- ncqFsck fpath + + for_ issues $ \i -> do + err $ viaShow i + + unless (List.null issues) exitFailure + + e -> throwIO $ BadFormException @C (mkList e) + entry $ bindMatch "ncq:cached:entries" $ \case [ isOpaqueOf @TCQ -> Just tcq ] -> lift do NCQStorage{..} <- getNCQ tcq diff --git a/hbs2-tests/test/TestNCQ.hs b/hbs2-tests/test/TestNCQ.hs index 35a5e942..074326d7 100644 --- a/hbs2-tests/test/TestNCQ.hs +++ b/hbs2-tests/test/TestNCQ.hs @@ -12,6 +12,7 @@ import HBS2.Hash import HBS2.Data.Types.Refs import HBS2.Clock import HBS2.Merkle +import HBS2.Polling import HBS2.Storage import HBS2.Storage.Simple @@ -30,6 +31,7 @@ import Data.Config.Suckless.System import DBPipe.SQLite hiding (field) +import Data.Char import Data.Bits import Data.ByteString (ByteString) import Data.ByteString qualified as BS @@ -174,6 +176,125 @@ testNCQFuckupRecovery1 TestEnv{..} = flip runContT pure do notice $ "loaded" <+> pretty ha <+> pretty (LBS.length lbs) + +testNCQSimple1 :: MonadUnliftIO m => TestEnv -> m () +testNCQSimple1 TestEnv{..} = flip runContT pure do + let ncqDir = testEnvDir "ncq-simple" + + for_ [ 0 .. 18 ] $ \s -> do + let size = 2 ^ s + let payload = LBS.replicate size 0x41 -- 0x41 = 'A' + let expectedHash = hashObject @HbSync payload + + -- Step 1: Write block + lift $ withNCQ id ncqDir $ \ncq -> do + let sto = AnyStorage ncq + h <- putBlock sto payload `orDie` "failed to write block" + liftIO $ assertBool "hashes match (write)" (h == expectedHash) + + -- Step 2: Read back + lift $ withNCQ id ncqDir $ \ncq -> do + let sto = AnyStorage ncq + blk <- getBlock sto (coerce expectedHash) `orDie` "block not found" + sx <- hasBlock sto (coerce expectedHash) + + loc <- ncqLocate ncq (coerce expectedHash) + >>= orThrowUser "not found" + + blk0 <- ncqStorageGet_ ncq loc + + let sblk0 = LBS.length <$> blk0 + + liftIO $ print $ "block size" + <+> pretty sx + <+> ";" + <+> pretty (LBS.length blk) + <+> ";" + <+> pretty size + <+> ";" + <+> pretty sblk0 + <+> pretty loc + + liftIO $ do + assertBool "block has correct length" (LBS.length blk == size) + assertBool "block contents are correct" (blk == payload) + + +testNCQSimple2 :: MonadUnliftIO m => Int -> TestEnv -> m () +testNCQSimple2 n TestEnv{..} = flip runContT pure do + let ncqDir = testEnvDir "ncq-simple2" + + let alph_ = V.fromList ['A' .. 'z'] + cnt <- newTVarIO 0 + + let alphx = liftIO do + i <- atomically $ stateTVar cnt (\x -> (x, succ x)) + pure $ alph_ ! ( i `mod` V.length alph_) + + -- Step 1: write N blocks + hashes <- lift $ withNCQ id ncqDir $ \ncq -> do + let sto = AnyStorage ncq + replicateM n do + size <- liftIO $ randomRIO (0, 256 * 1024) + chr <- alphx + let payload = LBS.replicate size (fromIntegral $ ord chr) + let h = hashObject @HbSync payload + h' <- putBlock sto payload `orDie` "putBlock failed" + loc <- ncqLocate ncq (coerce h) + s <- hasBlock sto h + w <- getBlock sto h + let w' = fromMaybe mempty w + + if w == Just payload then do + debug $ "okay" <+> pretty loc + else do + err $ pretty s <> "/" <> pretty size + <+> viaShow (LBS.take 48 w') + <+> ".." + <+> viaShow (LBS.take 8 $ LBS.reverse w') + <> line + <+> pretty loc + + error "ABORTED" + + liftIO $ assertBool "hash matches" (h == h') + pure (h, size, payload) + + let testRead ncq = do + let sto = AnyStorage ncq + forM_ hashes $ \(h, expectedSize, expectedPayload) -> do + loc <- ncqLocate ncq (coerce h) >>= orThrowUser "not found" + blk <- getBlock sto (coerce h) `orDie` "block not found" + sx <- hasBlock sto (coerce h) + blk0 <- ncqStorageGet_ ncq loc + let sblk0 = LBS.length <$> blk0 + let actualSize = LBS.length blk + + debug $ "block size" + <+> pretty sx + <+> ";" + <+> pretty actualSize + <+> ";" + <+> pretty expectedSize + <+> ";" + <+> pretty sblk0 + <+> pretty loc + + liftIO do + assertBool "size match" (actualSize == expectedSize) + assertBool "payload match" (blk == expectedPayload) + + -- Step 2: reopen and verify + lift $ withNCQ id ncqDir $ \ncq -> do + testRead ncq + -- ncqIndexRightNow ncq + pause @'Seconds 2 + + liftIO $ print $ "LAST PASS" + -- Step 3: reopen and verify - fossil + lift $ withNCQ id ncqDir $ \ncq -> do + testRead ncq + testNCQ1 :: MonadUnliftIO m => Int -> TestEnv @@ -196,109 +317,113 @@ testNCQ1 n TestEnv{..} = flip runContT pure do let fname = inputDir show i <> ".bin" size <- randomRIO (1, 256*1024) atomically $ modifyTVar nSize (+size) - file <- LBS.take size <$> LBS.readFile "/dev/urandom" - BS.writeFile fname (BS.toStrict file) - pure fname + file <- LBS.toStrict . LBS.take size <$> LBS.readFile "/dev/urandom" + BS.writeFile fname file + let ha = hashObject @HbSync file + pure (fname, (ha, fromIntegral $ BS.length file)) - ncq <- liftIO $ ncqStorageOpen ncqDir - r <- liftIO $ async (ncqStorageRun ncq) - - let sto = AnyStorage ncq - - nWq <- newTVarIO 0 - nCu <- newTVarIO 0 - nFo <- newTVarIO 0 - nMissed <- newTVarIO 0 - - let - updateStats :: forall m . MonadIO m => NCQStorage -> HashRef -> m (Maybe Location) - updateStats ncq h = do - w <- ncqLocate ncq (coerce h) - - case w of - Just (InWriteQueue _) -> atomically $ modifyTVar nWq succ - Just (InCurrent _) -> atomically $ modifyTVar nCu succ - Just (InFossil _ _) -> atomically $ modifyTVar nFo succ - Nothing -> atomically $ modifyTVar nMissed succ - - pure w - - - t1 <- ContT $ withAsync $ fix \loop -> do - - what <- readTVarIO twritten - p <- randomRIO (0.01, 0.5) - pause @'Seconds (realToFrac p) - - forConcurrently_ what $ \h -> do - - w <- updateStats ncq h - - what <- ncqStorageHasBlockEither ncq (coerce h) - case what of - Left LocationNotFound | isJust w -> do - error $ show $ "FUCKING RACE!" <+> pretty w - - Left e -> throwIO e - Right _ -> none - - done <- readTVarIO (ncqStopped ncq) - unless done loop - - link t1 - -- - - out <- newTQueueIO liftIO do - forConcurrently_ fss $ \f -> do - -- debug $ "process file" <+> pretty f - blk <- BS.readFile f - h <- putBlock sto (LBS.fromStrict blk) `orDie` ("Can't store block " <> f) - atomically do - writeTQueue out (HashRef h) - modifyTVar twritten (HS.insert (coerce h)) + withNCQ id ncqDir $ \ncq -> flip runContT pure do - blkQ <- atomically do - STM.flushTQueue out + let sto = AnyStorage ncq + let fileMap = HM.fromList [ (ha,(s,fn)) | (fn,(ha,s)) <- fss ] - notice $ "WAIT BLOCKS DONE" <+> pretty (List.length blkQ) + let + written :: forall m a . (Fractional a, MonadIO m) => m [(HashRef, a)] + written = readTVarIO twritten <&> HS.toList <&> fmap (,0.1) - lift $ ncqStorageFlush ncq + ContT $ withAsync $ forever do + polling (Polling 0.25 0.25) written $ \(HashRef hz) -> liftIO $ void $ asyncLinked do + what <- getBlock sto hz >>= orThrowUser ("block not found" <+> pretty hz) + let h2 = hashObject @HbSync what - for_ blkQ $ \h -> liftIO do - void $ updateStats ncq h - hasBlock sto (coerce h) - `orDie` show ("missed" <+> pretty h) + (s,_) <- HM.lookup hz fileMap & orThrowUser "fileMap entry missed" - liftIO $ ncqStorageStop ncq + ssz <- hasBlock sto hz + >>= orThrowUser ("block size not found" <+> pretty hz) - wait t1 + when (ssz /= s) do + error $ show $ "size mismatch" <+> pretty hz - let vars = zip [ "write-q" - , "current" - , "fossil" - , "missed" - , "size" - ] - [nWq, nCu, nFo, nMissed, nSize] + when (hz /= h2) do + error $ show $ pretty "hash does not match" <+> pretty hz <+> pretty s - liftIO $ wait r + liftIO $ forConcurrently_ fss $ \(fn, (ha,s)) -> do + co <- liftIO (BS.readFile fn) <&> LBS.fromStrict + h1 <- putBlock sto co >>= orThrowUser "block not written" + lbs2 <- getBlock sto ha >>= orThrowUser "block not found" + let h2 = hashObject @HbSync lbs2 - lift $ withNCQ id ncqDir $ \ncq1 -> do - for_ blkQ $ \h -> liftIO do - void $ updateStats ncq1 h - hasBlock (AnyStorage ncq1) (coerce h) >>= \case - Nothing -> print $ "missed" <+> pretty h - Just x -> none + when (ha /= h2 || h1 /= ha) do + error $ show $ pretty "hash does not match" <+> pretty h1 <+> pretty s - results <- for vars $ \(k,w) -> do - v <- readTVarIO w - pure $ mkList @C [ mkSym k, mkInt v] + atomically $ modifyTVar twritten (HS.insert (HashRef h1)) - liftIO $ print $ pretty $ mkList (mkSym "results" : results) + debug $ "putBlock" <+> pretty ha <+> pretty h2 + + liftIO $ forConcurrently_ fss $ \(fn, (ha,s)) -> do + lbs2 <- getBlock sto ha >>= orThrowUser "block not found" + let h2 = hashObject @HbSync lbs2 + + when (ha /= h2) do + error $ show $ pretty "hash does not match" <+> pretty ha <+> pretty s + + debug $ "getBlock" <+> pretty ha <+> pretty h2 + + liftIO do + withNCQ id ncqDir $ \ncq -> flip runContT pure do + + let sto = AnyStorage ncq + + for_ fss $ \(fn, (ha,s)) -> do + lbs2 <- getBlock sto ha >>= orThrowUser "block not found" + let h2 = hashObject @HbSync lbs2 + + when (ha /= h2) do + error $ show $ pretty "hash does not match" <+> pretty ha <+> pretty s + + debug $ "getBlock" <+> pretty ha <+> pretty h2 +testNCQTree1 :: MonadUnliftIO m + => Int + -> TestEnv + -> m () + +testNCQTree1 n TestEnv{..} = flip runContT pure do + + let size = 1024 * 1024 * fromIntegral n + + let tmp = testEnvDir + + let inputDir = tmp "input" + let ncqDir = tmp "ncq-test-data" + + treeLbs <- LBS.take size <$> liftIO (LBS.readFile ("/dev/urandom")) + + let h1 = hashObject @HbSync treeLbs + + lift $ withNCQ id ncqDir $ \ncq1 -> do + + let sto = AnyStorage ncq1 + + r <- createTreeWithMetadata sto Nothing mempty treeLbs + >>= orThrowPassIO + + lbs2 <- runExceptT (getTreeContents sto r) + >>= orThrowPassIO + + let h2 = hashObject @HbSync lbs2 + + + let l1 = LBS.length treeLbs + let l2 = LBS.length treeLbs + display (mkList @C [mkSym r, mkSym h1, mkSym h2, mkInt l1, mkInt l2]) + + liftIO $ assertBool "hashes equal" (h1 == h2) + + -- display (mkSym @C $ show $ pretty r) testNCQRefs1 :: MonadUnliftIO m => Int @@ -404,6 +529,14 @@ main = do debug $ "test:ncq:fuckup-recovery1" runTest testNCQFuckupRecovery1 + entry $ bindMatch "test:ncq:test-simple1" $ nil_ $ \case + [] -> runTest $ testNCQSimple1 + e -> throwIO $ BadFormException @C (mkList e) + + entry $ bindMatch "test:ncq:test-simple2" $ nil_ $ \case + [ LitIntVal n ] -> runTest $ testNCQSimple2 (fromIntegral n) + e -> throwIO $ BadFormException @C (mkList e) + entry $ bindMatch "test:ncq:test1" $ nil_ $ \case [ LitIntVal n ] -> do debug $ "ncq:test1" <+> pretty n @@ -418,6 +551,12 @@ main = do e -> throwIO $ BadFormException @C (mkList e) + entry $ bindMatch "test:ncq:tree1" $ nil_ $ \case + [ LitIntVal n ] -> do + debug $ "ncq:tree1" <+> pretty n + runTest $ testNCQTree1 (fromIntegral n) + + e -> throwIO $ BadFormException @C (mkList e) entry $ bindMatch "test:ncq:test-lock" $ nil_ $ \case [ ] -> do diff --git a/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script/Internal.hs b/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script/Internal.hs index 21dcd6b6..b1f94c8d 100644 --- a/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script/Internal.hs +++ b/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script/Internal.hs @@ -1070,7 +1070,7 @@ bindCliArgs :: forall c m . (IsContext c, MonadUnliftIO m, Exception (BadFormExc bindCliArgs a = do bind "$*" (mkList a) bind "*args" (mkList a) - forM_ (zip [0..] a) $ \(i,e) -> do + forM_ (zip [1..] a) $ \(i,e) -> do bind (fromString ("$"<>show i)) e internalEntries :: forall c m . ( IsContext c diff --git a/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Syntax.hs b/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Syntax.hs index 13c7fc5c..23d0d1b6 100644 --- a/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Syntax.hs +++ b/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Syntax.hs @@ -365,6 +365,9 @@ instance MkId (String,Integer) where instance IsContext c => MkSym c Id where mkSym = Symbol noContext +instance {-# OVERLAPPABLE #-} (IsContext c, Pretty a) => MkSym c a where + mkSym a = Symbol noContext (mkId (show $ pretty a)) + class IsContext c => MkStr c s where mkStr :: s -> Syntax c