wip36

hbs2-git3/app/Main.hs

@@ -1234,7 +1234,7 @@ theDict = 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
+          let opts = splitOpts [("--deep",0),("--only",0),("--dry",0)] syn
 
           d <- findGitDir >>= orThrowUser "not a git directory"
 
@@ -1242,24 +1242,34 @@ theDict = do
 
           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 ]
-          let deep    = or [ True | ListVal [StringLike "--deep"]    <- fst opts ] && not shallow
+          _done <- newTVarIO ( mempty :: HashSet HashRef )
 
-          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
 
           let whatever cblock = do
                 co <- listOnlyCommitsFromCBlock sto cblock
                 e <- mapM gitObjectExists co <&> and
-                debug $ "WHATEVER" <+> pretty e <+> pretty cb <+> pretty co
-                pure $ not e
+                let continue = deep || not e || (only  && cblock == cb0)
 
-          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
 
               _orphans <- newTVarIO ( mempty :: HashSet GitHash )
@@ -1267,11 +1277,14 @@ theDict = do
 
               for_ hs $ \hx -> do
 
-              what <- runExceptT (getTreeContents sto hx) >>= orThrowPassIO
+                what <- lift $ runExceptT (getTreeContents sto hx) >>= orThrowPassIO
 
                 enumGitPackObjectsFromLBS DoEnumPayload what $ \case
 
                   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 gitHash = show $ pretty h
                     let (prefix,name) = L.splitAt 2 gitHash
@@ -1307,6 +1320,13 @@ theDict = do
 
                   _ -> pure True
 
+                atomically $ modifyTVar _done (HS.insert hx)
+
+              isDone <- readTVarIO _done <&> HS.member cb0
+
+              when (only && isDone) $ exit ()
+
+              lift do
                 debug "updating .git/shallow"
                 let shallowFile = d </> "shallow"
                 new <- readTVarIO _orphans