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

wip

This commit is contained in:
voidlizard 2025-01-11 10:29:02 +03:00
parent 97100dbc90
commit 44f242a723
2 changed files with 104 additions and 95 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

103
hbs2-git3/app/Main.hs
View File

@ -279,7 +279,7 @@ readCommitChainHPSQ :: ( HBS2GitPerks m
readCommitChainHPSQ filt _ h0 action = flip runContT pure $ callCC \_ -> do readCommitChainHPSQ filt _ h0 action = flip runContT pure $ callCC \_ -> do
theReader <- ContT $ withGitCat theReader <- ContT $ withGitCat
void $ ContT $ bracket (pure theReader) stopProcess void $ ContT $ bracket (pure theReader) dontHandle -- stopProcess
flip fix (HCC 0 [h0] HPSQ.empty) $ \next -> \case flip fix (HCC 0 [h0] HPSQ.empty) $ \next -> \case
HCC _ [] result -> pure result HCC _ [] result -> pure result
@ -1027,13 +1027,7 @@ theDict = do
on conflict (sha1) on conflict (sha1)
do update set tx = excluded.tx|] (p,h) do update set tx = excluded.tx|] (p,h)
entry $ bindMatch "test:git:reflog:index:merge" $ nil_ $ \case entry $ bindMatch "reflog:index:compact" $ nil_ $ \syn -> lift do
[ StringLike f1, StringLike f2] -> lift do
mergeSortedFiles (LBS.take 20) f1 f2 "jopakita"
_ -> throwIO (BadFormException @C nil)
entry $ bindMatch "test:git:reflog:index:compact" $ nil_ $ \syn -> lift do
reflog <- getGitRemoteKey >>= orThrowUser "reflog not set" reflog <- getGitRemoteKey >>= orThrowUser "reflog not set"
idxPath <- getStatePath (AsBase58 reflog) <&> (</> "index") idxPath <- getStatePath (AsBase58 reflog) <&> (</> "index")
mkdir idxPath mkdir idxPath
@ -1069,7 +1063,7 @@ theDict = do
liftIO $ print $ pretty h liftIO $ print $ pretty h
entry $ bindMatch "reflog:index:build" $ nil_ $ const $ lift $ connectedDo do entry $ bindMatch "reflog:index:build" $ nil_ $ const $ lift $ connectedDo do
writeReflogIndex updateReflogIndex
entry $ bindMatch "test:reflog:index:lookup" $ nil_ \case entry $ bindMatch "test:reflog:index:lookup" $ nil_ \case
[ GitHashLike h ] -> lift do [ GitHashLike h ] -> lift do
@ -1084,6 +1078,8 @@ theDict = do
commit <- gitRevParseThrow what commit <- gitRevParseThrow what
updateReflogIndex
idx <- openIndex idx <- openIndex
-- let req h = lift $ indexEntryLookup idx h <&> isNothing -- let req h = lift $ indexEntryLookup idx h <&> isNothing
@ -1122,6 +1118,8 @@ theDict = do
void $ flip runContT pure do void $ flip runContT pure do
lift updateReflogIndex
idx <- lift openIndex idx <- lift openIndex
let req h = lift $ indexEntryLookup idx h <&> isNothing let req h = lift $ indexEntryLookup idx h <&> isNothing
@ -1151,37 +1149,64 @@ theDict = do
notice $ "all shit read" <+> pretty (realToFrac @_ @(Fixed E2) t3) notice $ "all shit read" <+> pretty (realToFrac @_ @(Fixed E2) t3)
(t4,new) <- lift $ timeItT $ readTVarIO uniq_ >>= indexFilterNewObjectsMem idx (t4,new) <- lift $ timeItT $ readTVarIO uniq_ >>= indexFilterNewObjects idx
notice $ pretty (length new) <+> "new objects" <+> "at" <+> pretty (realToFrac @_ @(Fixed E2) t4) notice $ pretty (length new) <+> "new objects" <+> "at" <+> pretty (realToFrac @_ @(Fixed E2) t4)
-- x <- readTVarIO uniq_ <&> HS.size entry $ bindMatch "reflog:tx:list" $ nil_ $ \syn -> lift $ connectedDo do
-- blmn <- readTVarIO blmn_ let (opts, _) = splitOpts [("--tree",0)] syn
-- notice $ "all shit filter" <+> parens (pretty x) <+> brackets (pretty blmn) <+> pretty (realToFrac @_ @(Fixed E2) t4)
-- notice $ pretty (length new) let optTree = or [ True | ListVal [StringLike "--tree"] <- opts ]
sto <- getStorage
-- notice $ "total objects" <+> pretty refLogAPI <- getClientAPI @RefLogAPI @UNIX
-- notice $ "present" <+> pretty nhere reflog <- getGitRemoteKey >>= orThrowUser "reflog not set"
-- liftIO $ print $ pretty (HS rv <- callRpcWaitMay @RpcRefLogGet (TimeoutSec 1) refLogAPI reflog
>>= orThrowUser "rpc timeout"
>>= orThrowUser "reflog is empty"
<&> coerce
-- fix \next -> do hxs <- S.toList_ $ walkMerkle @[HashRef] rv (getBlock sto) $ \case
-- h' <- atomically do Left{} -> throwIO MissedBlockError
-- pollSTM r >>= \case Right hs -> S.each hs
-- Just{} -> pure Nothing
-- Nothing -> readTQueue out <&> Just
-- maybe1 h' none $ \h ->do liftIO $ forM_ hxs $ \h -> do
-- liftIO $ print $ pretty h
-- next if not optTree then
print $ pretty h
else do
decoded <- readTxMay sto h
<&> \case
Nothing -> ("missed" <+> pretty h)
Just (AnnotatedHashRef _ x) -> (pretty h <+> pretty x)
print decoded
entry $ bindMatch "reflog:tx:objects:list" $ nil_ $ \syn -> lift $ connectedDo do
let (_, argz) = splitOpts [] syn
txh <- headMay [ x | HashLike x <- argz ] & orThrowUser "tx hash not set"
sto <- getStorage
AnnotatedHashRef _ tree <- readTxMay sto txh
>>= orThrowUser ("missed" <+> pretty txh)
liftIO $ print $ pretty tree
entry $ bindMatch "test:git:import" $ nil_ $ \syn -> lift $ connectedDo do
refLogAPI <- getClientAPI @RefLogAPI @UNIX
reflog <- getGitRemoteKey >>= orThrowUser "reflog not set"
rv <- (callRpcWaitMay @RpcRefLogGet (TimeoutSec 1) refLogAPI reflog)
>>= orThrowUser "reflog is empty"
notice $ "test:git:import" <+> pretty (AsBase58 reflog) <+> pretty rv
entry $ bindMatch "test:git:export" $ nil_ $ \syn -> lift $ connectedDo do entry $ bindMatch "test:git:export" $ nil_ $ \syn -> lift $ connectedDo do
let (opts, argz) = splitOpts [("--index",1),("--ref",1)] syn let (opts, argz) = splitOpts [("--dry",0),("--ref",1)] syn
let useIndex = headMay [ f | ListVal [StringLike "--index", StringLike f] <- opts ] let dry = or [ True | ListVal [StringLike "--dry"] <- opts ]
let hd = headDef "HEAD" [ x | StringLike x <- argz] let hd = headDef "HEAD" [ x | StringLike x <- argz]
h <- gitRevParseThrow hd h <- gitRevParseThrow hd
@ -1190,11 +1215,14 @@ theDict = do
| ListVal [StringLike "--ref", StringLike x] <- opts | ListVal [StringLike "--ref", StringLike x] <- opts
] ]
mmaped <- runMaybeT do updateReflogIndex
fname <- toMPlus useIndex
liftIO $ mmapFileByteString fname Nothing
_already <- newTVarIO mempty idx <- openIndex
_already <- newTVarIO ( mempty :: HashSet GitHash )
enumEntries idx $ \bs -> do
atomically $ modifyTVar _already (HS.insert (coerce $ BS.take 20 bs))
level <- getCompressionLevel level <- getCompressionLevel
segment <- getPackedSegmetSize segment <- getPackedSegmetSize
@ -1204,14 +1232,7 @@ theDict = do
notWrittenYet :: forall m . MonadIO m => GitHash -> m Bool notWrittenYet :: forall m . MonadIO m => GitHash -> m Bool
notWrittenYet x = do notWrittenYet x = do
already <- readTVarIO _already <&> HS.member x already <- readTVarIO _already <&> HS.member x
alsoInIdx <- maybe1 mmaped (pure False) $ \m -> do pure (not already) -- && not alsoInIdx)
found <- binarySearchBS 24 (BS.take 20 . BS.drop 4) (coerce x) m
pure (isJust found)
pure (not already && not alsoInIdx)
hs <- maybe1 useIndex (pure mempty) $ \fn -> readIndexFromFile fn
debug $ "INDEX" <+> pretty (HS.size hs)
hpsq <- readCommitChainHPSQ notWrittenYet Nothing h (\c -> debug $ "commit" <+> pretty c) hpsq <- readCommitChainHPSQ notWrittenYet Nothing h (\c -> debug $ "commit" <+> pretty c)
@ -1247,6 +1268,8 @@ theDict = do
lbs <- LBS.readFile fn lbs <- LBS.readFile fn
let meta = mempty let meta = mempty
let gk = Nothing let gk = Nothing
unless dry do
href <- createTreeWithMetadata sto gk meta lbs >>= orThrowPassIO href <- createTreeWithMetadata sto gk meta lbs >>= orThrowPassIO
writeLogEntry ("tree" <+> pretty ts <+> pretty href) writeLogEntry ("tree" <+> pretty ts <+> pretty href)
debug $ "SENDING" <+> pretty href <+> pretty fn debug $ "SENDING" <+> pretty href <+> pretty fn
@ -1257,6 +1280,8 @@ theDict = do
r <- callRpcWaitMay @RpcRefLogPost (TimeoutSec 2) reflogAPI tx r <- callRpcWaitMay @RpcRefLogPost (TimeoutSec 2) reflogAPI tx
>>= orThrowUser "rpc timeout" >>= orThrowUser "rpc timeout"
pure ()
rm fn rm fn
next next

52
hbs2-git3/lib/HBS2/Git3/State/Index.hs
View File

@ -213,13 +213,28 @@ bloomFilterSize n k p
where where
rnd x = 2 ** realToFrac (ceiling (logBase 2 x)) & round rnd x = 2 ** realToFrac (ceiling (logBase 2 x)) & round
writeReflogIndex :: forall m . ( Git3Perks m readTxMay :: forall m . ( MonadIO m
)
=> AnyStorage -> HashRef -> m (Maybe AnnotatedHashRef)
readTxMay sto href = runMaybeT do
tx <- getBlock sto (coerce href)
>>= toMPlus
RefLogUpdate{..} <- deserialiseOrFail @(RefLogUpdate L4Proto) tx
& toMPlus
deserialiseOrFail @AnnotatedHashRef (LBS.fromStrict _refLogUpdData)
& toMPlus
updateReflogIndex :: forall m . ( Git3Perks m
, MonadReader Git3Env m , MonadReader Git3Env m
, HasClientAPI PeerAPI UNIX m , HasClientAPI PeerAPI UNIX m
, HasClientAPI RefLogAPI UNIX m , HasClientAPI RefLogAPI UNIX m
, HasStorage m , HasStorage m
) => m () ) => m ()
writeReflogIndex = do updateReflogIndex = do
reflog <- getGitRemoteKey >>= orThrow Git3ReflogNotSet reflog <- getGitRemoteKey >>= orThrow Git3ReflogNotSet
@ -257,14 +272,7 @@ writeReflogIndex = do
Right (hs :: [HashRef]) -> do Right (hs :: [HashRef]) -> do
for_ [h | h <- hs, not (HS.member h written)] $ \h -> void $ runMaybeT do for_ [h | h <- hs, not (HS.member h written)] $ \h -> void $ runMaybeT do
tx <- getBlock sto (coerce h) AnnotatedHashRef _ href <- readTxMay sto (coerce h) >>= toMPlus
>>= toMPlus
RefLogUpdate{..} <- deserialiseOrFail @(RefLogUpdate L4Proto) tx
& toMPlus
AnnotatedHashRef _ href <- deserialiseOrFail @AnnotatedHashRef (LBS.fromStrict _refLogUpdData)
& toMPlus
-- FIXME: error logging -- FIXME: error logging
lbs <- liftIO (runExceptT (getTreeContents sto href)) lbs <- liftIO (runExceptT (getTreeContents sto href))
@ -286,27 +294,3 @@ writeReflogIndex = do
-- notice $ pretty sha1 <+> pretty tx -- notice $ pretty sha1 <+> pretty tx
writeSection ( LBS.fromChunks [key,value] ) (LBS.hPutStr wh) writeSection ( LBS.fromChunks [key,value] ) (LBS.hPutStr wh)
-- files <- lift listObjectIndexFiles
-- let num = sum (fmap snd files) `div` 56
-- let size = bloomFilterSize num 5 0.01
-- bloom <- liftIO $ stToIO (MBloom.new bloomHash (fromIntegral size))
-- lift $ enumEntries $ \bs -> do
-- liftIO $ stToIO $ MBloom.insert bloom (coerce bs)
-- let bloomIdxName = idxPath </> "filter"
-- bytes <- liftIO $ stToIO $ Bloom.freeze bloom
-- liftIO $ UIO.withBinaryFileAtomic bloomIdxName WriteMode $ \wh -> do
-- LBS.hPutStr wh "puk"
-- LBS.hPutStr wh (serialise bytes)
-- LBS.writeFile (serialise b
-- for_ ss $ \sha1 -> do
-- let key = coerce @_ @N.ByteString sha1
-- let value = coerce @_ @N.ByteString tx
-- -- notice $ pretty sha1 <+> pretty tx
-- writeSection ( LBS.fromChunks [key,value] ) (LBS.hPutStr wh)