wip

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)
+
+

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"
 

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 k = BS.take ncqKeyLen kv & coerce @_ @HashRef
-     let v = BS.take (w-32) $ BS.drop 32 kv
+     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 ()
+            when (BS.length bs < ncqSLen) $ exit ()
-            let w = BS.take 4 bs & N.word32 & fromIntegral
+            let w = BS.take ncqSLen bs & N.word32 & fromIntegral
-            let p = BS.take w (BS.drop 4 bs)
+            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 k  = BS.take ncqKeyLen p & coerce . BS.copy
-            let vs = w - 32
+            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))
 
@@ -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
 

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

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"
+      file <- LBS.toStrict . LBS.take size <$> LBS.readFile "/dev/urandom"
-      BS.writeFile fname (BS.toStrict file)
+      BS.writeFile fname file
-      pure fname
+      let ha = hashObject @HbSync file
+      pure (fname, (ha, fromIntegral $ BS.length file))
 
-    ncq <- liftIO $ ncqStorageOpen ncqDir
+
-    r   <- liftIO $ async (ncqStorageRun ncq)
+    liftIO do
+      withNCQ id ncqDir $ \ncq -> flip runContT pure do
+
+        let sto = AnyStorage ncq
+        let fileMap = HM.fromList [ (ha,(s,fn)) | (fn,(ha,s)) <- fss ]
+
+        let
+          written :: forall m a . (Fractional a, MonadIO m) => m [(HashRef, a)]
+          written = readTVarIO twritten <&> HS.toList <&> fmap (,0.1)
+
+        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
+
+            (s,_) <- HM.lookup hz fileMap & orThrowUser "fileMap entry  missed"
+
+            ssz <- hasBlock sto hz
+                     >>= orThrowUser ("block size not found" <+> pretty hz)
+
+            when (ssz /= s) do
+              error $ show $ "size mismatch" <+> pretty hz
+
+            when (hz /= h2) do
+              error $ show $ pretty "hash does not  match" <+> pretty hz <+> pretty s
+
+        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
+
+          when (ha /= h2 || h1 /= ha) do
+            error $ show $ pretty "hash does not  match" <+> pretty h1 <+> pretty s
+
+          atomically $ modifyTVar twritten (HS.insert (HashRef h1))
+
+          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
 
-    nWq     <- newTVarIO 0
+        for_ fss $ \(fn, (ha,s)) -> do
-    nCu     <- newTVarIO 0
+          lbs2 <- getBlock sto ha >>= orThrowUser "block not found"
-    nFo     <- newTVarIO 0
+          let h2 = hashObject @HbSync lbs2
-    nMissed <- newTVarIO 0
 
-    let
+          when (ha /= h2) do
-      updateStats :: forall m . MonadIO m => NCQStorage -> HashRef -> m (Maybe Location)
+            error $ show $ pretty "hash does not  match" <+> pretty ha <+> pretty s
-      updateStats ncq h = do
-          w <- ncqLocate ncq (coerce h)
 
-          case w of
+          debug $ "getBlock" <+> pretty ha <+> pretty h2
-            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
+testNCQTree1 :: MonadUnliftIO m
+         => Int
+         -> TestEnv
+         -> m ()
 
-            what <- readTVarIO twritten
+testNCQTree1 n TestEnv{..} = flip runContT pure do
-            p <- randomRIO (0.01, 0.5)
-            pause @'Seconds (realToFrac p)
 
-            forConcurrently_ what $ \h -> do
+  let size = 1024 * 1024 * fromIntegral n
 
-              w <- updateStats ncq h
+  let tmp = testEnvDir
 
-              what <- ncqStorageHasBlockEither ncq (coerce h)
+  let inputDir = tmp </> "input"
-              case what of
+  let ncqDir   = tmp </> "ncq-test-data"
-                Left LocationNotFound | isJust w -> do
-                  error $ show $ "FUCKING RACE!" <+> pretty w
 
-                Left e -> throwIO e
+  treeLbs <- LBS.take size <$> liftIO (LBS.readFile ("/dev/urandom"))
-                Right _ -> none
 
-            done <- readTVarIO (ncqStopped ncq)
+  let h1 = hashObject @HbSync treeLbs
-            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))
-
-    blkQ <- atomically do
-      STM.flushTQueue out
-
-    notice $ "WAIT BLOCKS DONE" <+> pretty (List.length blkQ)
-
-    lift $ ncqStorageFlush ncq
-
-    for_ blkQ $ \h -> liftIO do
-      void $ updateStats ncq h
-      hasBlock sto (coerce h)
-             `orDie` show ("missed" <+> pretty h)
-
-    liftIO $ ncqStorageStop ncq
-
-    wait t1
-
-    let vars = zip [ "write-q"
-                   , "current"
-                   , "fossil"
-                   , "missed"
-                   , "size"
-                   ]
-                   [nWq, nCu, nFo, nMissed, nSize]
-
-    liftIO $ wait r
 
   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
 
-      results <- for vars $ \(k,w) -> do
+    let sto = AnyStorage ncq1
-          v <- readTVarIO w
-          pure $ mkList @C [ mkSym k, mkInt v]
 
-      liftIO $ print $ pretty $ mkList (mkSym "results" : results)
+    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

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

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