wip-2

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))
+

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

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

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)