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

wip36

This commit is contained in:
voidlizard 2024-12-07 19:29:10 +03:00
parent c7c323ca9e
commit debe84f3ca
1 changed files with 75 additions and 55 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1234,7 +1234,7 @@ theDict = do
LBS.hGetContents stdin <&> Zlib.decompress >>= LBS.hPutStr stdout LBS.hGetContents stdin <&> Zlib.decompress >>= LBS.hPutStr stdout
entry $ bindMatch "test:git:cblock:import" $ nil_ $ \syn -> lift do entry $ bindMatch "test:git:cblock:import" $ nil_ $ \syn -> lift do
let opts = splitOpts [("--deep",0),("--shallow",0),("--dry",0)] syn let opts = splitOpts [("--deep",0),("--only",0),("--dry",0)] syn
d <- findGitDir >>= orThrowUser "not a git directory" d <- findGitDir >>= orThrowUser "not a git directory"
@ -1242,24 +1242,34 @@ theDict = do
debug $ "DIR" <+> pretty d debug $ "DIR" <+> pretty d
cb <- [ x | HashLike x <- snd opts ] & headMay & orThrowUser "import: cblock not set" cb0 <- [ x | HashLike x <- snd opts ] & headMay & orThrowUser "import: cblock not set"
indexCBlockCommits cb indexCBlockCommits cb0
let shallow = or [ True | ListVal [StringLike "--shallow"] <- fst opts ] _done <- newTVarIO ( mempty :: HashSet HashRef )
let deep = or [ True | ListVal [StringLike "--deep"] <- fst opts ] && not shallow
debug $ "cblock" <+> pretty deep <+> pretty cb let deep = or [ True | ListVal [StringLike "--deep"] <- fst opts ]
let only = or [ True | ListVal [StringLike "--only"] <- fst opts ]
debug $ "cblock" <+> pretty deep <+> pretty cb0 <+> pretty only <+> pretty deep
sto <- getStorage sto <- getStorage
let whatever cblock = do let whatever cblock = do
co <- listOnlyCommitsFromCBlock sto cblock co <- listOnlyCommitsFromCBlock sto cblock
e <- mapM gitObjectExists co <&> and e <- mapM gitObjectExists co <&> and
debug $ "WHATEVER" <+> pretty e <+> pretty cb <+> pretty co let continue = deep || not e || (only && cblock == cb0)
pure $ not e
traverseToCBlock sto cb whatever $ \i theCblk hs -> do debug $ "WHATEVER" <+> pretty e <+> pretty cblock <+> pretty co
unless continue do
debug $ "STOPPED" <+> pretty e <+> pretty cblock <+> pretty co
pure continue
flip runContT pure $ callCC \exit -> do
traverseToCBlock sto cb0 whatever $ \i theCblk hs -> do
debug $ green "process cblock data" <+> pretty i <+> pretty theCblk debug $ green "process cblock data" <+> pretty i <+> pretty theCblk
_orphans <- newTVarIO ( mempty :: HashSet GitHash ) _orphans <- newTVarIO ( mempty :: HashSet GitHash )
@ -1267,11 +1277,14 @@ theDict = do
for_ hs $ \hx -> do for_ hs $ \hx -> do
what <- runExceptT (getTreeContents sto hx) >>= orThrowPassIO what <- lift $ runExceptT (getTreeContents sto hx) >>= orThrowPassIO
enumGitPackObjectsFromLBS DoEnumPayload what $ \case enumGitPackObjectsFromLBS DoEnumPayload what $ \case
IOp _ s (IGitObject t h (Just body)) -> liftIO do IOp _ s (IGitObject t h (Just body)) -> liftIO do
debug $ red "AAAAQA!" <+> pretty h
let signature = [qc|{pretty t} {pretty s}|] <> "\x00" :: LBS8.ByteString let signature = [qc|{pretty t} {pretty s}|] <> "\x00" :: LBS8.ByteString
let gitHash = show $ pretty h let gitHash = show $ pretty h
let (prefix,name) = L.splitAt 2 gitHash let (prefix,name) = L.splitAt 2 gitHash
@ -1307,6 +1320,13 @@ theDict = do
_ -> pure True _ -> pure True
atomically $ modifyTVar _done (HS.insert hx)
isDone <- readTVarIO _done <&> HS.member cb0
when (only && isDone) $ exit ()
lift do
debug "updating .git/shallow" debug "updating .git/shallow"
let shallowFile = d </> "shallow" let shallowFile = d </> "shallow"
new <- readTVarIO _orphans new <- readTVarIO _orphans