wip

hbs2-git3/app/GitRemoteHelper.hs

@@ -185,129 +185,3 @@ silence = do
   setLoggingOff @WARN
   setLoggingOff @NOTICE
 
-
-  -- runGitCLI mempty $ do
-  --   env <- ask
-
-    -- flip runContT pure do
-
-    --   lift $ withGitEnv (env & set gitApplyHeads False) do
-
-    --     debug $ red "run" <+> pretty args
-
-    --     sto <- asks _storage
-    --     ip <- asks _progress
-
-    --     importRepoWait puk
-    --       `catch` (\(_ :: ImportRefLogNotFound) -> do
-    --                   onProgress ip ImportAllDone
-    --                   let url = headMay (catMaybes [ parseURL a | a <- args]) <&> AsBase58
-    --                   pause @'Seconds 0.25
-    --                   liftIO $ hFlush stderr
-    --                   liftIO $ hPutDoc stderr $ ""
-    --                               <> ul (yellow "Reference" <+> pretty url <+>  yellow "is not available yet.") <> line
-    --                               <> "If you sure it's a new one -- make sure you've added the key to hbs2-keyman and then run"
-    --                               <> line <> line
-    --                               <> "hbs2-keyman update" <> line <> line
-    --                               <> "git" <+> pretty hbs2Name <+> "export --new" <+> pretty url <> line <> line
-    --                               <> "to init the reflog first." <> line
-    --                               <> "Pushing to an existing reflog as a new one may cause unwanted data duplication." <> line
-    --                               <> line
-    --                               <> "Note: what ever pushed -- can not be unpushed" <> line
-    --                               <> "If it's not a new reflog --- just wait until it became available"
-    --                   liftIO exitFailure
-    --               )
-    --       `catch` ( \(ImportTxApplyError h) -> do
-    --                   onProgress ip ImportAllDone
-    --                   pause @'Seconds 0.25
-    --                   liftIO $ hFlush stderr
-    --                   liftIO $ hPutDoc stderr $ red "Can not apply tx" <+>  pretty h <> line <> line
-    --                                   <> "It means you don't have a key do decrypt this tx or the data is not completely downloaded yet"
-    --                                   <> line
-
-    --                   liftIO exitFailure
-    --               )
-
-    --     void $ runExceptT do
-
-    --         tpush <- newTQueueIO -- @(GitRef, Maybe GitHash)
-
-    --         flip fix Plain $ \next s -> do
-
-    --           eof <- done
-
-    --           when eof $ pure ()
-
-    --           cmd <- ExceptT (try @_ @IOError (getLine <&> words))
-
-    --           debug $ "C:" <+> pretty cmd
-
-    --           case cmd of
-
-    --             [] | s == Plain -> do
-    --               onProgress ip (ImportSetQuiet True)
-    --               pure ()
-
-    --             [] | s == Push -> do
-    --                    refs <- atomically (STM.flushTQueue tpush)
-    --                              <&> HM.toList . HM.fromList
-
-    --                    importRepoWait puk
-    --                    export puk refs
-    --                    sendLine ""
-    --                    next Plain
-
-    --             ["capabilities"] -> do
-    --               debug $ "send capabilities"
-    --               sendLine "push"
-    --               sendLine "fetch"
-    --               sendLine ""
-    --               next Plain
-
-    --             ("list" : _) -> do
-
-
-    --                 -- FIXME: may-cause-reference-inconsistency
-    --                 --   надо брать max(head) для lwwref
-    --                 --   а не максимальную транзу, накаченную на репо
-    --                 r'  <- runMaybeT do
-    --                         -- tx <- selectMaxAppliedTx >>= lift  . toMPlus <&> fst
-
-    --                         -- (_,rh) <- TX.readRepoHeadFromTx sto tx >>= lift . toMPlus
-    --                         rh <- liftIO (withGitEnv env (readActualRepoHeadFor puk))
-    --                                 >>= toMPlus
-
-    --                         pure (view repoHeadRefs rh)
-
-    --                 let r = fromMaybe mempty r'
-
-    --                 forM_ (fmap (show . formatRef) r) sendLine
-
-    --                 sendLine ""
-
-    --                 next Plain
-
-    --             ("push" : pargs : _ ) -> do
-    --               (fromRef, toRef) <- orThrowUser "can't parse push" (parsePush pargs)
-
-    --               r <- readProcess (setStderr closed $ shell [qc|git rev-parse {pretty $ fromRef}|])
-    --                     <&> headDef "" . LBS8.words . view _2
-    --                     <&> fromStringMay @GitHash . LBS8.unpack
-
-    --               let val = const r =<< fromRef
-
-    --               atomically $ writeTQueue tpush (toRef, val)
-
-    --               sendLine [qc|ok {pretty toRef}|]
-    --               next Push
-
-    --             _ -> next Plain
-
-    --           pure ()
-
-  -- `finally` liftIO do
-    -- hPutStrLn stdout "" >> hFlush stdout
-    -- -- notice $ red "BYE"
-    -- hPutStrLn stderr ""
-
-

hbs2-git3/lib/HBS2/Git3/Export.hs

@@ -30,6 +30,7 @@ import Data.HashPSQ qualified as HPSQ
 import Data.HashPSQ (HashPSQ)
 import Data.HashSet (HashSet)
 import Data.HashSet qualified as HS
+import Data.HashMap.Strict qualified as HM
 import Data.List qualified as L
 import Data.List (sortBy)
 import Data.List.Split (chunksOf)
@@ -53,19 +54,35 @@ data ECC =
   | ECCWrite Int FilePath Handle Result
   | ECCFinalize Int Bool FilePath Handle Result
 
+
+export :: forall m . HBS2GitPerks m => Git3 m ()
+export = do
+  none
+
 exportEntries :: forall m . (HBS2GitPerks m) => Id -> MakeDictM C (Git3 m) ()
 exportEntries prefix = do
     entry $ bindMatch (prefix <> "export") $ nil_ $ \syn -> lift $ connectedDo do
-      let (opts, argz) = splitOpts [("--dry",0),("--ref",1)] syn
+      let (opts, argz) = splitOpts [("--dry",0),("--ref",1),("--set",2),("--del",1)] syn
 
       let dry = or [ True  | ListVal [StringLike "--dry"] <- opts ]
 
       let hd = headDef "HEAD" [ x | StringLike x <- argz]
       h <- gitRevParseThrow hd
 
-      let refs = [ gitNormaliseRef (fromString x)
-                 | ListVal [StringLike "--ref", StringLike x] <- opts
-                 ]
+      refs' <- S.toList_ $ for opts $ \case
+                ListVal [StringLike "--ref", StringLike x] -> do
+                  S.yield (gitNormaliseRef (fromString x), h)
+
+                ListVal [StringLike "--set", StringLike x, StringLike what] -> do
+                  y <- gitRevParseThrow what
+                  S.yield $ (gitNormaliseRef (fromString x), y)
+
+                ListVal [StringLike "--del", StringLike x] -> do
+                  S.yield $ (gitNormaliseRef (fromString x), GitHash (BS.replicate 20 0))
+
+                _ -> none
+
+      let refs = HM.toList $ HM.fromList refs'
 
       tn <- getNumCapabilities
 
@@ -197,7 +214,7 @@ exportEntries prefix = do
                   writeTBQueue sourceQ (Just e)
 
               when (commit == lastCommit) do
-                writeRefSection sourceQ commit refs
+                writeRefSectionSome sourceQ refs
 
         t0 <- getTimeCoarse
         ContT $ withAsync $ do
@@ -245,7 +262,7 @@ exportEntries prefix = do
 
         when (exported == 0 && not (L.null refs)) do
           notice $ "no new segments, but refs" <+> pretty lastCommit
-          writeRefSection sourceQ lastCommit refs
+          writeRefSectionSome sourceQ refs
           atomically $ modifyTVar _exported succ
 
         atomically do
@@ -264,25 +281,43 @@ exportEntries prefix = do
      touch path
      liftIO (IO.appendFile path (show $ e <> line))
 
-   writeRefSection sourceQ commit refs = do
+   writeRefSectionSome :: forall m1 . MonadIO m1 => TBQueue (Maybe LBS.ByteString) -> [(GitRef, GitHash)] -> m1 ()
+   writeRefSectionSome sourceQ refsAndCommits = do
+     ts <- liftIO $ getPOSIXTime <&> round
 
-      ts <- liftIO $ getPOSIXTime <&> round
+     let brefs = [ LBS8.pack (show $ pretty ts <+> pretty commit <+> pretty ref)
+                 | (ref, commit) <- refsAndCommits
+                 ] & LBS8.unlines
 
-      let brefs = [ LBS8.pack (show $ pretty ts <+> pretty commit <+> pretty x)
-                  | x <- refs
-                  ] & LBS8.unlines
+     let sha1 = gitHashBlobPure brefs
 
-      let sha1 = gitHashBlobPure brefs
+     let e = [ Builder.byteString (coerce sha1)
+             , Builder.char8 'R'
+             , Builder.lazyByteString brefs
+             ] & Builder.toLazyByteString . mconcat
 
-      -- debug $ green "THIS IS THE LAST COMMIT BLOCK" <+> pretty commit <+> "ADDING REF INFO" <+> pretty sha1
+     atomically do
+          writeTBQueue sourceQ (Just e)
 
-      let e = [ Builder.byteString (coerce sha1)
-              , Builder.char8 'R'
-              , Builder.lazyByteString brefs
-              ] & Builder.toLazyByteString . mconcat
+   -- writeRefSection sourceQ commit refs = do
 
-      atomically do
-        writeTBQueue sourceQ (Just e)
+   --    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)
 
    segmentWriter env bytes_ sourceQ hbs2Q = flip runReaderT env do
      maxW <- getPackedSegmetSize