diff --git a/Makefile b/Makefile index 2469db11..00c175b5 100644 --- a/Makefile +++ b/Makefile @@ -24,7 +24,7 @@ BINS := \ fixme-new \ hbs2-git3 \ git-remote-hbs23 \ - hbs2-ncq \ + ncq3 \ hbs2-obsolete \ tcq \ test-ncq \ diff --git a/hbs2-log-structured/lib/HBS2/Data/Log/Structured/NCQ.hs b/hbs2-log-structured/lib/HBS2/Data/Log/Structured/NCQ.hs index 6ead9253..2065915f 100644 --- a/hbs2-log-structured/lib/HBS2/Data/Log/Structured/NCQ.hs +++ b/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 -- ^ template + -> FilePath + -> 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 - let kpiece = nwayAllocKeyPartSize + liftIO $ withBinaryFileDurableAtomic fn WriteMode $ \h -> do - let itemsInBuck = nwayAllocBucketSize - let itemSize = fromIntegral $ ks + vs - let buckSize = fromIntegral $ itemSize * itemsInBuck + let go (numBuckMay, pageOff, i, es) = do + let numBuck = fromMaybe + (max nwayAllocMinBuckets (nwayAllocBucketNum nwa (length es))) + numBuckMay - let kparts = ks `div` fromIntegral kpiece + -- счётчики на каждый бакет + alloc <- V.replicateM numBuck (newTVarIO 0) - fn0 <- liftIO (emptyTempFile path tpl) - fn <- liftIO (emptyTempFile path (takeBaseName fn0 <>".part")) + -- leftovers (если бакет переполнен) + leftovers <- newTVarIO [] - h0 <- openFile fn ReadWriteMode - fd <- liftIO $ handleToFd h0 - h <- liftIO $ fdToHandle fd + forM_ es $ \(k,v) -> do + let ki = N.word64 (BS.take kpiece (BS.drop (i*kpiece) k)) + 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 - leftovers <- newTQueueIO + for_ eIdx $ \e -> do + 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 - hClose h + lo <- readTVarIO leftovers - 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 - fix \next -> do - ops <- atomically do - void (peekTQueue wq) - STM.flushTQueue wq + buckets <- go (Nothing, 0, 0, items) - for_ ops $ \case - Just (_,op) -> op - Nothing -> none + let meta = [ mkForm @C "keysize" [mkInt ks] + , mkForm "keypartsize" [mkInt kpiece] + , 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 - 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 + pure fn nwayHashScanAll :: MonadIO m => NWayHash diff --git a/hbs2-storage-ncq/app/Main.hs b/hbs2-storage-ncq/app/Main.hs index 0edd9754..a77b8f4d 100644 --- a/hbs2-storage-ncq/app/Main.hs +++ b/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 - , NCQPerks m - , MonadUnliftIO m - , Exception (BadFormException c) - ) => [Syntax c] -> m () -runTop forms = do +setupLogger :: MonadIO m => m () +setupLogger = do + -- setLogging @DEBUG $ toStderr . logPrefix "[debug] " + setLogging @ERROR $ toStderr . logPrefix "[error] " + setLogging @WARN $ toStderr . logPrefix "[warn] " + 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 - [ StringLike path ] -> do - ncqStorageInit path + entry $ bindMatch "#!" $ nil_ $ const none - e -> throwIO $ BadFormException @c (mkList e) + entry $ bindMatch "stdin" $ nil_ $ \case + argz -> do + liftIO getContents >>= runScript dict argz - tvd <- newTVarIO dict - runEval tvd forms >>= eatNil display - - -main :: IO () -main = do - argz <- getArgs - - forms <- parseTop (unlines $ unwords <$> splitForms argz) - & either (error.show) pure - - runTop forms + entry $ bindMatch "file" $ nil_ $ \case + ( StringLike fn : argz ) -> do + liftIO (readFile fn) >>= runScript dict argz + + e -> error (show $ pretty $ mkList e) + + entry $ bindMatch "debug" $ nil_ \case + + [ LitBoolVal False ] -> do + setLoggingOff @DEBUG + + [ 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 diff --git a/hbs2-storage-ncq/hbs2-storage-ncq.cabal b/hbs2-storage-ncq/hbs2-storage-ncq.cabal index 690aad9e..1afe66d8 100644 --- a/hbs2-storage-ncq/hbs2-storage-ncq.cabal +++ b/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: diff --git a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3.hs b/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3.hs index e0795167..72275764 100644 --- a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3.hs +++ b/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 diff --git a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/CLI.hs b/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/CLI.hs new file mode 100644 index 00000000..a63c75b6 --- /dev/null +++ b/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 + diff --git a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Run.hs b/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Run.hs index de4a723a..5b2e5a13 100644 --- a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Run.hs +++ b/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 ()