From 781c9ded4b36f725613afcb5361b7bb5edfd40da Mon Sep 17 00:00:00 2001
From: Dmitry Zuikov <dzuikov@gmail.com>
Date: Sat, 15 Jul 2023 14:55:26 +0300
Subject: [PATCH] very basic acls work

---
 hbs2-core/lib/HBS2/Net/Proto/RefChan.hs | 21 +++++++++++++++++----
 hbs2-peer/app/CLI/RefChan.hs            |  2 +-
 hbs2-peer/app/PeerMain.hs               | 17 ++++++++++++-----
 3 files changed, 30 insertions(+), 10 deletions(-)

diff --git a/hbs2-core/lib/HBS2/Net/Proto/RefChan.hs b/hbs2-core/lib/HBS2/Net/Proto/RefChan.hs
index 23c12317..b9f4f6e1 100644
--- a/hbs2-core/lib/HBS2/Net/Proto/RefChan.hs
+++ b/hbs2-core/lib/HBS2/Net/Proto/RefChan.hs
@@ -224,8 +224,7 @@ refChanUpdateProto self adapter msg = do
 
   void $ runMaybeT do
 
-    guard auth
-
+    guard (auth || self)
 
     case msg of
      Propose chan box -> do
@@ -259,7 +258,10 @@ refChanUpdateProto self adapter msg = do
        deferred proto do
 
         -- проверили подпись пира
-        (peerKey, (ProposeTran headRef bs)) <- MaybeT $ pure $ unboxSignedBox0 box
+        (peerKey, ProposeTran headRef abox) <- MaybeT $ pure $ unboxSignedBox0 box
+
+        -- проверили подпись автора
+        (authorKey, bs) <- MaybeT $ pure $ unboxSignedBox0 abox
 
         -- итак, сначала достаём голову. как мы достаём голову?
         h <- MaybeT $ liftIO $ getRef sto (RefChanHeadKey @s chan)
@@ -274,7 +276,18 @@ refChanUpdateProto self adapter msg = do
         -- FIXME: cache-this
         hdblob <- MaybeT $ readBlobFromTree ( getBlock sto ) (HashRef h)
 
-        debug "OMG! OMG! We've got a transaction!!"
+        (_, headBlock) <- MaybeT $ pure $ unboxSignedBox @(RefChanHeadBlock e) @e hdblob
+
+        debug $ "OMG! Got trans" <+> pretty (AsBase58 peerKey)  <+> pretty (AsBase58 authorKey)
+
+        let pips = view refChanHeadPeers headBlock & fmap fst
+        let aus  = view refChanHeadAuthors headBlock
+
+        guard ( peerKey `elem` pips )
+
+        guard ( authorKey `elem` aus )
+
+        debug $ "OMG!!! TRANS AUTHORIZED" <+> pretty (AsBase58 peerKey)  <+> pretty (AsBase58 authorKey)
 
         pure ()
 
diff --git a/hbs2-peer/app/CLI/RefChan.hs b/hbs2-peer/app/CLI/RefChan.hs
index 81dca1ce..023052f9 100644
--- a/hbs2-peer/app/CLI/RefChan.hs
+++ b/hbs2-peer/app/CLI/RefChan.hs
@@ -110,7 +110,7 @@ pRefChanPropose = do
 
     lbs <- maybe1 fn LBS.getContents LBS.readFile
 
-    let box = makeSignedBox @L4Proto @ByteString (view peerSignPk creds) (view peerSignSk creds) lbs
+    let box = makeSignedBox @L4Proto @BS.ByteString (view peerSignPk creds) (view peerSignSk creds) (LBS.toStrict lbs)
 
     if dry then do
       LBS.putStr (serialise box)
diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs
index 944a0196..93bb6675 100644
--- a/hbs2-peer/app/PeerMain.hs
+++ b/hbs2-peer/app/PeerMain.hs
@@ -963,8 +963,7 @@ runPeer opts = U.handle (\e -> myException e
   let reflogFetchAction puk = do
         trace "reflogFetchAction"
         void $ liftIO $ async $ withPeerM penv $ do
-          forKnownPeers @e $ \p _ -> do
-            request p (RefLogRequest @e puk)
+          broadCastMessage (RefLogRequest @e puk)
 
   let reflogGetAction puk = do
         trace $ "reflogGetAction" <+> pretty (AsBase58 puk)
@@ -1011,10 +1010,18 @@ runPeer opts = U.handle (\e -> myException e
   let refChanProposeAction (puk, lbs) = do
         trace "reChanProposeAction"
         void $ liftIO $ async $ withPeerM penv $ do
-          let mbox = deserialiseOrFail lbs & either (const Nothing) Just
-          maybe1 mbox (err "proposal: Can't read SignedBox") $ \box -> do
-            proposed <- makeProposeTran @e pc puk box
+          me <- ownPeer @e
+          runMaybeT do
+            box <- MaybeT $ pure $ deserialiseOrFail lbs & either (const Nothing) Just
+            proposed <- MaybeT $ makeProposeTran @e pc puk box
+
             debug $ "PROPOSAL:" <+> pretty (LBS.length (serialise proposed))
+            lift $ broadCastMessage (Propose @e puk proposed)
+
+            -- FIXME: remove-this-debug-stuff
+            --   или оставить? нода будет сама себе
+            --   консенсус слать тогда. может, и оставить
+            lift $ runResponseM me $ refChanUpdateProto @e True refChanHeadAdapter (Propose @e puk proposed)
 
   let arpc = RpcAdapter pokeAction
                         dieAction