wip

hbs2-git3/app/Main.hs

@@ -104,7 +104,7 @@ import Control.Monad.Trans.Writer.CPS qualified as Writer
 import Control.Concurrent.STM qualified as STM
 import System.Directory (setCurrentDirectory)
 import System.IO (hPrint,hGetLine,IOMode(..))
-import System.Random
+import System.Random hiding (next)
 import System.IO.MMap (mmapFileByteString)
 import System.IO qualified as IO
 
@@ -253,6 +253,38 @@ withGitCat action = do
   p <- startProcess config
   action p
 
+withGitCatCheck ::  (MonadIO m) => (Process Handle Handle () -> m a) -> m a
+withGitCatCheck action = do
+  let cmd = "git"
+  let args = ["cat-file", "--batch-check"]
+  let config = setStdin createPipe $ setStdout createPipe $ setStderr closed $ proc cmd args
+  p <- startProcess config
+  action p
+
+gitCheckObjectFromHandle :: MonadIO m => Process Handle Handle a -> GitHash -> m (Maybe (GitObjectType, Int))
+gitCheckObjectFromHandle ph gh = liftIO do
+
+  let ssin = getStdin ph
+  let ssout = getStdout ph
+
+  hPrint ssin (pretty gh) >> hFlush ssin
+
+  s <- hGetLine ssout
+
+  runMaybeT do
+
+    case words s of
+      [_,t,ss] -> do
+        n <- readMay @Int ss & toMPlus
+        o <- fromStringMay @GitObjectType t & toMPlus
+        pure $ (o,n)
+
+      [_,"missing"] -> do
+        mzero
+
+      w -> throwIO (GitReadError $ show (pretty w))
+
+
 instance GitObjectReader (Process Handle Handle ()) where
   gitReadObjectMaybe ph co = liftIO do
 
@@ -2067,15 +2099,24 @@ data {LBS.length body}|]
 
                 _ -> none
 
-        entry $ bindMatch "test:git:zstd:packed:import" $ nil_ $ \syn -> lift do
+        entry $ bindMatch "test:git:zstd:packed:import" $ nil_ $ \syn -> lift $ flip runContT pure do
-          let (opts, argz) = splitOpts [("--scary",0)] syn
+          let (opts, argz) = splitOpts [] syn
           let logs = [ x| StringLike x <- argz ]
 
-          let scary = or [ True | ListVal [StringLike "--scary"] <- opts ]
-
           d <- findGitDir >>= orThrowUser "not a git directory"
 
-          forConcurrently_ logs $ \lfn -> do
+          inQ <- newTQueueIO
+          rr <- replicateM 8 $ ContT $ withAsync $ liftIO $ flip runContT pure do
+            che <- ContT $ withGitCatCheck
+            fix \next -> do
+              (o, answ) <- atomically $ readTQueue inQ
+              w <- gitCheckObjectFromHandle che o
+              atomically $ writeTQueue answ w
+              next
+
+          mapM_ link rr
+
+          lift $ forConcurrently_ logs $ \lfn -> do
 
             debug $ pretty lfn
 
@@ -2084,17 +2125,14 @@ data {LBS.length body}|]
             runConsumeLBS (ZstdL.decompress lbs) $ readLogFileLBS () $ \h s lbs -> do
               let (t, body) = LBS.splitAt 1 lbs
 
-              let tp = case t of
+              let tp = fromStringMay @(Short GitObjectType) (LBS8.unpack t)
-                        "T" -> Tree
+                           & maybe Blob coerce
-                        "C" -> Commit
-                        "B" -> Blob
-                        _   -> Blob
 
-              debug $ "FUCKING IMPORT OBJECT" <+> pretty h <+> pretty tp
+              answ <- newTQueueIO
 
-              if not scary then do
+              atomically $ writeTQueue inQ (h, answ)
-                gitImportObjectSlow tp body >>= orThrow (GitImportError (show $ pretty tp <+> pretty h))
+              here <- atomically do
-              else do
+                        readTQueue answ <&> isJust
 
               let gitHash = show $ pretty h
               let (prefix,name) = L.splitAt 2 gitHash
@@ -2103,10 +2141,11 @@ data {LBS.length body}|]
               let signature = [qc|{pretty tp} {pretty $ LBS.length body}|] <> "\x00" :: LBS8.ByteString
               let o = signature <> body
 
-                here <- doesPathExist path
 
               unless here $ liftIO do
 
+                debug $ "FUCKING IMPORT OBJECT" <+> pretty here <+> pretty h <+> pretty tp
+
                 touch path
 
                 debug $ pretty tp <+> pretty s <+> pretty h <+> pretty path