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

wip4

This commit is contained in:
voidlizard 2024-12-03 08:38:41 +03:00
parent 778e172b9d
commit 4a380c62c3
1 changed files with 54 additions and 56 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -140,7 +140,7 @@ isGitLsTreeEntry = \case
gitReadTree :: (Pretty what, MonadIO m) => what -> m [GitTreeEntry] gitReadTree :: (Pretty what, MonadIO m) => what -> m [GitTreeEntry]
gitReadTree what = gitReadTree what =
gitRunCommand [qc|git ls-tree -t -l -r {pretty what}|] gitRunCommand [qc|git ls-tree -t -l -r {pretty what}|]
>>= orThrowPassIO >>= orThrow (GitReadError (show $ pretty what))
<&> fmap LBS8.words . LBS8.lines <&> fmap LBS8.words . LBS8.lines
<&> mapMaybe \case <&> mapMaybe \case
GitTreeEntryView v -> do GitTreeEntryView v -> do
@ -522,7 +522,6 @@ export r = connectedDo $ flip runContT pure do
parents <- gitReadCommitParents bs parents <- gitReadCommitParents bs
n <- for (zip [1..] parents) $ \(i,gh) -> do n <- for (zip [1..] parents) $ \(i,gh) -> do
-- exists <- cached missed gh (gitObjectExists gh)
exists <- liftIO $ cached missed gh (isJust <$> gitReadObjectMaybe reader gh) exists <- liftIO $ cached missed gh (isJust <$> gitReadObjectMaybe reader gh)
here <- withState $ selectCBlock gh <&> isJust here <- withState $ selectCBlock gh <&> isJust
@ -547,86 +546,85 @@ export r = connectedDo $ flip runContT pure do
next ExportGetCommit next ExportGetCommit
ExportProcessCommit co bs -> do ExportProcessCommit co bs -> do
debug $ "write pack for" <+> pretty co debug $ "write pack for" <+> pretty co
hhead <- gitRevParse co hhead <- gitRevParse co
>>= orThrow (OtherGitError $ show $ "can't parse" <+> pretty co) >>= orThrow (OtherGitError $ show $ "can't parse" <+> pretty co)
parents <- gitReadObjectThrow Commit hhead parents <- gitReadObjectThrow Commit hhead
>>= gitReadCommitParents >>= gitReadCommitParents
skip <- if not (excludeParents ()) then do skip <- if not (excludeParents ()) then do
pure mempty pure mempty
else do else do
skip' <- S.toList_ $ for parents $ \p -> do skip' <- S.toList_ $ for parents $ \p -> do
-- exists <- liftIO $ cached missed p (gitObjectExists p) lift (try @_ @GitException (gitReadTree p))
exists <- liftIO $ cached missed p (isJust <$> gitReadObjectMaybe reader p) <&> fromRight mempty
when exists do <&> fmap gitEntryHash >>= S.each
gitReadTree p <&> fmap gitEntryHash >>= S.each
pure $ HS.fromList skip' pure $ HS.fromList skip'
r <- gitReadTree hhead r <- gitReadTree hhead
<&> L.filter (\GitTreeEntry{..} -> not (HS.member gitEntryHash skip)) <&> L.filter (\GitTreeEntry{..} -> not (HS.member gitEntryHash skip))
-- <&> L.filter (\GitTreeEntry{..} -> gitEntryType /= Tree) -- <&> L.filter (\GitTreeEntry{..} -> gitEntryType /= Tree)
<&> sortGitTreeEntries <&> sortGitTreeEntries
let blkMax = 1048576 let blkMax = 1048576
out <- newTQueueIO out <- newTQueueIO
flip fix (EWAcc 1 r 0 [(co,Commit,Nothing,bs)]) $ \go -> \case flip fix (EWAcc 1 r 0 [(co,Commit,Nothing,bs)]) $ \go -> \case
EWAcc _ [] _ [] -> none EWAcc _ [] _ [] -> none
EWAcc i [] l acc -> do EWAcc i [] l acc -> do
writePack sto l acc >>= atomically . writeTQueue out writePack sto l acc >>= atomically . writeTQueue out
EWAcc i (r@GitTreeEntry{..}:rs) l acc | gitEntrySize >= Just (fromIntegral blkMax) -> do EWAcc i (r@GitTreeEntry{..}:rs) l acc | gitEntrySize >= Just (fromIntegral blkMax) -> do
writeLargeBlob sto reader r >>= atomically . writeTQueue out writeLargeBlob sto reader r >>= atomically . writeTQueue out
go (EWAcc (succ i) rs l acc) go (EWAcc (succ i) rs l acc)
EWAcc i rs l acc | l >= blkMax -> do EWAcc i rs l acc | l >= blkMax -> do
writePack sto l acc >>= atomically . writeTQueue out writePack sto l acc >>= atomically . writeTQueue out
go (EWAcc (succ i) rs 0 mempty) go (EWAcc (succ i) rs 0 mempty)
EWAcc i (e@GitTreeEntry{..}:rs) l acc -> do EWAcc i (e@GitTreeEntry{..}:rs) l acc -> do
lbs <- gitReadObjectMaybe reader gitEntryHash lbs <- gitReadObjectMaybe reader gitEntryHash
>>= orThrow (GitReadError (show $ pretty gitEntryHash)) >>= orThrow (GitReadError (show $ pretty gitEntryHash))
<&> snd <&> snd
go (EWAcc i rs (l + fromIntegral (LBS.length lbs)) ((gitEntryHash,gitEntryType, Just e, lbs) : acc)) go (EWAcc i rs (l + fromIntegral (LBS.length lbs)) ((gitEntryHash,gitEntryType, Just e, lbs) : acc))
packs <- atomically $ STM.flushTQueue out packs <- atomically $ STM.flushTQueue out
phashes <- catMaybes <$> withState (for parents selectCBlock) phashes <- catMaybes <$> withState (for parents selectCBlock)
let v = "hbs2-git 3.0 zstd" let v = "hbs2-git 3.0 zstd"
let pps = vcat $ mconcat $ for phashes $ \p -> ["p" <+> pretty p] let pps = vcat $ mconcat $ for phashes $ \p -> ["p" <+> pretty p]
let meta = LBS8.pack $ show $ pretty v <> line <> pps let meta = LBS8.pack $ show $ pretty v <> line <> pps
hmeta <- putBlock sto meta >>= orThrow StorageError <&> HashRef hmeta <- putBlock sto meta >>= orThrow StorageError <&> HashRef
let cblock = hmeta : phashes <> packs let cblock = hmeta : phashes <> packs
let pt = toPTree (MaxSize 1024) (MaxNum 1024) cblock let pt = toPTree (MaxSize 1024) (MaxNum 1024) cblock
root <- makeMerkle 0 pt $ \(_,_,s) -> do root <- makeMerkle 0 pt $ \(_,_,s) -> do
void $ putBlock sto s void $ putBlock sto s
withState $ transactional do withState $ transactional do
for_ packs $ \href -> do for_ packs $ \href -> do
insertGitPack co href insertGitPack co href
insertCBlock co (HashRef root) insertCBlock co (HashRef root)
notice $ "cblock" <+> pretty root notice $ "cblock" <+> pretty root
atomically do atomically do
modifyTVar done (HS.insert co) modifyTVar done (HS.insert co)
modifyTVar q (HPSQ.delete co) modifyTVar q (HPSQ.delete co)
next ExportGetCommit next ExportGetCommit
ExportCheck -> do ExportCheck -> do
debug $ "ExportCheck dummy" <+> pretty r debug $ "ExportCheck dummy" <+> pretty r