mirror of https://github.com/voidlizard/hbs2
wip, ncq3 maintainance tools
This commit is contained in:
voidlizard
parent
c3f65af033
commit
3d9589676d
2
Makefile
2
Makefile
|
|
@ -24,7 +24,7 @@ BINS := \
|
|||
fixme-new \
|
||||
hbs2-git3 \
|
||||
git-remote-hbs23 \
|
||||
hbs2-ncq \
|
||||
ncq3 \
|
||||
hbs2-obsolete \
|
||||
tcq \
|
||||
test-ncq \
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
@ -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 ()
|
||||
|
|
|
|||
Loading…
Reference in New Issue