wip, ncq3 maintainance tools

Makefile

@@ -24,7 +24,7 @@ BINS := \
   fixme-new          \
 	hbs2-git3 \
 	git-remote-hbs23 \
-	hbs2-ncq \
+	ncq3 \
 	hbs2-obsolete \
 	tcq \
 	test-ncq \

hbs2-log-structured/lib/HBS2/Data/Log/Structured/NCQ.hs

@@ -50,7 +50,7 @@ import Safe
 import Lens.Micro.Platform
 import Control.Concurrent.STM qualified as STM
 import UnliftIO
-
+import UnliftIO.IO.File
 
 
 nextPowerOf2 :: Word64 -> Word64
@@ -225,130 +225,88 @@ nwayFileAllocate = fileAllocate
 
 nwayWriteBatch :: MonadUnliftIO m
                => NWayHashAlloc
-               -> FilePath -- ^ dir
+               -> FilePath
-               -> FilePath -- ^ template
+               -> FilePath
                -> [(ByteString, ByteString)]
                -> m FilePath
-
 nwayWriteBatch nwa@NWayHashAlloc{..} path tpl items' = do
 
- let items = HM.fromList items' & HM.toList
+  let items       = HM.toList (HM.fromList items')  -- dedup
+      ks          = nwayAllocKeySize
+      vs          = nwayAllocValueSize
+      kpiece      = nwayAllocKeyPartSize
+      itemsInBuck = nwayAllocBucketSize
+      itemSize    = ks + vs
+      buckSize    = itemSize * itemsInBuck
+      kparts      = ks `div` kpiece
 
- let  ks     = nwayAllocKeySize
+  fn <- liftIO $ emptyTempFile path tpl
 
- let  vs     = nwayAllocValueSize
+  liftIO $ withBinaryFileDurableAtomic fn WriteMode $ \h -> do
- let  kpiece = nwayAllocKeyPartSize
 
- let  itemsInBuck = nwayAllocBucketSize
+    let go (numBuckMay, pageOff, i, es) = do
- let  itemSize    = fromIntegral $ ks + vs
+          let numBuck = fromMaybe
- let  buckSize    = fromIntegral $ itemSize * itemsInBuck
+                          (max nwayAllocMinBuckets (nwayAllocBucketNum nwa (length es)))
+                          numBuckMay
 
- let  kparts = ks `div` fromIntegral kpiece
+          -- счётчики на каждый бакет
+          alloc <- V.replicateM numBuck (newTVarIO 0)
 
- fn0 <- liftIO (emptyTempFile path tpl)
+          -- leftovers (если бакет переполнен)
- fn <- liftIO (emptyTempFile path (takeBaseName fn0 <>".part"))
+          leftovers <- newTVarIO []
 
- h0 <- openFile fn ReadWriteMode
+          forM_ es $ \(k,v) -> do
- fd <- liftIO $ handleToFd  h0
+            let ki = N.word64 (BS.take kpiece (BS.drop (i*kpiece) k))
- h <- liftIO $ fdToHandle fd
+                bn = fromIntegral (ki `mod` fromIntegral numBuck)
 
- flip runContT pure do
+            eIdx <- atomically $ do
+                      e <- readTVar (alloc ! bn)
+                      if e >= itemsInBuck
+                        then do
+                          modifyTVar leftovers ((k,v):)
+                          pure Nothing
+                        else do
+                          writeTVar (alloc ! bn) (e+1)
+                          pure (Just e)
 
-   buckets <- newTQueueIO
+            for_ eIdx $ \e -> do
-   leftovers <- newTQueueIO
+              let woff = pageOff + bn * buckSize + (e * itemSize)
+              hSeek h AbsoluteSeek (fromIntegral woff)
+              BS.hPut h (k <> BS.take vs v)
 
-   void $ ContT $ bracket none $ const do
+          lo <- readTVarIO leftovers
-     hClose h
 
-   wq   <- newTQueueIO
+          if null lo
+            then pure [numBuck]
+            else if i + 1 < kparts
+              then do
+                let resize = nwayAllocResize nwa i numBuck (length lo)
+                more <- go (resize, pageOff + numBuck * buckSize, succ i, lo)
+                pure (numBuck : more)
+              else do
+                -- финальный шанс: удвоить бакеты
+                hSetFileSize h (fromIntegral pageOff)
+                more <- go (Just (numBuck*2), pageOff, i, lo)
+                pure (numBuck : more)
 
-   writer <- ContT $ withAsync  do
+    buckets <- go (Nothing, 0, 0, items)
-      fix \next -> do
-       ops <-  atomically do
-                void (peekTQueue wq)
-                STM.flushTQueue wq
 
-       for_ ops $ \case
+    let meta = [ mkForm @C "keysize"     [mkInt ks]
-         Just (_,op) -> op
+               , mkForm    "keypartsize" [mkInt kpiece]
-         Nothing -> none
+               , mkForm    "valuesize"   [mkInt vs]
+               , mkForm    "bucksize"    [mkInt itemsInBuck]
+               , mkForm    "buckets"     (fmap mkInt buckets)
+               , mkForm    "cqfile"      [mkInt 1]
+               ]
 
-       unless (any isNothing ops) next
+    let metabs   = BS8.pack (show (vsep (fmap pretty meta)))
+        metaSize = fromIntegral (BS.length metabs)
 
-   flip fix (Nothing,0,0,items) \nextPage (numBuck,pageOff,i,es) -> do
+    hSeek h SeekFromEnd 0
+    BS.hPut h metabs
+    BS.hPut h (N.bytestring32 metaSize)
 
-     let buckNum = case numBuck of
+  pure fn
-                     Just x  -> x
-                     Nothing -> max nwayAllocMinBuckets (nwayAllocBucketNum nwa (List.length es))
-
-     atomically $ writeTQueue buckets buckNum
-
-     tvx <- replicateM (fromIntegral buckNum) ( newTVarIO 0 )
-     let alloc  = V.fromList tvx
-
-     let pageSize = buckNum * buckSize
-
-     liftIO do
-       nwayFileAllocate fd pageOff (fromIntegral pageSize)
-
-     for_ es $ \(k,v) -> do
-       let ki = BS.take kpiece (BS.drop (i*kpiece) k ) & N.word64
-       let bn = ki `mod` fromIntegral buckNum
-       let buckOff = fromIntegral pageOff +  bn * fromIntegral buckSize
-
-       eIdx <- atomically do
-                 e <- readTVar (alloc ! fromIntegral bn)
-                 if e >= itemsInBuck then do
-                   writeTQueue leftovers (k,v)
-                   pure Nothing
-                 else do
-                   writeTVar (alloc ! fromIntegral bn) (e+1)
-                   pure $ Just e
-
-       for_ eIdx \e -> liftIO do
-         let woff = fromIntegral buckOff + fromIntegral (e * itemSize)
-         let op = liftIO do
-               hSeek h AbsoluteSeek woff
-               BS.hPut h (k <> BS.take (fromIntegral vs) v)
-
-         atomically (writeTQueue wq (Just (woff, op)))
-
-     lo <- atomically $ STM.flushTQueue leftovers
-
-     if | List.null lo -> none
-
-        | i + 1 < fromIntegral kparts -> do
-           let resize = nwayAllocResize nwa i buckNum (List.length lo)
-           nextPage (resize, pageOff + fromIntegral pageSize, succ i, lo)
-
-        | otherwise -> do
-            -- TODO: check-how-it-works
-            liftIO (setFileSize fn pageOff)
-            nextPage (Just (buckNum*2), pageOff, i, lo)
-
-   atomically $ writeTQueue wq Nothing
-   wait writer
-
-   -- finalize write
-   bucklist <- atomically $ STM.flushTQueue buckets
-
-   let meta = [ mkForm @C "keysize"     [mkInt ks]
-              , mkForm    "keypartsize" [mkInt kpiece]
-              , mkForm    "valuesize"   [mkInt vs]
-              , mkForm    "bucksize"    [mkInt itemsInBuck]
-              , mkForm    "buckets"     (fmap mkInt bucklist)
-              , mkForm    "cqfile"      [mkInt 1]
-              ]
-
-   let metabs = BS8.pack $ show $ vsep (fmap pretty meta)
-   let metaSize = fromIntegral $ BS.length metabs
-
-   liftIO do
-     hSeek h SeekFromEnd 0
-     BS.hPut h metabs
-     BS.hPut h (N.bytestring32 metaSize)
-     mv fn fn0
-
-   pure fn0
 
 nwayHashScanAll :: MonadIO m
                 => NWayHash

hbs2-storage-ncq/app/Main.hs

@@ -1,23 +1,64 @@
+{-# Language ViewPatterns #-}
 module Main where
 
 import HBS2.Prelude.Plated
-import HBS2.Storage.NCQ
+import HBS2.Storage.NCQ3
+import HBS2.System.Logger.Simple.ANSI
+import HBS2.Storage.NCQ3.Internal.CLI as CLI
 
 import Data.Config.Suckless.Script
 
+import Data.HashMap.Strict qualified as HM
+import Data.HashMap.Strict (HashMap)
+import Control.Monad.Trans.Cont
+import Control.Monad.Trans.Maybe
+import Data.Coerce
 import System.Environment
+import System.IO qualified as IO
 import UnliftIO
 
 
-runTop :: forall c m . ( IsContext c
+setupLogger :: MonadIO m => m ()
-                       , NCQPerks m
+setupLogger = do
-                       , MonadUnliftIO m
+  -- setLogging @DEBUG  $ toStderr . logPrefix "[debug] "
-                       , Exception (BadFormException c)
+  setLogging @ERROR  $ toStderr . logPrefix "[error] "
-                       ) => [Syntax c] -> m ()
+  setLogging @WARN   $ toStderr . logPrefix "[warn] "
-runTop forms = do
+  setLogging @NOTICE $ toStdout . logPrefix ""
+
+flushLoggers :: MonadIO m => m ()
+flushLoggers = do
+  silence
+
+silence :: MonadIO m => m ()
+silence = do
+  setLoggingOff @DEBUG
+  setLoggingOff @ERROR
+  setLoggingOff @WARN
+  setLoggingOff @NOTICE
+  setLoggingOff @TRACE
 
 
-  let dict = makeDict @c do
+main :: IO ()
+main = do
+
+  instances <- initInstances
+
+  tvd <- newTVarIO mempty
+
+  setupLogger
+
+  argz <- liftIO getArgs
+
+  forms <- parseTop (unlines $ unwords <$> splitForms argz)
+           & either  (error.show) pure
+
+  let runScript dict argz what = liftIO do
+        script <- either (error.show) pure $ parseTop what
+        runM dict do
+          bindCliArgs argz
+          evalTop script
+
+  let dict = makeDict do
 
        internalEntries
 
@@ -26,23 +67,61 @@ runTop forms = do
          [StringLike s]      -> helpList False (Just s)
          _                   -> helpList False Nothing
 
-       entry $ bindMatch "ncq:init" $ nil_ $ \case
+       entry $ bindMatch "#!" $ nil_ $ const none
-        [ StringLike path ] -> do
-          ncqStorageInit path
 
-        e -> throwIO $ BadFormException @c (mkList e)
+       entry $ bindMatch "stdin" $ nil_ $ \case
+         argz  -> do
+           liftIO getContents >>= runScript dict argz
 
-  tvd  <- newTVarIO dict
+       entry $ bindMatch "file" $ nil_ $ \case
-  runEval tvd forms >>= eatNil display
+         ( StringLike fn : argz ) -> do
-
+           liftIO (readFile fn) >>= runScript dict argz
-
+
-main :: IO ()
+         e -> error (show $ pretty $ mkList e)
-main = do
+
-  argz <- getArgs
+       entry $ bindMatch "debug" $ nil_ \case
-
+
-  forms <- parseTop (unlines $ unwords <$> splitForms argz)
+         [ LitBoolVal False ] -> do
-     & either (error.show) pure
+            setLoggingOff @DEBUG
-
+
-  runTop forms
+         [ StringLike "off" ] -> do
+            setLoggingOff @DEBUG
+
+         _ ->
+            setLogging @DEBUG  $ toStderr . logPrefix "[debug] "
+
+       CLI.entries instances
+
+  atomically $ writeTVar tvd dict
+
+  flip runContT pure do
+
+    ContT $ bracket none $ const do
+      finalizeInstances instances
+      flushLoggers
+
+    eatNil display =<< lift do
+      case forms of
+
+        ( cmd@(ListVal [StringLike "file", StringLike fn]) : _ ) -> do
+          run dict [cmd]
+
+        ( cmd@(ListVal [StringLike "stdin"]) : _ ) -> do
+          run dict [cmd]
+
+        ( cmd@(ListVal [StringLike "--help"]) : _ ) -> do
+          run dict [cmd]
+
+        [] -> do
+          eof <- liftIO IO.isEOF
+          if eof then
+            run dict [mkForm  "help" []]
+          else do
+            what <- liftIO getContents
+                      >>= either (error.show) pure . parseTop
+
+            run dict what
+
+        e -> run dict e
 
 

hbs2-storage-ncq/hbs2-storage-ncq.cabal

@@ -75,6 +75,7 @@ library
       HBS2.Storage.NCQ3.Internal.Fossil
       HBS2.Storage.NCQ3.Internal.Flags
       HBS2.Storage.NCQ3.Internal.Fsync
+      HBS2.Storage.NCQ3.Internal.CLI
       HBS2.Storage.NCQ
       HBS2.Storage.NCQ.Types
     -- other-modules:
@@ -124,7 +125,7 @@ library
     default-language: Haskell2010
 
 
-executable hbs2-ncq
+executable ncq3
     import:           shared-properties
 
     ghc-options:

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

@@ -26,6 +26,7 @@ import HBS2.Storage.NCQ3.Internal.Memtable
 import HBS2.Storage.NCQ3.Internal.Index
 import HBS2.Storage.NCQ3.Internal.Fossil
 import HBS2.Storage.NCQ3.Internal.Flags as Exported
+import HBS2.Storage.NCQ3.Internal.CLI as Exported
 
 
 

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

@@ -0,0 +1,495 @@
+{-# Language ViewPatterns #-}
+module HBS2.Storage.NCQ3.Internal.CLI where
+
+import HBS2.Storage.NCQ3.Internal.Prelude
+import HBS2.Storage.NCQ3.Internal.Types
+import HBS2.Storage.NCQ3.Internal.Run
+import HBS2.Storage.NCQ3.Internal.Class
+import HBS2.Storage.NCQ3.Internal.Files
+import HBS2.Storage.NCQ3.Internal.Index
+import HBS2.Storage.NCQ3.Internal.Fossil
+import HBS2.Storage.NCQ3.Internal
+import HBS2.Storage
+import HBS2.Base58
+import HBS2.Net.Auth.Credentials
+
+import Data.Config.Suckless.Script
+
+import Network.ByteOrder qualified as N
+import Data.Fixed
+import Data.Text.Encoding qualified as TE
+import Data.List qualified as List
+import Data.ByteString.Char8 qualified as BS8
+import Data.ByteString (ByteString)
+import Data.ByteString qualified as BS
+import Data.ByteString.Lazy qualified as LBS
+import Data.HashMap.Strict qualified as HM
+import Data.HashMap.Strict (HashMap)
+import System.Environment
+import UnliftIO
+
+newtype Instance = Instance FilePath
+                   deriving newtype (Eq,Ord,Hashable)
+
+type Instances =  TVar (HashMap Instance (NCQStorage, Async ()))
+
+initInstances :: MonadUnliftIO m => m Instances
+initInstances = newTVarIO mempty
+
+finalizeInstances :: MonadUnliftIO m => Instances -> m ()
+finalizeInstances ins = do
+  (storages, threads) <- readTVarIO ins <&> unzip . HM.elems
+  mapM_ ncqStorageStop storages
+  debug "wait storages to finalize"
+  mapM_ wait threads
+
+closeInstance :: MonadUnliftIO m => Instances -> Instance -> m ()
+closeInstance ins i = do
+  readTVarIO ins <&> HM.lookup i >>= \case
+    Nothing -> none
+    Just (sto, thread) -> do
+      atomically (modifyTVar ins (HM.delete i))
+      ncqStorageStop sto
+      wait thread
+
+
+getInstance :: MonadUnliftIO m
+            => Instances
+            -> Instance
+            -> m (NCQStorage, Async ())
+getInstance ins i = do
+  m <- readTVarIO ins
+  case HM.lookup i m of
+    Nothing -> newInstance
+    Just (sto, th) -> poll th >>= \case
+        Nothing -> pure (sto, th)
+        Just _  -> do
+          atomically $ modifyTVar ins (HM.delete i)
+          newInstance
+
+  where
+    newInstance = do
+      sto <- ncqStorageOpen (coerce i) id
+      th  <- async (ncqStorageRun sto)
+      atomically $ modifyTVar ins (HM.insert i (sto, th))
+      pure (sto, th)
+
+entries :: forall c m . ( MonadUnliftIO m
+                        , IsContext c
+                        , Exception (BadFormException c)
+                        ) => Instances -> MakeDictM c m ()
+entries instances = do
+
+  entry $ bindMatch "ncq3:open" $ \case
+   [ StringLike p ] -> do
+     what <- getInstance instances (Instance p)
+     mkOpaque (Instance p)
+
+   e -> throwIO (BadFormException (mkList e))
+
+  entry $ bindMatch "ncq3:close" $ nil_ \case
+   [ isOpaqueOf @Instance -> Just inst ] -> do
+     closeInstance instances inst
+
+   e -> throwIO (BadFormException (mkList e))
+
+  entry $ bindMatch "ncq3:put" $ \syn -> do
+    (inst,bs) <- case syn of
+      [ isOpaqueOf @Instance -> Just tcq, isOpaqueOf @ByteString -> Just bs ] -> lift do
+        pure (tcq, LBS.fromStrict bs)
+
+      [ isOpaqueOf @Instance -> Just tcq, TextLike s ] -> lift do
+        pure (tcq, LBS.fromStrict (TE.encodeUtf8 s))
+
+      e -> throwIO $ BadFormException (mkList e)
+
+    lift do
+      (ncq,_) <- getInstance instances inst
+      r <- putBlock ncq bs
+      pure $ maybe nil (mkSym . show . pretty) r
+
+
+  entry $ bindMatch "ncq3:get" $ \case
+    [ isOpaqueOf @Instance -> Just inst, HashLike hash ] -> lift do
+      (ncq,_) <- getInstance instances inst
+      getBlock ncq (coerce hash) >>= maybe (pure nil) mkOpaque
+
+    e -> throwIO $ BadFormException (mkList e)
+
+  entry $ bindMatch "ncq3:has" $ \case
+    [ isOpaqueOf @Instance -> Just inst, HashLike hash ] -> lift do
+      (ncq,_) <- getInstance instances inst
+      hasBlock ncq (coerce hash) <&> maybe nil mkInt
+
+    e -> throwIO $ BadFormException (mkList e)
+
+  entry $ bindMatch "ncq3:del" $ nil_ \case
+    [ isOpaqueOf @Instance -> Just inst, HashLike hash ] -> lift do
+      (ncq,_) <- getInstance instances inst
+      delBlock ncq (coerce hash)
+
+    e -> throwIO $ BadFormException (mkList e)
+
+
+  entry $ bindMatch "ncq3:set:ref" $ \case
+    [ isOpaqueOf @Instance -> Just inst, HashLike ref, HashLike val ] -> lift do
+      (ncq,_) <- getInstance instances inst
+      updateRef ncq (RefAlias2 mempty ref) (coerce val)
+      pure nil
+
+    e -> throwIO $ BadFormException (mkList e)
+
+  entry $ bindMatch "ncq3:del:ref" $ \case
+    [ isOpaqueOf @Instance -> Just inst, HashLike ref ] -> lift do
+      (ncq,_) <- getInstance instances inst
+      delRef ncq (RefAlias2 mempty ref)
+      pure nil
+
+    e -> throwIO $ BadFormException (mkList e)
+
+  entry $ bindMatch "ncq3:locate" $ \case
+    [ isOpaqueOf @Instance -> Just inst, HashLike hash ] -> lift do
+      (ncq,_) <- getInstance instances inst
+      ncqLocate ncq hash >>= \case
+        Just x -> parseSyntax (show $ pretty x) & either (error . show) (pure . fixContext)
+        Nothing -> pure nil
+
+    e -> throwIO $ BadFormException (mkList e)
+
+
+  entry $ bindMatch "ncq3:get:ref" $ \case
+    [ isOpaqueOf @Instance -> Just inst, HashLike w ] -> lift do
+      (ncq,_) <- getInstance instances inst
+      ref <- getRef ncq (RefAlias2 mempty w)
+      pure $ maybe nil (mkSym . show . pretty) ref
+
+    e -> throwIO $ BadFormException (mkList e)
+
+
+  entry $ bindMatch "ncq3:nway:stats" $ \case
+    [StringLike fn] -> liftIO do
+
+      mt_    <- newTVarIO 0
+      total_ <- newTVarIO 0
+
+      (mmaped,meta@NWayHash{..}) <- nwayHashMMapReadOnly fn
+                                     >>= orThrow (NWayHashInvalidMetaData fn)
+
+      let emptyKey = BS.replicate nwayKeySize 0
+      nwayHashScanAll meta mmaped $ \_ k _ -> do
+        atomically do
+          modifyTVar total_ succ
+          when (k == emptyKey) do
+            modifyTVar mt_ succ
+
+      mt    <- readTVarIO mt_
+      total <- readTVarIO total_
+      let used  = total - mt
+      let ratio = realToFrac @_ @(Fixed E3) (realToFrac used / realToFrac total)
+
+      let stats = mkForm @c "stats"
+                    [ mkForm "empty" [mkInt mt]
+                    , mkForm "used"  [mkInt used]
+                    , mkForm "total" [mkInt total]
+                    , mkForm "ratio" [mkDouble ratio]
+                    ]
+
+      pure $ mkList [ mkForm "metadata" [mkSyntax meta]
+                    , stats
+                    ]
+
+    e -> throwIO $ BadFormException (mkList e)
+
+  entry $ bindMatch "ncq3:workdir" $ \syn -> lift do
+    path <- case syn of
+      [ isOpaqueOf @Instance -> Just inst ] -> pure (coerce inst)
+      [ StringLike path ]                   -> pure path
+      e -> throwIO $ BadFormException (mkList e)
+
+    sto <- ncqStorageOpen path id
+    pure (mkSym (ncqGetWorkDir sto))
+
+  entry $ bindMatch "ncq3:states" $ \syn -> lift do
+    path <- case syn of
+      [ isOpaqueOf @Instance -> Just inst ] -> pure (coerce inst)
+      [ StringLike path ]                   -> pure path
+      e -> throwIO $ BadFormException (mkList e)
+
+    sto <- ncqStorageOpen path id
+    fs  <- dirFiles (ncqGetWorkDir sto) <&> filter (List.isPrefixOf "s-" . takeFileName)
+    pure (mkList (fmap mkSym fs))
+
+
+  entry $ bindMatch "ncq3:indexes" $ \syn -> lift do
+    path <- case syn of
+      [ isOpaqueOf @Instance -> Just inst ] -> pure (coerce inst)
+      [ StringLike path ]                   -> pure path
+      e -> throwIO $ BadFormException (mkList e)
+
+    sto <- ncqStorageOpen path id
+    fs  <- dirFiles (ncqGetWorkDir sto) <&> filter (List.isPrefixOf "i-" . takeFileName)
+    pure (mkList (fmap mkSym fs))
+
+
+  entry $ bindMatch "ncq3:datafiles" $ \syn -> lift do
+    path <- case syn of
+      [ isOpaqueOf @Instance -> Just inst ] -> pure (coerce inst)
+      [ StringLike path ]                   -> pure path
+      e -> throwIO $ BadFormException (mkList e)
+
+    sto <- ncqStorageOpen path id
+    fs  <- dirFiles (ncqGetWorkDir sto) <&> filter (List.isPrefixOf "f-" . takeFileName)
+    pure (mkList (fmap mkSym fs))
+
+  entry $ bindMatch "ncq3:index:scan" $ \syn -> liftIO do
+    (sto, files) <- case syn of
+      [ StringLike path, StringLike x ] -> do
+        sto <- ncqStorageOpen path id
+        pure (sto, [ncqGetFileName sto (takeFileName x)])
+
+      [ StringLike path, LitIntVal idx ] -> do
+        sto <- ncqStorageOpen path id
+        let fn = ncqGetFileName sto (IndexFile (FileKey (fromIntegral idx)))
+        pure (sto, [fn])
+
+      [ StringLike path ] -> do
+        sto <- ncqStorageOpen path id
+        fs  <- dirFiles (ncqGetWorkDir sto)
+        let idxs = filter (List.isPrefixOf "i-" . takeFileName) fs
+        pure (sto, List.sortOn Down idxs)
+
+      e -> throwIO $ BadFormException (mkList e)
+
+    forM_ files \fn -> do
+      mres <- nwayHashMMapReadOnly fn
+      case mres of
+        Nothing -> err ("can't mmap index " <> pretty fn)
+        Just (bs,nw) -> do
+          nwayHashScanAll nw bs $ \_ k v ->
+            unless (k == emptyKey) do
+              let IndexEntry fk off sz = unpackIndexEntry v
+              print $      fill 6 (pretty (fromString @FileKey (takeBaseName fn)))
+                       <+> fill 44 (pretty (coerce @_ @HashRef k))
+                       <+> fill 4 (pretty fk)
+                       <+> fill 8 (pretty off)
+                       <+> pretty sz
+
+    pure nil
+
+  entry $ bindMatch "ncq3:index:lookup" $ \syn -> liftIO do
+    (sto, h, files) <- case syn of
+
+      [ StringLike path, LitIntVal idx, HashLike h ] -> do
+        sto <- ncqStorageOpen path id
+        let fn = ncqGetFileName sto (IndexFile (FileKey (fromIntegral idx)))
+        pure (sto, h, [fn])
+
+      [ StringLike path, StringLike fname, HashLike h ] -> do
+        sto <- ncqStorageOpen path id
+        pure (sto, h, [ncqGetFileName sto (takeFileName fname)])
+
+      [ StringLike path, HashLike h ] -> do
+        sto <- ncqStorageOpen path id
+        fs  <- dirFiles (ncqGetWorkDir sto)
+        let idxs = filter (List.isPrefixOf "i-" . takeFileName) fs
+        pure (sto, h, List.sortOn Down idxs)
+
+      e -> throwIO $ BadFormException (mkList e)
+
+    forM_ files \fn -> do
+      mres <- nwayHashMMapReadOnly fn
+      case mres of
+        Nothing -> err ("can't mmap index " <+> pretty fn)
+        Just (bs,nw) -> do
+          mval <- nwayHashLookup nw bs (coerce h)
+          case mval of
+            Nothing -> debug "fucking nothing!" >> pure ()
+            Just entryBs -> do
+              let IndexEntry fk off sz = unpackIndexEntry entryBs
+              print $
+                   fill 44 (pretty h)
+               <+> fill 6  (pretty fk)
+               <+> fill 10 (pretty off)
+               <+> pretty sz
+
+    pure nil
+
+  entry $ bindMatch "ncq3:index:find" $ \syn -> liftIO do
+    (sto, hash, files) <- case syn of
+
+      -- путь, хэш → все индексы
+      [ StringLike path, HashLike h ] -> do
+        sto <- ncqStorageOpen path id
+        fs  <- dirFiles (ncqGetWorkDir sto)
+        let idxs = filter (List.isPrefixOf "i-" . takeFileName) fs
+        pure (sto, h, List.sortOn Down idxs)
+
+      -- путь, хэш, имя файла
+      [ StringLike path, HashLike h, StringLike x ] -> do
+        sto <- ncqStorageOpen path id
+        pure (sto, h, [ncqGetFileName sto (takeFileName x)])
+
+      -- путь, хэш, индекс по номеру
+      [ StringLike path, HashLike h, LitIntVal idx ] -> do
+        sto <- ncqStorageOpen path id
+        let fn = ncqGetFileName sto (IndexFile (FileKey (fromIntegral idx)))
+        pure (sto, h, [fn])
+
+
+      e -> throwIO $ BadFormException (mkList e)
+
+    forM_ files \fn -> do
+      mres <- nwayHashMMapReadOnly fn
+      case mres of
+        Nothing -> err ("can't mmap index " <+> pretty fn)
+        Just (bs,nw) -> do
+          nwayHashScanAll nw bs $ \_ k v ->
+            unless (k == emptyKey) do
+              when (coerce @_ @HashRef k == hash) do
+                let IndexEntry fk off sz = unpackIndexEntry v
+                print $      fill 6 (pretty (fromString @FileKey (takeBaseName fn)))
+                         <+> fill 44 (pretty (coerce @_ @HashRef k))
+                         <+> fill 4 (pretty fk)
+                         <+> fill 8 (pretty off)
+                         <+> pretty sz
+
+    pure nil
+
+  entry $ bindMatch "ncq3:data:scan" $ \syn -> liftIO do
+    (sto, files) <- case syn of
+
+      [ StringLike path, StringLike x ] -> do
+        sto <- ncqStorageOpen path id
+        pure (sto, [ncqGetFileName sto (takeFileName x)])
+
+      [ StringLike path, LitIntVal idx ] -> do
+        sto <- ncqStorageOpen path id
+        let fn = ncqGetFileName sto (DataFile (FileKey (fromIntegral idx)))
+        pure (sto, [fn])
+
+      [ StringLike path ] -> do
+        sto <- ncqStorageOpen path id
+        fs  <- dirFiles (ncqGetWorkDir sto)
+        let dfs = filter (List.isPrefixOf "f-" . takeFileName) fs
+        pure (sto, List.sortOn Down dfs)
+
+      e -> throwIO $ BadFormException (mkList e)
+
+    forM_ files \fn -> do
+      let fk = fromString @FileKey (takeBaseName fn)
+      ncqStorageScanDataFile sto fn $ \offset w key val -> do
+        print $
+              fill 6  (pretty fk)
+          <+> fill 10 (pretty offset)
+          <+> fill 8  (pretty (w + ncqSLen))
+          <+> fill 44 (pretty (coerce @_ @HashRef key))
+          <+> prettyTag val
+
+    pure nil
+
+  entry $ bindMatch "ncq3:data:find" $ \syn -> liftIO do
+    (sto, h, files) <- case syn of
+
+      [ StringLike path, HashLike h, StringLike x ] -> do
+        sto <- ncqStorageOpen path id
+        pure (sto, h, [ncqGetFileName sto (takeFileName x)])
+
+      [ StringLike path, HashLike h, LitIntVal idx ] -> do
+        sto <- ncqStorageOpen path id
+        let fn = ncqGetFileName sto (DataFile (FileKey (fromIntegral idx)))
+        pure (sto, h, [fn])
+
+      [ StringLike path, HashLike h ] -> do
+        sto <- ncqStorageOpen path id
+        fs  <- dirFiles (ncqGetWorkDir sto)
+        let dfs = filter (List.isPrefixOf "f-" . takeFileName) fs
+        pure (sto, h, List.sortOn Down dfs)
+
+      e -> throwIO $ BadFormException (mkList e)
+
+    forM_ files \fn -> do
+      let fk = fromString @FileKey (takeBaseName fn)
+      ncqStorageScanDataFile sto fn $ \offset w key val -> do
+        when (coerce @_ @HashRef key == h) do
+          print $
+                fill 6  (pretty fk)
+            <+> fill 10 (pretty offset)
+            <+> fill 8  (pretty (w + ncqSLen))
+            <+> fill 44 (pretty (coerce @_ @HashRef key))
+            <+> prettyTag val
+
+    pure nil
+
+
+  entry $ bindMatch "ncq3:data:read" $ \syn -> liftIO do
+    (fn, offset) <- case syn of
+
+      -- путь + индекс + offset
+      [ StringLike path, LitIntVal idx, LitIntVal off ] -> do
+        sto <- ncqStorageOpen path id
+        let fn = ncqGetFileName sto (DataFile (FileKey (fromIntegral idx)))
+        pure (fn, fromIntegral off)
+
+      -- путь + имя файла + offset
+      [ StringLike path, StringLike fname, LitIntVal off ] -> do
+        sto <- ncqStorageOpen path id
+        let fn = ncqGetFileName sto (takeFileName fname)
+        pure (fn, fromIntegral off)
+
+      e -> throwIO $ BadFormException (mkList e)
+
+    -- mmap файла
+    bs <- mmapFileByteString fn Nothing
+
+    -- читаем первые 4 байта для размера
+    let beSize = BS.take 4 (BS.drop offset bs)
+        size   = N.word32 beSize
+
+    -- вырезаем всю запись целиком
+    let record = BS.take (fromIntegral (size + ncqSLen)) (BS.drop offset bs)
+
+    mkOpaque record
+
+  entry $ bindMatch "ncq3:data:unpack" $ \syn -> lift do
+    case syn of
+      [ SymbolVal x, isOpaqueOf @ByteString -> Just bs ] -> do
+        let raw = bs
+        let (k, e) = ncqEntryUnwrap bs
+        let val = either id snd e
+        case x of
+          "key"  -> pure (mkSym (show (pretty (coerce @_ @HashRef k))))
+
+          "size" -> pure $ mkInt (BS.length raw)
+
+          "tag"  -> pure (mkSym (show (prettyTag' e)))
+
+          "prefix" -> do
+            pure (mkStr $ BS8.unpack $ BS.take ncqPrefixLen $ BS.drop (ncqSLen + ncqKeyLen) raw)
+
+          "value"      -> mkOpaque val
+          "value:hex"  -> pure $ mkStr (show $ AsHex val)
+          "value:b58"  -> pure $ mkStr (show $ AsBase58 val)
+
+          _ -> pure nil
+
+      e -> throwIO $ BadFormException (mkList e)
+
+
+
+printDataEntry :: MonadUnliftIO m => NCQOffset -> NCQSize -> HashRef -> ByteString -> m ()
+printDataEntry offset size key val = do
+  liftIO $ print $
+        fill 10 (pretty offset)
+    <+> fill 8  (pretty size)
+    <+> fill 44 (pretty key)
+    <+> prettyTag val
+
+prettyTag x = case ncqEntryUnwrapValue x of
+    Left _              -> pretty ("E" :: String)
+    Right (meta, _)     -> pretty meta
+
+prettyTag' :: Either ByteString (NCQSectionType, ByteString) -> Doc a
+prettyTag' = \case
+    Left _              -> pretty ("E" :: String)
+    Right (meta, _)     -> pretty meta
+

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

@@ -211,9 +211,12 @@ ncqStorageRun ncq@NCQStorage{..} = withSem ncqRunSem $ flip runContT pure do
 
       ContT $ ncqWithState ncq
 
+      -- debug $ "REQ IN STATE" <+> pretty h
+
       NCQState{..} <- readTVarIO ncqState
 
       for_ ncqStateIndex $ \(_, fk) -> do
+       -- debug $ "SCAN FUCKING INDEX" <+> pretty fk
        CachedIndex bs nw <- lift $ ncqGetCachedIndex ncq fk
        lift (ncqLookupIndex h (bs, nw)) >>= \case
         Just (IndexEntry fk o s) -> answer (Just (InFossil (FileLocation fk o s))) >> exit ()