mirror of https://github.com/voidlizard/hbs2
wip, refchans
This commit is contained in:
Dmitry Zuikov
parent
0f1880ff53
commit
66d147e3f5
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue