publishing repo index entry notification

hbs2-git/git-hbs2/Main.hs

@@ -11,14 +11,22 @@ import HBS2.Git.Data.RefLog
 import HBS2.Git.Local.CLI qualified as Git
 import HBS2.Git.Data.Tx.Git qualified as TX
 import HBS2.Git.Data.Tx.Git (RepoHead(..))
+import HBS2.Git.Data.Tx.Index
 import HBS2.Git.Data.LWWBlock
+import HBS2.Peer.Proto.RefChan.Types
 import HBS2.Git.Data.GK
 
+import HBS2.KeyMan.Keys.Direct
 import HBS2.Storage.Operations.ByteString
 
+import Data.HashSet qualified as HS
+import Data.Maybe
+import Data.Coerce
 import Options.Applicative as O
 import Data.ByteString.Lazy qualified as LBS
 
+import Streaming.Prelude qualified as S
+
 import System.Exit
 
 globalOptions :: Parser [GitOption]
@@ -215,10 +223,48 @@ pTrack = hsubparser (  command "send-repo-notify" (info pSendRepoNotify (progDes
 
 pSendRepoNotify :: GitPerks m => Parser (GitCLI m ())
 pSendRepoNotify = do
+  dry <- flag False True (short 'n' <> long "dry" <> help "don't post anything")
   notifyChan <- argument pRefChanId (metavar "CHANNEL-KEY")
   pure do
-    notice "wip"
+    notice $ "test send-repo-notify" <+> pretty (AsBase58 notifyChan)
-    pure ()
+    -- откуда мы берём ссылку, которую постим? их много.
+
+    lwws <- withState selectAllLww
+
+    -- берём те, для которых у нас есть приватный ключ (наши)
+    creds <- catMaybes <$> runKeymanClient do
+                for lwws $ \(lwref,_,_) -> do
+                  loadCredentials (coerce @_ @(PubKey 'Sign 'HBS2Basic) lwref)
+
+    sto <- getStorage
+    rchanAPI <- asks _refChanAPI
+
+    hd <- getRefChanHead @L4Proto sto (RefChanHeadKey notifyChan)
+             `orDie` "refchan head not found"
+
+    let notifiers = view refChanHeadNotifiers hd & HS.toList
+
+    -- откуда мы берём ключ, которым подписываем?
+    -- ищем тоже в кеймане, берём тот, у которого выше weight
+    foundKey <- runKeymanClient (
+                  S.head_ do
+                     for notifiers $ \n -> do
+                      lift (loadCredentials n) >>= maybe none S.yield
+                      ) `orDie` "signing key not found"
+
+    for_ creds $ \c -> do
+      let lww = LWWRefKey @'HBS2Basic (view peerSignPk c)
+      let lwwSk = view peerSignSk c
+      let tx = makeNotificationTx @'HBS2Basic (NotifyCredentials foundKey) lww lwwSk Nothing
+
+      notice $ "about to publish lwwref index entry:"
+        <+> pretty (AsBase58 $ view peerSignPk c)
+
+      -- как мы постим ссылку
+      unless dry do
+        void $ callService @RpcRefChanNotify rchanAPI (notifyChan, tx)
+
+    -- кто парсит ссылку и помещает в рефчан
 
 main :: IO ()
 main = do

hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/App.hs

@@ -136,11 +136,13 @@ runGitCLI o m = do
 
     peerAPI    <- makeServiceCaller @PeerAPI (fromString soname)
     refLogAPI  <- makeServiceCaller @RefLogAPI (fromString soname)
+    refChanAPI <- makeServiceCaller @RefChanAPI (fromString soname)
     storageAPI <- makeServiceCaller @StorageAPI (fromString soname)
     lwwAPI     <- makeServiceCaller @LWWRefAPI (fromString soname)
 
     let endpoints = [ Endpoint @UNIX  peerAPI
                     , Endpoint @UNIX  refLogAPI
+                    , Endpoint @UNIX  refChanAPI
                     , Endpoint @UNIX  lwwAPI
                     , Endpoint @UNIX  storageAPI
                     ]
@@ -160,7 +162,7 @@ runGitCLI o m = do
 
     progress <- ContT $ withAsync (drawProgress q)
 
-    env <- lift $ newGitEnv ip o git cpath conf peerAPI refLogAPI lwwAPI storageAPI
+    env <- lift $ newGitEnv ip o git cpath conf peerAPI refLogAPI refChanAPI lwwAPI storageAPI
     lift $ runReaderT setupLogging env
     lift $ withGitEnv env (evolveDB >> m)
       `finally` do

hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/App/Types.hs

@@ -85,11 +85,12 @@ newGitEnv :: GitPerks m
           -> Config
           -> ServiceCaller PeerAPI UNIX
           -> ServiceCaller RefLogAPI UNIX
+          -> ServiceCaller RefChanAPI UNIX
           -> ServiceCaller LWWRefAPI UNIX
           -> ServiceCaller StorageAPI UNIX
           -> m GitEnv
 
-newGitEnv p opts path cpath conf peer reflog lww sto = do
+newGitEnv p opts path cpath conf peer reflog rchan lww sto = do
   let dbfile  = cpath </> "state.db"
   let dOpt = dbPipeOptsDef { dbLogger = \x -> debug ("state:" <+> pretty x) }
   db <- newDBPipeEnv dOpt dbfile
@@ -105,6 +106,7 @@ newGitEnv p opts path cpath conf peer reflog lww sto = do
            conf
            peer
            reflog
+           rchan
            lww
            (AnyStorage (StorageClient sto))
            db

hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/App/Types/GitEnv.hs

@@ -42,6 +42,7 @@ data GitEnv =
   , _config          :: Config
   , _peerAPI         :: ServiceCaller PeerAPI UNIX
   , _refLogAPI       :: ServiceCaller RefLogAPI UNIX
+  , _refChanAPI      :: ServiceCaller RefChanAPI UNIX
   , _lwwRefAPI       :: ServiceCaller LWWRefAPI UNIX
   , _storage         :: AnyStorage -- ServiceCaller StorageAPI UNIX
   , _db              :: DBPipeEnv

hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/Tx/Index.hs

@@ -44,28 +44,22 @@ instance ForGitIndex s => Serialise (GitRepoAnnounceData s)
 instance ForGitIndex s => Serialise (GitRepoAnnounce s)
 
 
-data NotifyCredentials s =
+newtype NotifyCredentials s = NotifyCredentials (PeerCredentials s)
-  NotifyCredentials
-  { notifyPk :: PubKey 'Sign s
-  , notifySk :: PrivKey 'Sign s
-  }
 
 -- | makes notification tx
 -- | it is signed by lwwref private key in order to proove authorship
 -- | and signed with published notification private key in order
 -- | to publish tx via rpc
-makeNotificationTx :: forall  s m . (Monad m, ForGitIndex s)
+makeNotificationTx :: forall  s . (ForGitIndex s)
                    => NotifyCredentials s
                    -> LWWRefKey s
-                   -> ( PubKey 'Sign s -> m (Maybe (PrivKey 'Sign s) ) )
+                   -> PrivKey 'Sign s
                    -> Maybe (RepoForkInfo s)
-                   -> m (Maybe (SignedBox ByteString s))
+                   -> SignedBox ByteString s
-makeNotificationTx ncred lww klook forkInfo = runMaybeT do
+makeNotificationTx ncred lww lwsk forkInfo = do
+  let creds = coerce ncred :: PeerCredentials s
   let annData = GitRepoAnnounceData @s lww forkInfo
   let lwpk = coerce lww :: PubKey 'Sign s
-  lwsk <- MaybeT $ klook lwpk
   let repoAnn = makeSignedBox @s lwpk lwsk (LBS.toStrict $ serialise annData)
-  pure $ makeSignedBox @s (notifyPk ncred) (notifySk ncred) (LBS.toStrict $ serialise repoAnn)
+  makeSignedBox @s (view peerSignPk creds) (view peerSignSk creds) (LBS.toStrict $ serialise repoAnn)
-
-
 

hbs2-keyman/src/HBS2/KeyMan/Keys/Direct.hs

@@ -59,8 +59,11 @@ loadCredentials k = KeyManClient do
 
   fnames <- select @(Only FilePath) [qc|
     select f.file
-    from keytype t join keyfile f on t.key = f.key
+    from keytype t
+            join keyfile f on t.key = f.key
+       left join keyweight w on w.key = f.key
     where t.key = ? and t.type = 'sign'
+    order by w.weight desc nulls last
     limit 1 |]  (Only (SomePubKey k))
 
   runMaybeT do

hbs2-peer/app/CLI/RefChan.hs

@@ -48,7 +48,7 @@ import UnliftIO
 
 
 pRefChan :: Parser (IO ())
-pRefChan = hsubparser (   command "head" (info pRefChanHead       (progDesc "head commands" ))
+pRefChan = hsubparser (   command "head"    (info pRefChanHead       (progDesc "head commands" ))
                        <> command "propose" (info pRefChanPropose (progDesc "post propose transaction"))
                        <> command "notify"  (info pRefChanNotify  (progDesc "post notify message"))
                        <> command "fetch"   (info pRefChanFetch   (progDesc "fetch and sync refchan value"))

hbs2-peer/lib/HBS2/Peer/Proto/RefChan/Types.hs

@@ -418,13 +418,10 @@ getActualRefChanHead key = do
 
     case mbHead of
       Just hd -> do
-        debug "HEAD DISCOVERED"
         pure hd
 
       Nothing -> do
-        headblk <- MaybeT $ getRefChanHead sto key
+        MaybeT $ getRefChanHead sto key
-        debug "HEAD FOUND"
-        pure headblk
 
 getRefChanHead :: forall e s m . ( MonadIO m
                                  , s ~ Encryption e

nix/peer/flake.lock

@@ -329,16 +329,17 @@
         "suckless-conf": "suckless-conf_2"
       },
       "locked": {
-        "lastModified": 1711190148,
+        "lastModified": 1713159635,
-        "narHash": "sha256-XnvjD8yvSrSTMmsy3fE7chVg1oDBamMaWkEZ0lJ8sHU=",
+        "narHash": "sha256-iXf8qcJxePLM65E0fsAK2kj69/YIyQdNMrZ5yULzVGc=",
-        "ref": "dev-0.24.2",
+        "ref": "hbs2-git-index",
-        "rev": "37618a32bb0ae5bfa8b8380c6537638b1f5d412d",
+        "rev": "2289845078ba839bade83a1daf5234435e6e631e",
-        "revCount": 983,
+        "revCount": 997,
         "type": "git",
         "url": "http://git.hbs2/BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP"
       },
       "original": {
-        "ref": "dev-0.24.2",
+        "ref": "hbs2-git-index",
+        "rev": "2289845078ba839bade83a1daf5234435e6e631e",
         "type": "git",
         "url": "http://git.hbs2/BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP"
       }