From 66d147e3f57eb1c30db69ef816549365a30d3f27 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Fri, 14 Jul 2023 13:27:05 +0300 Subject: [PATCH] wip, refchans --- hbs2-core/lib/HBS2/Net/Proto/Definition.hs | 9 ++ hbs2-core/lib/HBS2/Net/Proto/RefChan.hs | 156 +++++++++++---------- 2 files changed, 88 insertions(+), 77 deletions(-) diff --git a/hbs2-core/lib/HBS2/Net/Proto/Definition.hs b/hbs2-core/lib/HBS2/Net/Proto/Definition.hs index 230a649f..5daddf1e 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/Definition.hs +++ b/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 diff --git a/hbs2-core/lib/HBS2/Net/Proto/RefChan.hs b/hbs2-core/lib/HBS2/Net/Proto/RefChan.hs index ca019bf5..1ea26470 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/RefChan.hs +++ b/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] - , _refChanHeadAuthors :: [PubKey 'Sign e] + , _refChanHeadPeers :: [(PubKey 'Sign (Encryption e),Weight)] + , _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 - , Response e (RefChanHead e) m - , IsPeerAddr e m - , Pretty (Peer e) - , Sessions e (KnownPeer e) m - , Signatures s - , Pretty (AsBase58 (PubKey 'Sign s)) - , s ~ Encryption e - ) - => RefChanHead e -> m () - -refChanHeadProto _ = pure () - - --- 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) - - - - - - + , Request e (RefChanHead e) m + , Response e (RefChanHead e) m + , IsPeerAddr e m + , Pretty (Peer e) + , Sessions e (KnownPeer e) m + , Signatures s + , Pretty (AsBase58 (PubKey 'Sign s)) + , s ~ Encryption e + ) + => RefChanHeadAdapter e m + -> RefChanHead e + -> m () +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)))