From 478f43a52857b7d70de793d446fa890109c8a46e Mon Sep 17 00:00:00 2001 From: voidlizard Date: Fri, 31 Jan 2025 13:40:21 +0300 Subject: [PATCH] wip-2 --- hbs2-git3/lib/HBS2/Git3/Import.hs | 62 ++++++++++++++++++++++++++- hbs2-git3/lib/HBS2/Git3/Repo/Tools.hs | 4 +- hbs2-git3/lib/HBS2/Git3/Run.hs | 30 +++++++++++++ hbs2-peer/app/PeerMain.hs | 6 ++- 4 files changed, 98 insertions(+), 4 deletions(-) diff --git a/hbs2-git3/lib/HBS2/Git3/Import.hs b/hbs2-git3/lib/HBS2/Git3/Import.hs index 661627d5..132aece0 100644 --- a/hbs2-git3/lib/HBS2/Git3/Import.hs +++ b/hbs2-git3/lib/HBS2/Git3/Import.hs @@ -7,13 +7,16 @@ import HBS2.Git3.Prelude import HBS2.Git3.State import HBS2.Git3.Git import HBS2.Git3.Git.Pack +import HBS2.Git3.Config.Local -import HBS2.Data.Detect (ScanLevel(..), deepScan) +import HBS2.Data.Detect (readLogThrow,deepScan,ScanLevel(..)) import HBS2.Storage.Operations.Missed import HBS2.CLI.Run.Internal.Merkle (getTreeContents) import HBS2.Data.Log.Structured import HBS2.System.Dir +import Data.Config.Suckless.Almost.RPC +import Data.Config.Suckless.Script import Codec.Compression.Zlib qualified as Zlib import Data.ByteString.Lazy.Char8 qualified as LBS8 @@ -22,11 +25,15 @@ import Data.ByteString qualified as BS import Data.HashSet (HashSet) import Data.HashSet qualified as HS import Data.Maybe +import Data.Either import Data.List qualified as L import Network.ByteOrder qualified as N import System.IO.Temp as Temp import Text.InterpolatedString.Perl6 (qc) import UnliftIO.IO.File qualified as UIO +import System.IO (hPrint) + +import Streaming.Prelude qualified as S data ImportException = ImportInvalidSegment HashRef @@ -165,6 +172,9 @@ importGitRefLog = withStateDo $ ask >>= \case ImportStart -> do rvl <- readTVarIO gitRefLogVal + + importGroupKeys + prev <- importedCheckpoint if | isNothing prev -> again $ ImportWIP 0 prev @@ -235,3 +245,53 @@ importGitRefLog = withStateDo $ ask >>= \case Left e -> throwIO e + +groupKeysFile :: MonadIO m => Git3 m FilePath +groupKeysFile = getStatePathM <&> ( "groupkeys") + +readGroupKeyFile :: MonadIO m => Git3 m (Maybe HashRef) +readGroupKeyFile = do + file <- groupKeysFile + debug $ "readGroupKeyFile" <+> pretty file + liftIO (try @_ @IOError (readFile file)) + <&> fromRight mempty + <&> parseTop + <&> fromRight mempty + <&> \x -> headMay [ w | ListVal [HashLike w] <- x ] + +importGroupKeys :: forall m . ( HBS2GitPerks m + ) + => Git3 m () + +importGroupKeys = do + + debug $ "importGroupKeys" + sto <- getStorage + + already <- readGroupKeyFile + + LWWRef{..} <- getRepoRefMaybe >>= orThrow GitRepoRefNotSet + rhead <- readLogThrow (getBlock sto) lwwValue + let keyTree' = headMay (tailSafe rhead) + + when (keyTree' /= already) do + + ops <- S.toList_ $ for_ keyTree' $ \tree -> do + keyhashes <- readLogThrow (getBlock sto) tree + for_ keyhashes $ \h -> do + S.yield $ mkForm @C "gk:track" [mkSym (show $ pretty h)] + + -- FIXME: check-added-keys + unless (null ops) do + _ <- callProc "hbs2-keyman" ["run","stdin"] ops + updateGroupKeys keyTree' + + where + + updateGroupKeys keyTree' = do + file <- groupKeysFile + void $ runMaybeT do + val <- keyTree' & toMPlus + liftIO $ UIO.withBinaryFileAtomic file WriteMode $ \fh -> do + hPrint fh $ pretty (mkSym @C (show $ pretty val)) + diff --git a/hbs2-git3/lib/HBS2/Git3/Repo/Tools.hs b/hbs2-git3/lib/HBS2/Git3/Repo/Tools.hs index 505aae1d..69d2b25d 100644 --- a/hbs2-git3/lib/HBS2/Git3/Repo/Tools.hs +++ b/hbs2-git3/lib/HBS2/Git3/Repo/Tools.hs @@ -163,8 +163,10 @@ updateGroupKey repo new = do let missed = HM.keysSet $ recipients gkNew `HM.difference` recipients gk + let updGk (g1,m1) (_,m2) = (g1,m1<>m2) + unless (HS.null missed) do - atomically $ modifyTVar r (HM.insert gkId (gk,missed)) + atomically $ modifyTVar r (HM.insertWith updGk gkId (gk,missed)) none keys <- readTVarIO r <&> HM.elems diff --git a/hbs2-git3/lib/HBS2/Git3/Run.hs b/hbs2-git3/lib/HBS2/Git3/Run.hs index d33ed1a8..2fdc96ce 100644 --- a/hbs2-git3/lib/HBS2/Git3/Run.hs +++ b/hbs2-git3/lib/HBS2/Git3/Run.hs @@ -389,6 +389,7 @@ compression ; prints compression level entry $ bindMatch "reflog:refs" $ nil_ $ \syn -> lift $ connectedDo do + resolveRepoKeyThrow syn >>= setGitRepoKey waitRepo Nothing =<< getGitRepoKeyThrow rrefs <- importedRefs @@ -461,6 +462,24 @@ compression ; prints compression level _ -> throwIO $ BadFormException @C nil + entry $ bindMatch "repo:gk:add:extra:keys" $ nil_ $ \case + ( x@(StringLike{}) : keyHashes ) -> lift $ connectedDo do + repo <- resolveRepoKeyThrow [x] + setGitRepoKey repo + waitRepo (Just 10) =<< getGitRepoKeyThrow + + sto <- getStorage + RepoManifest mf <- getRepoManifest + + hh <- for [ x | HashLike x <- keyHashes ] $ \k -> do + _ <- loadGroupKeyMaybe @HBS2Basic sto k >>= orThrow (GitRepoNoGroupKey k) + pure k + + updateRepoHead repo mf hh + + _ -> throwIO $ BadFormException @C nil + + -- FIXME: maybe-add-default-remote entry $ bindMatch "repo:head" $ nil_ $ \syn -> lift $ connectedDo $ do resolveRepoKeyThrow syn >>= setGitRepoKey @@ -468,6 +487,17 @@ compression ; prints compression level lww <- getRepoRefMaybe liftIO $ print $ pretty lww + entry $ bindMatch "repo:gk:journal:import" $ nil_ $ \syn -> lift $ connectedDo $ do + resolveRepoKeyThrow syn >>= setGitRepoKey + waitRepo Nothing =<< getGitRepoKeyThrow + importGroupKeys + + entry $ bindMatch "repo:gk:journal:imported" $ nil_ $ \syn -> lift $ connectedDo $ do + resolveRepoKeyThrow syn >>= setGitRepoKey + waitRepo Nothing =<< getGitRepoKeyThrow + readGroupKeyFile <&> maybe nil (mkSym @C . show . pretty) + >>= liftIO . print . pretty + entry $ bindMatch "repo:gk:journal" $ nil_ $ \syn -> lift $ connectedDo $ do resolveRepoKeyThrow syn >>= setGitRepoKey waitRepo Nothing =<< getGitRepoKeyThrow diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index de02fb69..6cddfc0a 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -1152,7 +1152,7 @@ runPeer opts = respawnOnError opts $ do void $ liftIO $ async $ withPeerM env do - pause @'Seconds 1 + pause @'Seconds 3 debug "sending first peer announce" request localMulticast (PeerAnnounce @e pnonce) @@ -1171,9 +1171,11 @@ runPeer opts = respawnOnError opts $ do flip runContT pure do peerThread "local multicast" $ forever $ do - pause defPeerAnnounceTime -- FIXME: setting! + pips <- getKnownPeers @L4Proto + let w = if null pips then 10 else defPeerAnnounceTime debug "sending local peer announce" request localMulticast (PeerAnnounce @e pnonce) + pause w peerThread "byPassWorker" (byPassWorker byPass)