voidlizard
/
hbs2
mirror of https://github.com/voidlizard/hbs2
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

wip, fwd section -- good idea or?

This commit is contained in:
Dmitry Zuikov 2024-05-31 07:47:27 +03:00
parent 39764326fa
commit ce87e43829
1 changed files with 32 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
hbs2-storage-simple/lib/HBS2/Storage/Compact.hs
View File

@ -39,6 +39,10 @@ newtype EntryOffset = EntryOffset Word64
deriving newtype (Ord,Eq,Num,Enum,Real,Integral,Show) deriving newtype (Ord,Eq,Num,Enum,Real,Integral,Show)
deriving stock Generic deriving stock Generic
newtype FwdEntryOffset = FwdEntryOffset Word64
deriving newtype (Ord,Eq,Num,Enum,Real,Integral,Show)
deriving stock Generic
newtype EntrySize = EntrySize Word64 newtype EntrySize = EntrySize Word64
deriving newtype (Ord,Eq,Num,Enum,Real,Integral,Show) deriving newtype (Ord,Eq,Num,Enum,Real,Integral,Show)
deriving stock Generic deriving stock Generic
@ -68,6 +72,7 @@ data Header =
Header Header
{ hdrMagic :: Word16 { hdrMagic :: Word16
, hdrVersion :: Word16 , hdrVersion :: Word16
, hdrFwdOffset :: FwdEntryOffset
, hdrIndexOffset :: EntryOffset , hdrIndexOffset :: EntryOffset
, hdrIndexEntries :: EntryNum , hdrIndexEntries :: EntryNum
, hdrGen :: Word32 , hdrGen :: Word32
@ -190,8 +195,13 @@ compactStorageCommit sto = liftIO do
unless (List.null items) do unless (List.null items) do
-- write fwd
offFwd <- hTell ha
LBS.hPut ha (toLazyByteString $ word64BE 0)
off0 <- hTell ha off0 <- hTell ha
-- write data
idxEntries <- flip fix (off0, items, mempty) $ \next (off, what, idx) -> do idxEntries <- flip fix (off0, items, mempty) $ \next (off, what, idx) -> do
case what of case what of
[] -> pure idx [] -> pure idx
@ -202,6 +212,7 @@ compactStorageCommit sto = liftIO do
offIdx0 <- hTell ha <&> fromIntegral offIdx0 <- hTell ha <&> fromIntegral
-- write index
for_ idxEntries $ \(e,_) -> do for_ idxEntries $ \(e,_) -> do
let lbs = serialise e let lbs = serialise e
LBS.hPut ha (B.toLazyByteString $ LBS.hPut ha (B.toLazyByteString $
@ -212,7 +223,14 @@ compactStorageCommit sto = liftIO do
pver <- atomicModifyIORef' (csHeaderGen sto) (\v -> (v+1, v)) pver <- atomicModifyIORef' (csHeaderGen sto) (\v -> (v+1, v))
-- FIXME: maybe-slow-length-calc -- FIXME: maybe-slow-length-calc
appendHeader ha (Just offPrev) pver offIdx0 (fromIntegral $ length idxEntries) appendHeader ha (fromIntegral offFwd) (Just offPrev) pver offIdx0 (fromIntegral $ length idxEntries)
offCommitHead <- hTell ha
hSeek ha AbsoluteSeek offFwd
LBS.hPut ha (toLazyByteString $ word16BE (fromIntegral offCommitHead))
hFlush ha hFlush ha
hSeek ha SeekFromEnd 0 hSeek ha SeekFromEnd 0
@ -259,19 +277,21 @@ compactStorageClose sto = do
appendHeader :: ForCompactStorage m appendHeader :: ForCompactStorage m
=> Handle => Handle
-> FwdEntryOffset -- fwd section offset
-> Maybe EntryOffset -- prev. header -> Maybe EntryOffset -- prev. header
-> Word32 -- prev. header version -> Word32 -- prev. header version
-> EntryOffset -> EntryOffset
-> EntryNum -> EntryNum
-> m () -> m ()
appendHeader ha poffset v ioffset num = do appendHeader ha fwdOff poffset v ioffset num = do
let bs = word16BE headerMagic let bs = word16BE headerMagic -- 2
<> word16BE headerVersion <> word16BE headerVersion -- 4
<> word64BE (coerce ioffset) <> word64BE (coerce fwdOff) -- 12
<> word32BE (coerce num) <> word64BE (coerce ioffset) -- 20
<> word32BE v <> word32BE (coerce num) -- 24
<> word64BE (coerce $ fromMaybe 0 poffset) <> word32BE v -- 28
<> word32BE 0 -- reserved <> word64BE (coerce $ fromMaybe 0 poffset) -- 36
<> byteString (BS.replicate 4 0) -- 40
liftIO $ LBS.hPut ha (B.toLazyByteString bs) liftIO $ LBS.hPut ha (B.toLazyByteString bs)
readHeader :: ForCompactStorage m readHeader :: ForCompactStorage m
@ -294,6 +314,7 @@ readHeader mha moff = do
let what = flip runGetOrFail bs do let what = flip runGetOrFail bs do
Header <$> getWord16be Header <$> getWord16be
<*> getWord16be <*> getWord16be
<*> getFwdOffset
<*> getOffset <*> getOffset
<*> getNum <*> getNum
<*> getWord32be <*> getWord32be
@ -304,6 +325,7 @@ readHeader mha moff = do
where where
getOffset = EntryOffset <$> getWord64be getOffset = EntryOffset <$> getWord64be
getNum = EntryNum <$> getWord32be getNum = EntryNum <$> getWord32be
getFwdOffset = FwdEntryOffset <$> getWord64be
headerMagic :: Word16 headerMagic :: Word16
headerMagic = 32264 headerMagic = 32264
@ -312,7 +334,7 @@ headerVersion :: Word16
headerVersion = 1 headerVersion = 1
headerSize :: Integral a => Word16 -> a headerSize :: Integral a => Word16 -> a
headerSize 1 = fromIntegral (32 :: Integer) headerSize 1 = fromIntegral (40 :: Integer)
headerSize _ = error "unsupported header version" headerSize _ = error "unsupported header version"