wip, refchans

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

@@ -19,6 +19,7 @@ import HBS2.Net.Proto.PeerAnnounce
 import HBS2.Net.Proto.PeerExchange
 import HBS2.Net.Proto.PeerMeta
 import HBS2.Net.Proto.RefLog
+import HBS2.Net.Proto.RefChan
 import HBS2.Prelude
 
 import Data.Functor
@@ -120,6 +121,14 @@ instance HasProtocol L4Proto (PeerMetaProto L4Proto) where
   -- FIXME: real-period
   requestPeriodLim = ReqLimPerMessage 0.25
 
+instance HasProtocol L4Proto (RefChanHead L4Proto) where
+  type instance ProtocolId (RefChanHead L4Proto) = 11001
+  type instance Encoded L4Proto = ByteString
+  decode = either (const Nothing) Just . deserialiseOrFail
+  encode = serialise
+  -- requestPeriodLim = ReqLimPerMessage 600
+
+
 instance Expires (SessionKey L4Proto (BlockInfo L4Proto)) where
   expiresIn _ = Just defCookieTimeoutSec
 

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

@@ -14,122 +14,124 @@ import HBS2.Net.Proto.Peer
 import HBS2.Net.Proto.Sessions
 import HBS2.Data.Types.Refs
 
+import Data.Config.Suckless
+
 -- import HBS2.System.Logger.Simple
 
 -- import Data.Maybe
 -- import Data.Hashable
+import Data.Text qualified as Text
 import Data.ByteString (ByteString)
 -- import Type.Reflection (someTypeRep)
+import Data.Either
+import Data.Maybe
 import Lens.Micro.Platform
--- import Codec.Serialise
+import Codec.Serialise
 
 {- HLINT ignore "Use newtype instead of data" -}
 
+type RefChanId e = PubKey 'Sign (Encryption e)
+type RefChanOwner e = PubKey 'Sign (Encryption e)
+type RefChanAuthor e = PubKey 'Sign (Encryption e)
+
 data SignedBox p e =
   SignedBox (PubKey 'Sign e) ByteString (Signature (Encryption e))
   deriving stock (Generic)
 
+type Weight = Integer
+
 data RefChanHeadBlock e =
-  RefChanHeadBlock
+  RefChanHeadBlockSmall
   { _refChanHeadVersion     :: Integer
   , _refChanHeadQuorum      :: Integer
   , _refChanHeadWaitAccept  :: Integer
-  , _refChanHeadPeers       :: [PubKey 'Sign e]
+  , _refChanHeadPeers       :: [(PubKey 'Sign (Encryption e),Weight)]
-  , _refChanHeadAuthors     :: [PubKey 'Sign e]
+  , _refChanHeadAuthors     :: [PubKey 'Sign (Encryption e)]
   }
   deriving stock (Generic)
 
-makeLenses 'RefChanHeadBlock
+makeLenses 'RefChanHeadBlockSmall
 
+type ForRefChans e = ( Serialise ( PubKey 'Sign (Encryption e))
+                     , Pretty (AsBase58 (PubKey 'Sign (Encryption e)))
+                     , FromStringMaybe (PubKey 'Sign (Encryption e))
+                     )
+
+-- блок головы может быть довольно большой.
+-- поэтому посылаем его, как merkle tree
 newtype RefChanHeadBlockTran e =
   RefChanHeadBlockTran HashRef
   deriving stock (Generic)
 
-type RefChanId e = PubKey 'Sign e
+instance Serialise (RefChanHeadBlockTran e)
+
 
 data RefChanHead e =
     RefChanHead (RefChanId e) (RefChanHeadBlockTran e)
   | RefChanGetHead (RefChanId e)
   deriving stock (Generic)
 
+instance ForRefChans e => Serialise (RefChanHead e)
 
+data RefChanHeadAdapter e m =
+  RefChanHeadAdapter
+  { _refChanHeadOnHead :: RefChanHeadBlockTran e -> m ()
+  }
 
 refChanHeadProto :: forall e s m . ( MonadIO m
-                                    , Request e (RefChanHead e) m
+                                   , Request e (RefChanHead e) m
-                                    , Response e (RefChanHead e) m
+                                   , Response e (RefChanHead e) m
-                                    , IsPeerAddr e m
+                                   , IsPeerAddr e m
-                                    , Pretty (Peer e)
+                                   , Pretty (Peer e)
-                                    , Sessions e (KnownPeer e) m
+                                   , Sessions e (KnownPeer e) m
-                                    , Signatures s
+                                   , Signatures s
-                                    , Pretty (AsBase58 (PubKey 'Sign s))
+                                   , Pretty (AsBase58 (PubKey 'Sign s))
-                                    , s ~ Encryption e
+                                   , s ~ Encryption e
-                                    )
+                                   )
-                  => RefChanHead e -> m ()
+                  => RefChanHeadAdapter e m
-
+                  -> RefChanHead e
-refChanHeadProto _ = pure ()
+                  -> m ()
-
-
--- type RefChanAuthor e = PubKey 'Sign (Encryption e)
--- type RefChan e = PubKey 'Sign (Encryption e)
-
--- type ForRefChan e = ( Serialise (RefChan e)
---                     , Serialise (Signature (Encryption e))
---                     )
-
--- data RefChanACL e =
---   RefChanACLImmediate [RefChanAuthor e] -- ^ authorized authors
---   deriving stock (Generic)
-
--- instance ForRefChan e => Serialise (RefChanACL e)
-
--- data RefChanHeadBlock e =
---   RefChanHeadBlock
---   { _refChanHeadPrev    :: Maybe HashRef
---   , _refChanHeadVersion :: Integer
---   , _refChanHeadHistory :: Maybe HashRef
---   , _refChanHeadACL     :: RefChanACL e
---   }
---   deriving stock (Generic)
-
--- makeLenses ''RefChanHeadBlock
-
--- instance ForRefChan e => Serialise (RefChanHeadBlock e)
-
--- data RefChanMsgEnvelope e =
---   RefChanMessage
---   { _refChanMsgChan    :: RefChan e
---   , _refChanMsgAuthor  :: RefChanAuthor e
---   , _refChanMsgData    :: ByteString
---   , _refChanMsgSign    :: Signature (Encryption e)
---   }
---   deriving stock (Generic)
-
--- makeLenses ''RefChanMsgEnvelope
-
--- instance ForRefChan e => Serialise (RefChanMsgEnvelope e)
-
--- newtype RefChanHeadMsg e =
---   RefChanHeadMsg HashRef
---   deriving stock Generic
-
--- instance Serialise (RefChanHeadMsg e)
-
--- data RefChanHead e =
---     RefChanGetHead (RefChanMsgEnvelope e)
---   | RefChanHead    (RefChanMsgEnvelope e)
---   deriving stock (Generic)
-
--- instance ForRefChan e => Serialise (RefChanHead e)
-
-
-
-
-
-
 
+refChanHeadProto adapter msg = do
+  -- авторизовать пира
+
+  case msg of
+    RefChanHead pkt _ -> do
+      pure ()
+
+    RefChanGetHead _ -> do
+      -- прочитать ссылку
+      -- послать хэш головы
+      pure ()
 
 
+instance ForRefChans e => FromStringMaybe (RefChanHeadBlock e) where
+  fromStringMay str = RefChanHeadBlockSmall <$> version
+                                          <*> quorum
+                                          <*> wait
+                                          <*> pure peers
+                                          <*> pure authors
+    where
+      parsed = parseTop str & fromRight mempty
+      version = lastMay [ n | (ListVal [SymbolVal "version", LitIntVal n] ) <- parsed ]
+      quorum  = lastMay [ n | (ListVal [SymbolVal "quorum", LitIntVal n] ) <- parsed ]
+      wait    = lastMay [ n | (ListVal [SymbolVal "wait", LitIntVal n] ) <- parsed ]
+      peers   = catMaybes [ (,) <$> fromStringMay (Text.unpack s) <*> pure w | (ListVal [SymbolVal "peer", LitStrVal s, LitIntVal w] ) <- parsed  ]
+      authors = catMaybes [ fromStringMay (Text.unpack s) | (ListVal [SymbolVal "author", LitStrVal s] ) <- parsed  ]
 
+instance ForRefChans e => Pretty (RefChanHeadBlock e) where
+  pretty blk = parens ("version" <+> pretty (view refChanHeadVersion blk)) <> line
+               <>
+               parens ("quorum" <+> pretty (view refChanHeadQuorum blk)) <> line
+               <>
+               parens ("wait" <+> pretty (view refChanHeadWaitAccept blk)) <> line
+               <>
+               vcat (fmap peer (view refChanHeadPeers blk)) <> line
+               <>
+               vcat (fmap author (view refChanHeadAuthors blk)) <> line
 
+    where
+      peer (p,w) = parens ("peer" <+> dquotes (pretty (AsBase58 p)) <+> pretty w)
+      author p   = parens ("author" <+> dquotes (pretty (AsBase58 p)))