diff --git a/hbs2-git3/app/Main.hs b/hbs2-git3/app/Main.hs index bccfa615..f7cb0d19 100644 --- a/hbs2-git3/app/Main.hs +++ b/hbs2-git3/app/Main.hs @@ -51,6 +51,8 @@ import Codec.Compression.Zstd.Streaming qualified as ZstdS import Codec.Compression.Zstd.Streaming (Result(..)) import Codec.Compression.Zstd (maxCLevel) +import Codec.Compression.Zlib qualified as Zlib + import qualified Data.Attoparsec.ByteString as A import Data.HashPSQ qualified as HPSQ import Data.HashPSQ (HashPSQ) @@ -91,6 +93,7 @@ import Data.List (sortOn) import Data.Ord (Down(..)) import UnliftIO +import UnliftIO.IO.File qualified as UIO {- HLINT ignore "Functor law" -} {- HLINT ignore "Eta reduce" -} @@ -381,6 +384,22 @@ gitReadCommitParents bs = do | ListVal [ StringLike "parent", StringLike hash ] <- what ] & catMaybes + +gitReadCommitTree :: MonadIO m => ByteString -> m GitHash +gitReadCommitTree bs = do + + what <- LBS8.lines bs + & takeWhile ( not . LBS8.null ) + & LBS8.unpack . LBS8.unlines + & parseTop + & orThrow (OtherGitError "invalid commit format") + + let r = [ fromStringMay @GitHash hash + | ListVal [ StringLike "tree", StringLike hash ] <- what + ] + + catMaybes r & headMay & orThrow (InvalidObjectFormat Commit Nothing) + gitObjectExists :: (MonadIO m, Pretty what) => what -> m Bool gitObjectExists what = do gitRunCommand [qc|git cat-file -e {pretty what}|] <&> isRight @@ -654,15 +673,9 @@ export mref' r = connectedDo $ flip runContT pure do n <- for (zip [1..] parents) $ \(i,gh) -> do - -- exists <- gitObjectExists gh exists <- liftIO (cached commits gh (gitReadObjectMaybe reader gh)) <&> isJust - -- unless exists do - -- really <- gitObjectExists gh - -- unless really do - -- throwIO (GitReadError (show $ "export" <+> pretty co)) - here <- withState $ selectCBlock gh <&> isJust unless exists do @@ -699,6 +712,8 @@ export mref' r = connectedDo $ flip runContT pure do parents <- gitReadObjectThrow Commit hhead >>= gitReadCommitParents + tree <- gitReadCommitTree bs + skip <- if not (excludeParents ()) then do pure mempty else do @@ -722,7 +737,11 @@ export mref' r = connectedDo $ flip runContT pure do let ref = maybeToList $ EGitRef <$> mref <*> pure now <*> pure (Just co) - let seed = (if lastBlock then ref else mempty) <> [EGitObject Commit co Nothing bs] + (_,tbs) <- gitReadObjectMaybe reader tree + >>= orThrow (GitReadError (show $ pretty tree)) + + let commitItself = [EGitObject Tree tree Nothing tbs, EGitObject Commit co Nothing bs] + let seed = (if lastBlock then ref else mempty) <> commitItself flip fix (EWAcc 1 r 0 seed) $ \go -> \case @@ -991,6 +1010,15 @@ traverseToCBlock sto cblock dig process = do next $ WNextSBlock +indexCBlockCommits :: forall m . ( MonadIO m + , HasStateDB m + , HasStorage m + ) + => HashRef -> m () + +indexCBlockCommits cb = do + pure () + -- FIXME: move-to-suckless-script splitOpts :: [(Id,Int)] -> [Syntax C] @@ -1139,13 +1167,22 @@ theDict = do _ -> throwIO (BadFormException @C nil) + entry $ bindMatch "zlib:deflate" $ nil_ $ const $ liftIO do + LBS.hGetContents stdin <&> Zlib.decompress >>= LBS.hPutStr stdout + entry $ bindMatch "test:git:cblock:import" $ nil_ $ \syn -> lift do let opts = splitOpts [("--deep",0),("--shallow",0),("--dry",0)] syn + d <- findGitDir >>= orThrowUser "not a git directory" + debug $ pretty opts + debug $ "DIR" <+> pretty d + cb <- [ x | HashLike x <- snd opts ] & headMay & orThrowUser "import: cblock not set" + indexCBlockCommits cb + let shallow = or [ True | ListVal [StringLike "--shallow"] <- fst opts ] let deep = or [ True | ListVal [StringLike "--deep"] <- fst opts ] && not shallow @@ -1153,15 +1190,43 @@ theDict = do sto <- getStorage - let whatever _ = do - -- shallow: - -- 1. get commits - -- 2. if all commits here -> stop + let whatever cb = do + co <- withState $ selectCommitsByCBlock cb + e <- mapM gitObjectExists co <&> and + debug $ "WHATEVER" <+> pretty e <+> pretty cb <+> pretty co pure True + -- pure $ not e - traverseToCBlock sto cb whatever $ \i h _ -> do + traverseToCBlock sto cb whatever $ \i h hs -> do debug $ green "process cblock data" <+> pretty i <+> pretty h + for_ hs $ \hx -> do + + what <- runExceptT (getTreeContents sto hx) >>= orThrowPassIO + + enumGitPackObjectsFromLBS DoEnumPayload what $ \case + + IOp _ s (IGitObject t h (Just body)) -> liftIO do + let signature = [qc|{pretty t} {pretty s}|] <> "\x00" :: LBS8.ByteString + let gitHash = show $ pretty h + let (prefix,name) = L.splitAt 2 gitHash + let path = joinPath [d, "objects", prefix, name] + + touch path + + liftIO $ print $ pretty t <+> pretty s <+> pretty h <+> pretty path + + let params = Zlib.defaultCompressParams { Zlib.compressMethod = Zlib.deflateMethod } + UIO.withBinaryFileAtomic path WriteMode $ \fh -> do + let contents = Zlib.compressWith params (signature <> body) + LBS.hPutStr fh contents + + pure True + + _ -> pure True + + pure () + entry $ bindMatch "test:git:cblock:scan" $ nil_ $ \case [ HashLike cblock ] -> lift do diff --git a/hbs2-git3/lib/HBS2/Git3/State/Direct.hs b/hbs2-git3/lib/HBS2/Git3/State/Direct.hs index d2547425..898f8e85 100644 --- a/hbs2-git3/lib/HBS2/Git3/State/Direct.hs +++ b/hbs2-git3/lib/HBS2/Git3/State/Direct.hs @@ -44,8 +44,9 @@ evolveState = do ddl [qc| create table if not exists cblock - ( kommit text not null primary key + ( kommit text not null , cblock text not null + , primary key (kommit, cblock) ) |] @@ -72,7 +73,7 @@ insertCBlock :: MonadIO m => GitHash -> HashRef -> DBPipeM m () insertCBlock co cblk = do insert [qc| insert into cblock (kommit, cblock) values(?,?) - on conflict (kommit) do update set cblock = excluded.cblock + on conflict (kommit,cblock) do update set cblock = excluded.cblock |] (co, cblk) selectCBlock :: MonadIO m => GitHash -> DBPipeM m (Maybe HashRef) @@ -80,3 +81,9 @@ selectCBlock gh = do select [qc|select cblock from cblock where kommit = ? limit 1|] (Only gh) <&> listToMaybe . fmap fromOnly +selectCommitsByCBlock :: MonadIO m => HashRef -> DBPipeM m [GitHash] +selectCommitsByCBlock cb = do + select [qc|select kommit from cblock where cblock = ? limit 1|] (Only cb) + <&> fmap fromOnly + +