wip, exporting references

hbs2-fixer/hbs2-fixer.cabal

@@ -68,7 +68,7 @@ common shared-properties
                , streaming
                , streaming-bytestring
                , streaming-commons
-               , cryptonite
+               , crypton
                , directory
                , exceptions
                , filelock

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)

hbs2-git3/hbs2-git3.cabal

@@ -73,6 +73,7 @@ common shared-properties
       , binary
       , bitvec
       , containers
+      , crypton
       , directory
       , exceptions
       , filepath

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)
+

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
 
 

hbs2/hbs2.cabal

@@ -73,7 +73,7 @@ executable hbs2
                     , cborg
                     , clock
                     , containers
-                    , cryptonite
+                    , crypton
                     , deepseq
                     , directory
                     , filepath