diff --git a/hbs2-core/lib/HBS2/Actors/Peer.hs b/hbs2-core/lib/HBS2/Actors/Peer.hs index 14f66116..ef0983d5 100644 --- a/hbs2-core/lib/HBS2/Actors/Peer.hs +++ b/hbs2-core/lib/HBS2/Actors/Peer.hs @@ -302,7 +302,6 @@ instance ( MonadIO m , PeerMessaging e , HasTimeLimits e msg m , Show (Peer e) - , Show msg ) => Request e msg m where request peer_e msg = do let proto = protoId @e @msg (Proxy @msg) @@ -318,8 +317,8 @@ instance ( MonadIO m -- liftIO $ print "request!" allowed <- tryLockForPeriod peer_e msg - when (not allowed) do - trace $ "REQUEST: not allowed to send" <+> viaShow msg + unless allowed do + trace $ "REQUEST: not allowed to send for proto" <+> viaShow proto when allowed do sendTo pipe (To peer_e) (From me) (AnyMessage @(Encoded e) @e proto (encode msg)) diff --git a/hbs2-core/lib/HBS2/Net/Proto/Definition.hs b/hbs2-core/lib/HBS2/Net/Proto/Definition.hs index 8816961d..d6376143 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/Definition.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/Definition.hs @@ -7,7 +7,6 @@ module HBS2.Net.Proto.Definition where import HBS2.Clock -import HBS2.Data.Types.Crypto import HBS2.Defaults import HBS2.Hash import HBS2.Net.Auth.Credentials @@ -35,8 +34,6 @@ import Crypto.Saltine.Class qualified as Crypto import Crypto.Saltine.Core.Sign qualified as Sign import Crypto.Saltine.Core.Box qualified as Encrypt -import HBS2.Data.Types.Crypto - type instance Encryption L4Proto = HBS2Basic @@ -52,11 +49,6 @@ type instance PrivKey 'Encrypt HBS2Basic = Encrypt.SecretKey -- но возможно, будет работать и так, ведь ключи -- это же всего лишь байтстроки внутри. -instance Serialise Sign.PublicKey -instance Serialise Encrypt.PublicKey -instance Serialise Sign.SecretKey -instance Serialise Encrypt.SecretKey - deserialiseCustom :: (Serialise a, MonadPlus m) => ByteString -> m a deserialiseCustom = either (const mzero) pure . deserialiseOrFail -- deserialiseCustom = either (\msg -> trace ("deserialiseCustom: " <> show msg) mzero) pure . deserialiseOrFail @@ -209,11 +201,8 @@ instance Expires (EventKey L4Proto (PeerAnnounce L4Proto)) where instance Expires (EventKey L4Proto (PeerMetaProto L4Proto)) where expiresIn _ = Just 600 --- instance MonadIO m => HasNonces () m where --- type instance Nonce (PeerHandshake L4Proto) = BS.ByteString --- newNonce = do --- n <- liftIO ( Crypto.newNonce <&> Crypto.encode ) --- pure $ BS.take 32 n +instance Expires (SessionKey L4Proto (EncryptionHandshake L4Proto)) where + expiresIn _ = Just defCookieTimeoutSec instance MonadIO m => HasNonces (PeerHandshake L4Proto) m where type instance Nonce (PeerHandshake L4Proto) = BS.ByteString @@ -239,13 +228,6 @@ instance MonadIO m => HasNonces () m where n <- liftIO ( Crypto.newNonce <&> Crypto.encode ) pure $ BS.take 32 n -instance Serialise Sign.Signature - -instance Signatures HBS2Basic where - type Signature HBS2Basic = Sign.Signature - makeSign = Sign.signDetached - verifySign = Sign.signVerifyDetached - instance Asymm HBS2Basic where type AsymmKeypair HBS2Basic = Encrypt.Keypair type AsymmPrivKey HBS2Basic = Encrypt.SecretKey diff --git a/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs b/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs index c9faecaf..37964767 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs @@ -83,7 +83,7 @@ encryptionHandshakeProto :: forall e s m . , Serialise (PubKey 'Encrypt (Encryption e)) , s ~ Encryption e , e ~ L4Proto - , PubKey Encrypt s ~ Encrypt.PublicKey + , PubKey 'Encrypt s ~ Encrypt.PublicKey , Show (PubKey 'Sign s) , Show (Nonce ()) ) diff --git a/hbs2-core/lib/HBS2/Net/Proto/RefChan.hs b/hbs2-core/lib/HBS2/Net/Proto/RefChan.hs index 13ee42fa..9a417947 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/RefChan.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/RefChan.hs @@ -5,8 +5,6 @@ {-# LANGUAGE ImplicitParams #-} module HBS2.Net.Proto.RefChan where --- import HBS2.Actors.Peer.Types -import HBS2.Data.Types.Peer import HBS2.Prelude.Plated import HBS2.Hash import HBS2.Data.Detect @@ -21,6 +19,7 @@ import HBS2.Net.Proto.BlockAnnounce import HBS2.Net.Proto.Sessions import HBS2.Data.Types.Refs import HBS2.Actors.Peer.Types +import HBS2.Data.Types.Peer import HBS2.Storage import Data.Config.Suckless @@ -153,9 +152,6 @@ data RefChanHead e = | RefChanGetHead (RefChanId e) deriving stock (Generic) -instance Show (RefChanHead e) where - show _ = "RefChanHead" - instance ForRefChans e => Serialise (RefChanHead e) @@ -226,9 +222,6 @@ data RefChanUpdate e = | Accept (RefChanId e) (SignedBox (AcceptTran e) e) -- подписано ключом пира deriving stock (Generic) -instance Show (RefChanUpdate e) where - show _ = "RefChanUpdate" - instance ForRefChans e => Serialise (RefChanUpdate e) data RefChanRequest e = @@ -236,9 +229,6 @@ data RefChanRequest e = | RefChanResponse (RefChanId e) HashRef deriving stock (Generic,Typeable) -instance Show (RefChanRequest e) where - show _ = "RefChanRequest" - instance ForRefChans e => Serialise (RefChanRequest e) data instance EventKey e (RefChanRequest e) = @@ -488,89 +478,85 @@ refChanUpdateProto self pc adapter msg = do -- -- рассылаем ли себе? что бы был хоть один accept lift $ refChanUpdateProto True pc adapter accept - Accept chan box -> undefined - -- TODO: fix refchain - -- deferred proto do + Accept chan box -> deferred proto do --- debug $ "RefChanUpdate/ACCEPT" <+> pretty h0 + debug $ "RefChanUpdate/ACCEPT" <+> pretty h0 --- (peerKey, AcceptTran headRef hashRef) <- MaybeT $ pure $ unboxSignedBox0 box + (peerKey, AcceptTran headRef hashRef) <- MaybeT $ pure $ unboxSignedBox0 box --- let refchanKey = RefChanHeadKey @s chan --- h <- MaybeT $ liftIO $ getRef sto refchanKey + let refchanKey = RefChanHeadKey @s chan + h <- MaybeT $ liftIO $ getRef sto refchanKey --- guard (HashRef h == headRef) + guard (HashRef h == headRef) --- lift $ gossip msg + lift $ gossip msg --- -- тут может так случиться, что propose еще нет --- -- UDP вообще не гарантирует порядок доставки, а отправляем мы транзы --- -- почти одновременно. ну или не успело записаться. и что делать? + -- тут может так случиться, что propose еще нет + -- UDP вообще не гарантирует порядок доставки, а отправляем мы транзы + -- почти одновременно. ну или не успело записаться. и что делать? --- here <- liftIO (hasBlock sto (fromHashRef hashRef)) <&> isJust + here <- liftIO (hasBlock sto (fromHashRef hashRef)) <&> isJust --- unless here do --- warn $ "No propose transaction saved yet!" <+> pretty hashRef + unless here do + warn $ "No propose transaction saved yet!" <+> pretty hashRef --- tranBs <- MaybeT $ liftIO $ getBlock sto (fromHashRef hashRef) + tranBs <- MaybeT $ liftIO $ getBlock sto (fromHashRef hashRef) --- tran <- MaybeT $ pure $ deserialiseOrFail @(RefChanUpdate e) tranBs & either (const Nothing) Just + tran <- MaybeT $ pure $ deserialiseOrFail @(RefChanUpdate e) tranBs & either (const Nothing) Just --- headBlock <- MaybeT $ getActualRefChanHead @e refchanKey + headBlock <- MaybeT $ getActualRefChanHead @e refchanKey --- proposed <- MaybeT $ pure $ case tran of --- Propose _ pbox -> Just pbox --- _ -> Nothing + proposed <- MaybeT $ pure $ case tran of + Propose _ pbox -> Just pbox + _ -> Nothing --- (_, ptran) <- MaybeT $ pure $ unboxSignedBox0 @(ProposeTran e) @e proposed + (_, ptran) <- MaybeT $ pure $ unboxSignedBox0 @(ProposeTran e) @e proposed --- debug $ "ACCEPT FROM:" <+> pretty (AsBase58 peerKey) <+> pretty h0 + debug $ "ACCEPT FROM:" <+> pretty (AsBase58 peerKey) <+> pretty h0 --- -- compiler bug? --- let (ProposeTran _ pbox) = ptran + -- compiler bug? + let (ProposeTran _ pbox) = ptran --- (authorKey, _) <- MaybeT $ pure $ unboxSignedBox0 pbox + (authorKey, _) <- MaybeT $ pure $ unboxSignedBox0 pbox --- -- может, и не надо второй раз проверять --- guard $ checkACL headBlock peerKey authorKey + -- может, и не надо второй раз проверять + guard $ checkACL headBlock peerKey authorKey --- debug $ "JUST GOT TRANSACTION FROM STORAGE! ABOUT TO CHECK IT" <+> pretty hashRef + debug $ "JUST GOT TRANSACTION FROM STORAGE! ABOUT TO CHECK IT" <+> pretty hashRef --- rcRound <- MaybeT $ find (RefChanRoundKey @e hashRef) id + rcRound <- MaybeT $ find (RefChanRoundKey @e hashRef) id --- atomically $ modifyTVar (view refChanRoundAccepts rcRound) (HashMap.insert peerKey ()) + atomically $ modifyTVar (view refChanRoundAccepts rcRound) (HashMap.insert peerKey ()) --- -- TODO: garbage-collection-strongly-required --- ha <- MaybeT $ liftIO $ putBlock sto (serialise msg) + -- TODO: garbage-collection-strongly-required + ha <- MaybeT $ liftIO $ putBlock sto (serialise msg) --- atomically $ modifyTVar (view refChanRoundTrans rcRound) (HashSet.insert (HashRef ha)) --- -- atomically $ modifyTVar (view refChanRoundTrans rcRound) (HashSet.insert hashRef) -- propose just in case we missed it? + atomically $ modifyTVar (view refChanRoundTrans rcRound) (HashSet.insert (HashRef ha)) + -- atomically $ modifyTVar (view refChanRoundTrans rcRound) (HashSet.insert hashRef) -- propose just in case we missed it? --- accepts <- atomically $ readTVar (view refChanRoundAccepts rcRound) <&> HashMap.size + accepts <- atomically $ readTVar (view refChanRoundAccepts rcRound) <&> HashMap.size --- debug $ "ACCEPTS:" <+> pretty accepts + debug $ "ACCEPTS:" <+> pretty accepts --- closed <- readTVarIO (view refChanRoundClosed rcRound) + closed <- readTVarIO (view refChanRoundClosed rcRound) --- -- FIXME: round! --- when (fromIntegral accepts >= view refChanHeadQuorum headBlock && not closed) do --- debug $ "ROUND!" <+> pretty accepts <+> pretty hashRef + -- FIXME: round! + when (fromIntegral accepts >= view refChanHeadQuorum headBlock && not closed) do + debug $ "ROUND!" <+> pretty accepts <+> pretty hashRef --- trans <- atomically $ readTVar (view refChanRoundTrans rcRound) <&> HashSet.toList + trans <- atomically $ readTVar (view refChanRoundTrans rcRound) <&> HashSet.toList --- forM_ trans $ \t -> do --- lift $ refChanWriteTran adapter t --- debug $ "WRITING TRANS" <+> pretty t + forM_ trans $ \t -> do + lift $ refChanWriteTran adapter t + debug $ "WRITING TRANS" <+> pretty t --- let pips = view refChanHeadPeers headBlock & HashMap.keys & HashSet.fromList --- votes <- readTVarIO (view refChanRoundAccepts rcRound) <&> HashSet.fromList . HashMap.keys + let pips = view refChanHeadPeers headBlock & HashMap.keys & HashSet.fromList + votes <- readTVarIO (view refChanRoundAccepts rcRound) <&> HashSet.fromList . HashMap.keys --- when (pips `HashSet.isSubsetOf` votes) do --- debug $ "CLOSING ROUND" <+> pretty hashRef <+> pretty (length trans) --- atomically $ writeTVar (view refChanRoundClosed rcRound) True - --- lift $ refChanUpdateProto True pc adapter msg + when (pips `HashSet.isSubsetOf` votes) do + debug $ "CLOSING ROUND" <+> pretty hashRef <+> pretty (length trans) + atomically $ writeTVar (view refChanRoundClosed rcRound) True where proto = Proxy @(RefChanUpdate e) diff --git a/hbs2-core/lib/HBS2/Net/Proto/Types.hs b/hbs2-core/lib/HBS2/Net/Proto/Types.hs index 413c677a..f2680a08 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/Types.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/Types.hs @@ -111,8 +111,7 @@ data ReqLimPeriod = NoLimit | ReqLimPerProto (Timeout 'Seconds) | ReqLimPerMessage (Timeout 'Seconds) -class (KnownNat (ProtocolId p), HasPeer e, Show (Encoded e) - ) => HasProtocol e p | p -> e where +class (KnownNat (ProtocolId p), HasPeer e ) => HasProtocol e p | p -> e where type family ProtocolId p = (id :: Nat) | id -> p type family Encoded e :: Type diff --git a/hbs2-peer/app/EncryptionKeys.hs b/hbs2-peer/app/EncryptionKeys.hs index 2a963e40..dd524d5d 100644 --- a/hbs2-peer/app/EncryptionKeys.hs +++ b/hbs2-peer/app/EncryptionKeys.hs @@ -16,6 +16,7 @@ import HBS2.Net.Proto.Peer import HBS2.Net.Proto.Sessions import HBS2.Prelude.Plated import HBS2.Storage +import HBS2.Net.Proto.Definition() import HBS2.System.Logger.Simple import PeerConfig @@ -48,7 +49,7 @@ encryptionHandshakeWorker :: forall e m s . -- , HasPeer e -- , HasNonces (EncryptionHandshake e) m -- , Request e (EncryptionHandshake e) m - -- , Sessions e (EncryptionHandshake e) m + , Sessions e (EncryptionHandshake e) m -- , Sessions e (PeerInfo e) m -- , Sessions e (KnownPeer e) m -- , Pretty (Peer e) @@ -80,3 +81,4 @@ encryptionHandshakeWorker pconf penv creds EncryptionHandshakeAdapter{..} = do case mkey of Just _ -> pure () Nothing -> sendBeginEncryptionExchange @e creds ourpubkey peer +