diff --git a/hbs2-fixer/hbs2-fixer.cabal b/hbs2-fixer/hbs2-fixer.cabal index 01beff6a..984f59c5 100644 --- a/hbs2-fixer/hbs2-fixer.cabal +++ b/hbs2-fixer/hbs2-fixer.cabal @@ -68,7 +68,7 @@ common shared-properties , streaming , streaming-bytestring , streaming-commons - , cryptonite + , crypton , directory , exceptions , filelock diff --git a/hbs2-git3/app/Main.hs b/hbs2-git3/app/Main.hs index a9ddac95..63f3e7c5 100644 --- a/hbs2-git3/app/Main.hs +++ b/hbs2-git3/app/Main.hs @@ -659,6 +659,10 @@ theDict = do liftIO $ print $ pretty $ length commits + entry $ bindMatch "test:git:hash:blob" $ nil_ $ const $ liftIO do + co <- LBS.hGetContents stdin + print $ pretty $ gitHashBlobPure co + entry $ bindMatch "test:git:exists:fast" $ nil_ \case [ StringLike x ] -> lift $ flip runContT pure do @@ -706,8 +710,6 @@ theDict = do let (opts, argz) = splitOpts [("--git",0),("--packed",0),("--import",1)] syn - err $ pretty opts - let git = or [ True | ListVal [StringLike "--git"] <- opts ] let packed = or [ True | ListVal [StringLike "--packed"] <- opts ] @@ -751,6 +753,24 @@ theDict = do liftIO $ print $ "object" <+> pretty h <+> pretty s + entry $ bindMatch "test:git:log:list:refs" $ nil_ $ \syn -> do + let (_, argz) = splitOpts [] syn + + let fs = [fn | StringLike fn <- argz] + + for_ fs $ \f -> do + lbs <- liftIO$ LBS.readFile f + runConsumeLBS (ZstdL.decompress lbs) $ readLogFileLBS () $ \h s lbs -> do + let (sign,rest) = LBS.splitAt 1 lbs + + let tp = fromStringMay @(Short SegmentObjectType) (LBS8.unpack sign) + + case tp of + Just (Short RefObject) -> do + liftIO $ LBS.hPutStr stdout rest + + _ -> pure () + entry $ bindMatch "test:git:log:index:flat:dump" $ nil_ $ \syn -> lift do let (_, argz) = splitOpts [] syn fname <- headMay [ x | StringLike x <- argz] & orThrowUser "no file" @@ -999,7 +1019,7 @@ theDict = do LBS.hPutStr fh contents entry $ bindMatch "test:git:export" $ nil_ $ \syn -> lift do - let (opts, argz) = splitOpts [("--index",1)] syn + let (opts, argz) = splitOpts [("--index",1),("--ref",1)] syn maxW <- getPackedSegmetSize @@ -1008,6 +1028,10 @@ theDict = do let hd = headDef "HEAD" [ x | StringLike x <- argz] h <- gitRevParseThrow hd + let refs = [ gitNormaliseRef (fromString x) + | ListVal [StringLike "--ref", StringLike x] <- opts + ] + mmaped <- runMaybeT do fname <- toMPlus useIndex liftIO $ mmapFileByteString fname Nothing @@ -1102,6 +1126,8 @@ theDict = do -- void $ ContT $ bracket (pure pool) cancel + let lastCommit = last r + workers <- lift $ forM (zip [0..] commitz) $ \(i,chunk) -> async $ flip runContT pure do -- let gitCatBatchQ commit = gitReadObjectMaybe theReader commit @@ -1133,6 +1159,26 @@ theDict = do atomically do writeTBQueue sourceQ (Just e) + when (commit == lastCommit) do + + ts <- liftIO $ getPOSIXTime <&> round + + let brefs = [ LBS8.pack (show $ pretty ts <+> pretty commit <+> pretty x) + | x <- refs + ] & LBS8.unlines + + let sha1 = gitHashBlobPure brefs + + debug $ green "THIS IS THE LAST COMMIT BLOCK" <+> pretty commit <+> "ADDING REF INFO" <+> pretty sha1 + + let e = [ Builder.byteString (coerce sha1) + , Builder.char8 'R' + , Builder.lazyByteString brefs + ] & Builder.toLazyByteString . mconcat + + atomically do + writeTBQueue sourceQ (Just e) + t0 <- getTimeCoarse ContT $ withAsync $ do @@ -1175,6 +1221,8 @@ theDict = do atomically $ writeTBQueue sourceQ Nothing + debug "writing refs" + wait l contWorkerPool :: (MonadUnliftIO m) diff --git a/hbs2-git3/hbs2-git3.cabal b/hbs2-git3/hbs2-git3.cabal index fbcdc34c..d92d6765 100644 --- a/hbs2-git3/hbs2-git3.cabal +++ b/hbs2-git3/hbs2-git3.cabal @@ -73,6 +73,7 @@ common shared-properties , binary , bitvec , containers + , crypton , directory , exceptions , filepath diff --git a/hbs2-git3/lib/HBS2/Git3/Git.hs b/hbs2-git3/lib/HBS2/Git3/Git.hs index aa09aa4c..2306d960 100644 --- a/hbs2-git3/lib/HBS2/Git3/Git.hs +++ b/hbs2-git3/lib/HBS2/Git3/Git.hs @@ -7,12 +7,17 @@ module HBS2.Git3.Git import HBS2.Prelude.Plated import HBS2.OrDie +import HBS2.Git3.Types import HBS2.Git.Local import HBS2.Git.Local.CLI import Data.Config.Suckless.Script +import Crypto.Hash (hashlazy) +import Crypto.Hash qualified as Crypton import Control.Monad.Trans.Maybe +import Data.ByteArray qualified as BA +import Data.ByteString qualified as BS import Data.ByteString.Char8 qualified as BS8 import Data.ByteString.Lazy ( ByteString ) import Data.ByteString.Lazy.Char8 qualified as LBS8 @@ -236,22 +241,12 @@ instance GitObjectReader (Process Handle Handle ()) where w -> throwIO (GitReadError $ show (pretty w)) -newtype Short x = Short x - -instance Pretty (Short GitObjectType) where - pretty = \case - (Short Tree) -> "T" - (Short Blob) -> "B" - (Short Commit) -> "C" - - -instance FromStringMaybe (Short GitObjectType) where - fromStringMay = \case - "T" -> Just (Short Tree) - "B" -> Just (Short Blob) - "C" -> Just (Short Commit) - _ -> Just (Short Blob) sortGitTreeEntries :: [GitTreeEntry] -> [GitTreeEntry] sortGitTreeEntries = sortOn (\e -> (gitEntryType e, gitEntrySize e)) +gitHashBlobPure :: ByteString -> GitHash +gitHashBlobPure body = do + let preamble = [qc|{pretty Blob} {pretty $ LBS.length body}|] <> "\x00" :: LBS8.ByteString + GitHash $ BS.pack $ BA.unpack $ hashlazy @Crypton.SHA1 (preamble <> body) + diff --git a/hbs2-git3/lib/HBS2/Git3/Types.hs b/hbs2-git3/lib/HBS2/Git3/Types.hs index 6af7c87e..e28e4043 100644 --- a/hbs2-git3/lib/HBS2/Git3/Types.hs +++ b/hbs2-git3/lib/HBS2/Git3/Types.hs @@ -2,8 +2,37 @@ module HBS2.Git3.Types where import HBS2.Prelude.Plated import HBS2.Net.Auth.Credentials +import HBS2.Git.Local type GitRemoteKey = PubKey 'Sign 'HBS2Basic +newtype Short x = Short x + +instance Pretty (Short GitObjectType) where + pretty = \case + (Short Tree) -> "T" + (Short Blob) -> "B" + (Short Commit) -> "C" + + +instance FromStringMaybe (Short GitObjectType) where + fromStringMay = \case + "T" -> Just (Short Tree) + "B" -> Just (Short Blob) + "C" -> Just (Short Commit) + _ -> Just (Short Blob) + + +instance FromStringMaybe (Short SegmentObjectType) where + fromStringMay = \case + "T" -> Just (Short (GitObject Tree)) + "B" -> Just (Short (GitObject Blob)) + "C" -> Just (Short (GitObject Commit)) + "R" -> Just (Short RefObject) + _ -> Just (Short (GitObject Blob)) + +data SegmentObjectType = + GitObject GitObjectType + | RefObject diff --git a/hbs2/hbs2.cabal b/hbs2/hbs2.cabal index 416627b0..e59a9259 100644 --- a/hbs2/hbs2.cabal +++ b/hbs2/hbs2.cabal @@ -73,7 +73,7 @@ executable hbs2 , cborg , clock , containers - , cryptonite + , crypton , deepseq , directory , filepath