wip, emitting accept message

hbs2-core/lib/HBS2/Net/Proto/RefChan.hs

@@ -1,6 +1,7 @@
 {-# Language UndecidableInstances #-}
 {-# Language AllowAmbiguousTypes #-}
 {-# Language TemplateHaskell #-}
+{-# Language FunctionalDependencies #-}
 module HBS2.Net.Proto.RefChan where
 
 import HBS2.Prelude.Plated
@@ -117,7 +118,12 @@ instance ForRefChans e => Serialise (RefChanHead e)
 data ProposeTran e = ProposeTran HashRef (SignedBox ByteString e) -- произвольная бинарная транзакция,
                      deriving stock (Generic)                     -- подписанная ключом **АВТОРА**, который её рассылает
 
+
+data AcceptTran e = AcceptTran HashRef HashRef -- ссылка на (ProposTran e)
+                    deriving stock (Generic)
+
 instance ForRefChans e => Serialise (ProposeTran e)
+instance ForRefChans e => Serialise (AcceptTran e)
 
 -- TODO: find-out-sure-transaction-size
 --   транзакция должна быть маленькая!
@@ -126,6 +132,8 @@ instance ForRefChans e => Serialise (ProposeTran e)
 --   надо посмотреть. байт, небось, 400
 data RefChanUpdate e =
     Propose (RefChanId e) (SignedBox (ProposeTran e) e) -- подписано ключом пира
+  | Accept  (RefChanId e) (SignedBox (AcceptTran e) e)  -- подписано ключом пира
+
   deriving stock (Generic)
 
 instance ForRefChans e => Serialise (RefChanUpdate e)
@@ -145,9 +153,6 @@ deriving stock instance ForRefChans L4Proto
 instance Expires (SessionKey L4Proto (RefChanHeadBlock L4Proto)) where
   expiresIn = const (Just defCookieTimeoutSec)
 
--- data RefChanNotifyMsg e =
---   Notify (SignedBox ByteString e)
---   deriving stock (Generic)
 
 data RefChanHeadAdapter e m =
   RefChanHeadAdapter
@@ -232,11 +237,12 @@ refChanUpdateProto :: forall e s m . ( MonadIO m
                                      , s ~ Encryption e
                                      )
                    => Bool
+                   -> PeerCredentials s
                    -> RefChanHeadAdapter e m
                    -> RefChanUpdate e
                    -> m ()
 
-refChanUpdateProto self adapter msg = do
+refChanUpdateProto self pc adapter msg = do
   -- авторизовать пира
   peer <- thatPeer proto
 
@@ -248,6 +254,12 @@ refChanUpdateProto self adapter msg = do
 
     guard (auth || self)
 
+    -- TODO: process-each-message-only-once
+    -- где-то тут мы разбираемся, что такое сообщеине
+    -- уже отправляли и больше одного раза не реагируем
+
+    guard =<< lift (refChanHeadSubscribed adapter undefined)
+
     case msg of
      Propose chan box -> do
        guard =<< lift (refChanHeadSubscribed adapter chan)
@@ -283,7 +295,7 @@ refChanUpdateProto self adapter msg = do
         (peerKey, ProposeTran headRef abox) <- MaybeT $ pure $ unboxSignedBox0 box
 
         -- проверили подпись автора
-        (authorKey, bs) <- MaybeT $ pure $ unboxSignedBox0 abox
+        (authorKey, _) <- MaybeT $ pure $ unboxSignedBox0 abox
 
         -- итак, сначала достаём голову. как мы достаём голову?
 
@@ -309,17 +321,30 @@ refChanUpdateProto self adapter msg = do
 
         debug $ "OMG!!! TRANS AUTHORIZED" <+> pretty (AsBase58 peerKey)  <+> pretty (AsBase58 authorKey)
 
-        -- ок, теперь мы можем:
+        -- если не смогли сохранить транзу, то и Accept разослать
-        --  gossip propose если еще нет
+        -- не сможем
+        hash <- MaybeT $ liftIO $ putBlock sto (serialise msg)
 
         lift $ gossip msg
 
-        --  генерируем Accept и рассылаем всем
+        let tran = AcceptTran headRef (HashRef hash)
-        --   рассылаем ли себе?
-        --   как сюда просунуть ручку Gossip ?
 
-        pure ()
+        let pk = view peerSignPk pc
+        let sk = view peerSignSk pc
 
+        --  генерируем Accept
+        let accept = Accept chan (makeSignedBox @e pk sk tran)
+
+        -- и рассылаем всем
+        debug "GOSSIP ACCEPT TRANSACTION"
+        lift $ gossip accept
+
+        --  рассылаем ли себе? что бы был хоть один accept
+        lift $ refChanUpdateProto True pc adapter accept
+
+     Accept chan box -> do
+       guard =<< lift (refChanHeadSubscribed adapter chan)
+       debug "RefChanUpdate/Propose"
 
   where
     proto = Proxy @(RefChanUpdate e)

hbs2-peer/app/PeerMain.hs

@@ -891,7 +891,7 @@ runPeer opts = U.handle (\e -> myException e
                     , makeResponse (refLogRequestProto reflogReqAdapter)
                     , makeResponse (peerMetaProto (mkPeerMeta conf))
                     , makeResponse (refChanHeadProto False refChanHeadAdapter)
-                    , makeResponse (refChanUpdateProto False refChanHeadAdapter)
+                    , makeResponse (refChanUpdateProto False pc refChanHeadAdapter)
                     ]
 
               void $ liftIO $ waitAnyCancel workers
@@ -1022,7 +1022,7 @@ runPeer opts = U.handle (\e -> myException e
             -- FIXME: remove-this-debug-stuff
             --   или оставить? нода будет сама себе
             --   консенсус слать тогда. может, и оставить
-            lift $ runResponseM me $ refChanUpdateProto @e True refChanHeadAdapter (Propose @e puk proposed)
+            lift $ runResponseM me $ refChanUpdateProto @e True pc refChanHeadAdapter (Propose @e puk proposed)
 
   let arpc = RpcAdapter pokeAction
                         dieAction