mirror of https://github.com/voidlizard/hbs2
wip
This commit is contained in:
voidlizard
parent
fbb6c1730a
commit
3639ccec25
|
|
@ -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)
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
||||
|
|
|
|||
|
|
@ -170,6 +170,36 @@ data NCQStorage =
|
|||
}
|
||||
|
||||
|
||||
-- Log structure:
|
||||
-- (SD)*
|
||||
-- S ::= word32be, section prefix
|
||||
-- D ::= HASH PREFIX DATA
|
||||
-- HASH ::= BYTESTRING(32)
|
||||
-- PREFIX ::= BYTESTRING(4)
|
||||
-- DATA ::= BYTESTRING(n) | n == S - LEN(WORD32) - LEN(HASH) - LEN(PREFIX)
|
||||
|
||||
newtype NCQFullRecordLen a =
|
||||
NCQFullRecordLen a
|
||||
deriving newtype (Num,Enum,Integral,Real,Ord,Eq)
|
||||
|
||||
-- including prefix
|
||||
ncqFullDataLen :: forall a . Integral a => NCQFullRecordLen a -> a
|
||||
ncqFullDataLen full = fromIntegral full - ncqKeyLen
|
||||
{-# INLINE ncqFullDataLen #-}
|
||||
|
||||
ncqKeyLen :: forall a . Integral a => a
|
||||
ncqKeyLen = 32
|
||||
{-# INLINE ncqKeyLen #-}
|
||||
|
||||
-- 'S' in SD, i.e size, i.e section header
|
||||
ncqSLen:: forall a . Integral a => a
|
||||
ncqSLen = 4
|
||||
{-# INLINE ncqSLen #-}
|
||||
|
||||
ncqDataOffset :: forall a b . (Integral a, Integral b) => a -> b
|
||||
ncqDataOffset base = fromIntegral base + ncqSLen + ncqKeyLen
|
||||
{-# INLINE ncqDataOffset #-}
|
||||
|
||||
instance MonadUnliftIO m => Storage NCQStorage HbSync LBS.ByteString m where
|
||||
putBlock ncq lbs = fmap coerce <$> ncqStoragePutBlock ncq lbs
|
||||
enqueueBlock ncq lbs = fmap coerce <$> ncqStoragePutBlock ncq lbs
|
||||
|
|
@ -412,6 +442,10 @@ ncqStorageRun ncq@NCQStorage{..} = flip runContT pure do
|
|||
atomically $ modifyTVar ncqCurrentUsage (IntMap.adjust pred (fromIntegral fd))
|
||||
fdSeek fd AbsoluteSeek (fromIntegral $ 4 + 32 + off)
|
||||
bs <- Posix.fdRead fd (fromIntegral l)
|
||||
|
||||
unless (BS.length bs == fromIntegral l) do
|
||||
err $ "READ MISMATCH" <+> pretty l <+> pretty (BS.length bs)
|
||||
|
||||
atomically $ putTMVar answ bs
|
||||
|
||||
link reader
|
||||
|
|
@ -473,7 +507,7 @@ ncqStorageRun ncq@NCQStorage{..} = flip runContT pure do
|
|||
what' <- race (pause @'Seconds 1) $ atomically do
|
||||
stop <- readTVar ncqStopped
|
||||
q <- tryPeekTQueue indexQ
|
||||
if not (stop || isJust q) then
|
||||
if not ( stop || isJust q) then
|
||||
STM.retry
|
||||
else do
|
||||
STM.flushTQueue indexQ
|
||||
|
|
@ -515,7 +549,6 @@ ncqStorageRun ncq@NCQStorage{..} = flip runContT pure do
|
|||
Nothing -> pure mempty
|
||||
Just (h,_,WQItem{..},rest) -> do
|
||||
|
||||
off <- fdSeek fh SeekFromEnd 0
|
||||
|
||||
-- we really have to write tomb prefix here
|
||||
let b = byteString (coerce @_ @ByteString h)
|
||||
|
|
@ -524,7 +557,9 @@ ncqStorageRun ncq@NCQStorage{..} = flip runContT pure do
|
|||
let wbs = toLazyByteString b
|
||||
let len = LBS.length wbs
|
||||
let ws = N.bytestring32 (fromIntegral len)
|
||||
let w = 4 + len
|
||||
let w = ncqSLen + len
|
||||
|
||||
off <- fdSeek fh SeekFromEnd 0
|
||||
|
||||
if isNothing wqData && wqNew then
|
||||
pure ()
|
||||
|
|
@ -539,9 +574,10 @@ ncqStorageRun ncq@NCQStorage{..} = flip runContT pure do
|
|||
fsize <- getFdStatus fh <&> PFS.fileSize
|
||||
pure (0,fromIntegral fsize)
|
||||
|
||||
now <- readTVarIO ncqIndexNow
|
||||
|
||||
if sz < ncqMinLog && now <= 0 then do
|
||||
-- off <- fdSeek fh SeekFromEnd 0 <&> subtract (fromIntegral w)
|
||||
|
||||
if sz < ncqMinLog then do
|
||||
((h, (fromIntegral off, fromIntegral len)) : ) <$> next (written', rest)
|
||||
else do
|
||||
pure [(h, (fromIntegral off, fromIntegral len))]
|
||||
|
|
@ -563,14 +599,15 @@ ncqStorageRun ncq@NCQStorage{..} = flip runContT pure do
|
|||
[] -> pure (q,w)
|
||||
((h,(o,l)):xs) -> do
|
||||
modifyTVar wbytes (+l)
|
||||
next (HPSQ.delete h q, HPSQ.insert h now1 (o,l) w,xs)
|
||||
let recLen = ncqFullDataLen (NCQFullRecordLen l)
|
||||
next (HPSQ.delete h q, HPSQ.insert h now1 (o,recLen) w,xs)
|
||||
|
||||
writeTVar ncqWriteQueue rq
|
||||
modifyTVar ncqStaged (IntMap.insert (fromIntegral fdr) rw)
|
||||
bw <- readTVar wbytes
|
||||
writeTVar ncqNotWritten (max 0 (b0 - bw))
|
||||
|
||||
indexNow <- atomically $ stateTVar ncqIndexNow (,0)
|
||||
indexNow <- readTVarIO ncqIndexNow
|
||||
|
||||
when (fromIntegral size >= ncqMinLog || indexNow > 0) do
|
||||
|
||||
|
|
@ -598,6 +635,7 @@ ncqStorageRun ncq@NCQStorage{..} = flip runContT pure do
|
|||
-- то есть должны отнять 1 после индексации.
|
||||
modifyTVar ncqCurrentUsage (IntMap.insertWith (+) (fromIntegral fdr) 1)
|
||||
writeTQueue indexQ (fdr, fossilized)
|
||||
writeTVar ncqIndexNow 0
|
||||
|
||||
closeFd fh
|
||||
writeBinaryFileDurable (ncqGetCurrentSizeName ncq) (N.bytestring64 0)
|
||||
|
|
@ -706,6 +744,15 @@ ncqStorageGetBlock ncq h = do
|
|||
Just lbs | not (ncqIsTomb lbs) -> pure (Just $ LBS.drop ncqPrefixLen lbs)
|
||||
_ -> pure Nothing
|
||||
|
||||
data NCQSectionType = B | R | T
|
||||
deriving stock (Eq,Ord,Show)
|
||||
|
||||
instance Pretty NCQSectionType where
|
||||
pretty = \case
|
||||
B -> "B"
|
||||
T -> "T"
|
||||
R -> "R"
|
||||
|
||||
ncqPrefixLen :: Integral a => a
|
||||
ncqPrefixLen = 4
|
||||
{-# INLINE ncqPrefixLen #-}
|
||||
|
|
@ -832,20 +879,20 @@ ncqStorageScanDataFile ncq fp' action = do
|
|||
flip runContT pure $ callCC \exit -> do
|
||||
flip fix (0,mmaped) $ \next (o,bs) -> do
|
||||
|
||||
when (BS.length bs < 4) $ exit ()
|
||||
when (BS.length bs < ncqSLen) $ exit ()
|
||||
|
||||
let w = BS.take 4 bs & N.word32 & fromIntegral
|
||||
let w = BS.take ncqSLen bs & N.word32 & fromIntegral
|
||||
|
||||
when (BS.length bs < 4 + w) $ exit ()
|
||||
when (BS.length bs < ncqSLen + w) $ exit ()
|
||||
|
||||
let kv = BS.drop 4 bs
|
||||
let kv = BS.drop ncqSLen bs
|
||||
|
||||
let k = BS.take 32 kv & coerce @_ @HashRef
|
||||
let v = BS.take (w-32) $ BS.drop 32 kv
|
||||
let k = BS.take ncqKeyLen kv & coerce @_ @HashRef
|
||||
let v = BS.take (ncqFullDataLen (NCQFullRecordLen w)) $ BS.drop ncqKeyLen kv
|
||||
|
||||
lift (action o (fromIntegral w) k v)
|
||||
|
||||
next (4 + o + fromIntegral w, BS.drop (w+4) bs)
|
||||
next (ncqSLen + o + fromIntegral w, BS.drop (w+ncqSLen) bs)
|
||||
|
||||
ncqStorageGet :: MonadUnliftIO m => NCQStorage -> HashRef -> m (Maybe LBS.ByteString)
|
||||
ncqStorageGet ncq h = runMaybeT do
|
||||
|
|
@ -869,7 +916,7 @@ ncqStorageGet_ ncq@NCQStorage{..} = \case
|
|||
InFossil ce (o,l) -> do
|
||||
now <- getTimeCoarse
|
||||
atomically $ writeTVar (cachedTs ce) now
|
||||
let chunk = BS.take (fromIntegral l) (BS.drop (fromIntegral o + 4 + 32) (cachedMmapedData ce))
|
||||
let chunk = BS.take (fromIntegral l) (BS.drop (ncqDataOffset o) (cachedMmapedData ce))
|
||||
pure $ Just $ LBS.fromStrict chunk
|
||||
|
||||
_ -> pure Nothing
|
||||
|
|
@ -884,7 +931,7 @@ ncqStorageGetRef ncq ref = runMaybeT do
|
|||
lbs <- lift (ncqStorageGet ncq h) >>= toMPlus
|
||||
guard (not $ ncqIsTomb lbs)
|
||||
let hbs = LBS.toStrict (LBS.drop ncqPrefixLen lbs)
|
||||
guard (BS.length hbs == 32)
|
||||
guard (BS.length hbs == ncqKeyLen)
|
||||
pure $ coerce hbs
|
||||
where h = ncqRefHash ncq ref
|
||||
|
||||
|
|
@ -907,8 +954,9 @@ ncqStorageDel ncq@NCQStorage{..} h = flip runContT pure $ callCC \exit -> do
|
|||
|
||||
now <- getTimeCoarse
|
||||
let writeTombstone wq = do
|
||||
let recordPrefixLen = ncqSLen + ncqKeyLen + ncqPrefixLen
|
||||
modifyTVar ncqWriteQueue (HPSQ.insert h now wq)
|
||||
modifyTVar ncqNotWritten (+ (4 + 32 + ncqPrefixLen))
|
||||
modifyTVar ncqNotWritten (+ recordPrefixLen)
|
||||
|
||||
ncqLocate ncq h >>= atomically . \case
|
||||
Just (InFossil _ _) -> writeTombstone (WQItem False Nothing)
|
||||
|
|
@ -1018,19 +1066,19 @@ ncqStorageOpen fp' = do
|
|||
items <- S.toList_ <$>
|
||||
flip runContT pure $ callCC \exit ->do
|
||||
flip fix (0,bs0) $ \next (o,bs) -> do
|
||||
when (BS.length bs < 4) $ exit ()
|
||||
let w = BS.take 4 bs & N.word32 & fromIntegral
|
||||
let p = BS.take w (BS.drop 4 bs)
|
||||
when (BS.length bs < ncqSLen) $ exit ()
|
||||
let w = BS.take ncqSLen bs & N.word32 & fromIntegral
|
||||
let p = BS.take w (BS.drop ncqSLen bs)
|
||||
|
||||
when (BS.length p < w ) do
|
||||
throwIO NCQStorageBrokenCurrent
|
||||
|
||||
let k = BS.take 32 p & coerce . BS.copy
|
||||
let vs = w - 32
|
||||
let k = BS.take ncqKeyLen p & coerce . BS.copy
|
||||
let vs = ncqFullDataLen (NCQFullRecordLen w)
|
||||
|
||||
lift $ S.yield (k,now, (fromIntegral o, fromIntegral vs))
|
||||
|
||||
next (o+w+4, BS.drop (w+4) bs)
|
||||
next (o+w+ncqSLen, BS.drop (w+ncqSLen) bs)
|
||||
|
||||
atomically $ modifyTVar ncqStaged (IntMap.insert (fromIntegral fd) (HPSQ.fromList items))
|
||||
|
||||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -12,6 +12,7 @@ import HBS2.Hash
|
|||
import HBS2.Data.Types.Refs
|
||||
import HBS2.Clock
|
||||
import HBS2.Merkle
|
||||
import HBS2.Polling
|
||||
|
||||
import HBS2.Storage
|
||||
import HBS2.Storage.Simple
|
||||
|
|
@ -30,6 +31,7 @@ import Data.Config.Suckless.System
|
|||
|
||||
import DBPipe.SQLite hiding (field)
|
||||
|
||||
import Data.Char
|
||||
import Data.Bits
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.ByteString qualified as BS
|
||||
|
|
@ -174,6 +176,125 @@ testNCQFuckupRecovery1 TestEnv{..} = flip runContT pure do
|
|||
notice $ "loaded" <+> pretty ha <+> pretty (LBS.length lbs)
|
||||
|
||||
|
||||
|
||||
testNCQSimple1 :: MonadUnliftIO m => TestEnv -> m ()
|
||||
testNCQSimple1 TestEnv{..} = flip runContT pure do
|
||||
let ncqDir = testEnvDir </> "ncq-simple"
|
||||
|
||||
for_ [ 0 .. 18 ] $ \s -> do
|
||||
let size = 2 ^ s
|
||||
let payload = LBS.replicate size 0x41 -- 0x41 = 'A'
|
||||
let expectedHash = hashObject @HbSync payload
|
||||
|
||||
-- Step 1: Write block
|
||||
lift $ withNCQ id ncqDir $ \ncq -> do
|
||||
let sto = AnyStorage ncq
|
||||
h <- putBlock sto payload `orDie` "failed to write block"
|
||||
liftIO $ assertBool "hashes match (write)" (h == expectedHash)
|
||||
|
||||
-- Step 2: Read back
|
||||
lift $ withNCQ id ncqDir $ \ncq -> do
|
||||
let sto = AnyStorage ncq
|
||||
blk <- getBlock sto (coerce expectedHash) `orDie` "block not found"
|
||||
sx <- hasBlock sto (coerce expectedHash)
|
||||
|
||||
loc <- ncqLocate ncq (coerce expectedHash)
|
||||
>>= orThrowUser "not found"
|
||||
|
||||
blk0 <- ncqStorageGet_ ncq loc
|
||||
|
||||
let sblk0 = LBS.length <$> blk0
|
||||
|
||||
liftIO $ print $ "block size"
|
||||
<+> pretty sx
|
||||
<+> ";"
|
||||
<+> pretty (LBS.length blk)
|
||||
<+> ";"
|
||||
<+> pretty size
|
||||
<+> ";"
|
||||
<+> pretty sblk0
|
||||
<+> pretty loc
|
||||
|
||||
liftIO $ do
|
||||
assertBool "block has correct length" (LBS.length blk == size)
|
||||
assertBool "block contents are correct" (blk == payload)
|
||||
|
||||
|
||||
testNCQSimple2 :: MonadUnliftIO m => Int -> TestEnv -> m ()
|
||||
testNCQSimple2 n TestEnv{..} = flip runContT pure do
|
||||
let ncqDir = testEnvDir </> "ncq-simple2"
|
||||
|
||||
let alph_ = V.fromList ['A' .. 'z']
|
||||
cnt <- newTVarIO 0
|
||||
|
||||
let alphx = liftIO do
|
||||
i <- atomically $ stateTVar cnt (\x -> (x, succ x))
|
||||
pure $ alph_ ! ( i `mod` V.length alph_)
|
||||
|
||||
-- Step 1: write N blocks
|
||||
hashes <- lift $ withNCQ id ncqDir $ \ncq -> do
|
||||
let sto = AnyStorage ncq
|
||||
replicateM n do
|
||||
size <- liftIO $ randomRIO (0, 256 * 1024)
|
||||
chr <- alphx
|
||||
let payload = LBS.replicate size (fromIntegral $ ord chr)
|
||||
let h = hashObject @HbSync payload
|
||||
h' <- putBlock sto payload `orDie` "putBlock failed"
|
||||
loc <- ncqLocate ncq (coerce h)
|
||||
s <- hasBlock sto h
|
||||
w <- getBlock sto h
|
||||
let w' = fromMaybe mempty w
|
||||
|
||||
if w == Just payload then do
|
||||
debug $ "okay" <+> pretty loc
|
||||
else do
|
||||
err $ pretty s <> "/" <> pretty size
|
||||
<+> viaShow (LBS.take 48 w')
|
||||
<+> ".."
|
||||
<+> viaShow (LBS.take 8 $ LBS.reverse w')
|
||||
<> line
|
||||
<+> pretty loc
|
||||
|
||||
error "ABORTED"
|
||||
|
||||
liftIO $ assertBool "hash matches" (h == h')
|
||||
pure (h, size, payload)
|
||||
|
||||
let testRead ncq = do
|
||||
let sto = AnyStorage ncq
|
||||
forM_ hashes $ \(h, expectedSize, expectedPayload) -> do
|
||||
loc <- ncqLocate ncq (coerce h) >>= orThrowUser "not found"
|
||||
blk <- getBlock sto (coerce h) `orDie` "block not found"
|
||||
sx <- hasBlock sto (coerce h)
|
||||
blk0 <- ncqStorageGet_ ncq loc
|
||||
let sblk0 = LBS.length <$> blk0
|
||||
let actualSize = LBS.length blk
|
||||
|
||||
debug $ "block size"
|
||||
<+> pretty sx
|
||||
<+> ";"
|
||||
<+> pretty actualSize
|
||||
<+> ";"
|
||||
<+> pretty expectedSize
|
||||
<+> ";"
|
||||
<+> pretty sblk0
|
||||
<+> pretty loc
|
||||
|
||||
liftIO do
|
||||
assertBool "size match" (actualSize == expectedSize)
|
||||
assertBool "payload match" (blk == expectedPayload)
|
||||
|
||||
-- Step 2: reopen and verify
|
||||
lift $ withNCQ id ncqDir $ \ncq -> do
|
||||
testRead ncq
|
||||
-- ncqIndexRightNow ncq
|
||||
pause @'Seconds 2
|
||||
|
||||
liftIO $ print $ "LAST PASS"
|
||||
-- Step 3: reopen and verify - fossil
|
||||
lift $ withNCQ id ncqDir $ \ncq -> do
|
||||
testRead ncq
|
||||
|
||||
testNCQ1 :: MonadUnliftIO m
|
||||
=> Int
|
||||
-> TestEnv
|
||||
|
|
@ -196,109 +317,113 @@ testNCQ1 n TestEnv{..} = flip runContT pure do
|
|||
let fname = inputDir </> show i <> ".bin"
|
||||
size <- randomRIO (1, 256*1024)
|
||||
atomically $ modifyTVar nSize (+size)
|
||||
file <- LBS.take size <$> LBS.readFile "/dev/urandom"
|
||||
BS.writeFile fname (BS.toStrict file)
|
||||
pure fname
|
||||
file <- LBS.toStrict . LBS.take size <$> LBS.readFile "/dev/urandom"
|
||||
BS.writeFile fname file
|
||||
let ha = hashObject @HbSync file
|
||||
pure (fname, (ha, fromIntegral $ BS.length file))
|
||||
|
||||
ncq <- liftIO $ ncqStorageOpen ncqDir
|
||||
r <- liftIO $ async (ncqStorageRun ncq)
|
||||
|
||||
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
|
||||
nCu <- newTVarIO 0
|
||||
nFo <- newTVarIO 0
|
||||
nMissed <- newTVarIO 0
|
||||
for_ fss $ \(fn, (ha,s)) -> do
|
||||
lbs2 <- getBlock sto ha >>= orThrowUser "block not found"
|
||||
let h2 = hashObject @HbSync lbs2
|
||||
|
||||
let
|
||||
updateStats :: forall m . MonadIO m => NCQStorage -> HashRef -> m (Maybe Location)
|
||||
updateStats ncq h = do
|
||||
w <- ncqLocate ncq (coerce h)
|
||||
when (ha /= h2) do
|
||||
error $ show $ pretty "hash does not match" <+> pretty ha <+> pretty s
|
||||
|
||||
case w of
|
||||
Just (InWriteQueue _) -> atomically $ modifyTVar nWq succ
|
||||
Just (InCurrent _) -> atomically $ modifyTVar nCu succ
|
||||
Just (InFossil _ _) -> atomically $ modifyTVar nFo succ
|
||||
Nothing -> atomically $ modifyTVar nMissed succ
|
||||
|
||||
pure w
|
||||
debug $ "getBlock" <+> pretty ha <+> pretty h2
|
||||
|
||||
|
||||
t1 <- ContT $ withAsync $ fix \loop -> do
|
||||
testNCQTree1 :: MonadUnliftIO m
|
||||
=> Int
|
||||
-> TestEnv
|
||||
-> m ()
|
||||
|
||||
what <- readTVarIO twritten
|
||||
p <- randomRIO (0.01, 0.5)
|
||||
pause @'Seconds (realToFrac p)
|
||||
testNCQTree1 n TestEnv{..} = flip runContT pure do
|
||||
|
||||
forConcurrently_ what $ \h -> do
|
||||
let size = 1024 * 1024 * fromIntegral n
|
||||
|
||||
w <- updateStats ncq h
|
||||
let tmp = testEnvDir
|
||||
|
||||
what <- ncqStorageHasBlockEither ncq (coerce h)
|
||||
case what of
|
||||
Left LocationNotFound | isJust w -> do
|
||||
error $ show $ "FUCKING RACE!" <+> pretty w
|
||||
let inputDir = tmp </> "input"
|
||||
let ncqDir = tmp </> "ncq-test-data"
|
||||
|
||||
Left e -> throwIO e
|
||||
Right _ -> none
|
||||
treeLbs <- LBS.take size <$> liftIO (LBS.readFile ("/dev/urandom"))
|
||||
|
||||
done <- readTVarIO (ncqStopped ncq)
|
||||
unless done loop
|
||||
|
||||
link t1
|
||||
--
|
||||
|
||||
out <- newTQueueIO
|
||||
|
||||
liftIO do
|
||||
forConcurrently_ fss $ \f -> do
|
||||
-- debug $ "process file" <+> pretty f
|
||||
blk <- BS.readFile f
|
||||
h <- putBlock sto (LBS.fromStrict blk) `orDie` ("Can't store block " <> f)
|
||||
atomically do
|
||||
writeTQueue out (HashRef h)
|
||||
modifyTVar twritten (HS.insert (coerce h))
|
||||
|
||||
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
|
||||
let h1 = hashObject @HbSync treeLbs
|
||||
|
||||
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
|
||||
v <- readTVarIO w
|
||||
pure $ mkList @C [ mkSym k, mkInt v]
|
||||
let sto = AnyStorage ncq1
|
||||
|
||||
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue