From 2e0c0fc879b992e062b84ca5aa12376cdf866d52 Mon Sep 17 00:00:00 2001 From: voidlizard Date: Fri, 17 Jan 2025 12:37:42 +0300 Subject: [PATCH] wip --- hbs2-git3/app/GitRemoteHelper.hs | 126 ------------------------------ hbs2-git3/lib/HBS2/Git3/Export.hs | 73 ++++++++++++----- 2 files changed, 54 insertions(+), 145 deletions(-) diff --git a/hbs2-git3/app/GitRemoteHelper.hs b/hbs2-git3/app/GitRemoteHelper.hs index ac2c6489..77d17e83 100644 --- a/hbs2-git3/app/GitRemoteHelper.hs +++ b/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 "" - - diff --git a/hbs2-git3/lib/HBS2/Git3/Export.hs b/hbs2-git3/lib/HBS2/Git3/Export.hs index f6ef3874..2307eecc 100644 --- a/hbs2-git3/lib/HBS2/Git3/Export.hs +++ b/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