diff --git a/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs b/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs index 49d3f6f0..bd9d1d91 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs @@ -1,5 +1,6 @@ {-# Language TemplateHaskell #-} {-# Language UndecidableInstances #-} + module HBS2.Net.Proto.EncryptionHandshake where import HBS2.Actors.Peer @@ -50,6 +51,11 @@ sendEncryptionPubKey pip pubkey = do tt <- liftIO $ getTimeCoarse request pip (BeginEncryptionExchange @e nonce pubkey) +data EncryptionHandshakeAdapter e m s = EncryptionHandshakeAdapter + { encHandshake_considerPeerAsymmKey :: PeerAddr e -> Encrypt.PublicKey -> m () + } + + encryptionHandshakeProto :: forall e s m . ( MonadIO m , Response e (EncryptionHandshake e) m , Request e (EncryptionHandshake e) m @@ -66,17 +72,22 @@ encryptionHandshakeProto :: forall e s m . ( MonadIO m , Serialise (PubKey 'Encrypt (Encryption e)) , s ~ Encryption e , e ~ L4Proto + , PubKey Encrypt s ~ Encrypt.PublicKey ) - => PeerEnv e + => EncryptionHandshakeAdapter e m s + -> PeerEnv e -> EncryptionHandshake e -> m () -encryptionHandshakeProto penv = \case +encryptionHandshakeProto EncryptionHandshakeAdapter{..} penv = \case BeginEncryptionExchange nonce theirpubkey -> do pip <- thatPeer proto trace $ "GOT BeginEncryptionExchange from" <+> pretty pip + paddr <- toPeerAddr pip + encHandshake_considerPeerAsymmKey paddr theirpubkey + -- взять свои ключи creds <- getCredentials @s @@ -86,7 +97,7 @@ encryptionHandshakeProto penv = \case let sign = makeSign @s (view peerSignSk creds) (unEENonce nonce <> (cs . serialise) ourpubkey) -- отправить обратно вместе с публичным ключом - -- response (AckEncryptionExchange @e nonce sign ourpubkey (PeerData (view peerSignPk creds))) + response (AckEncryptionExchange @e nonce sign ourpubkey) -- Нужно ли запомнить его theirpubkey или достаточно того, что будет -- получено в обратном AckEncryptionExchange? @@ -101,6 +112,9 @@ encryptionHandshakeProto penv = \case pip <- thatPeer proto -- trace $ "AckEncryptionExchange" <+> pretty pip + paddr <- toPeerAddr pip + encHandshake_considerPeerAsymmKey paddr theirpubkey + emit PeerAsymmInfoKey (PeerAsymmPubKey pip theirpubkey) where diff --git a/hbs2-peer/app/Brains.hs b/hbs2-peer/app/Brains.hs index 9f880c28..fd312d62 100644 --- a/hbs2-peer/app/Brains.hs +++ b/hbs2-peer/app/Brains.hs @@ -13,6 +13,7 @@ import HBS2.System.Logger.Simple import PeerConfig +import Crypto.Saltine.Core.Box qualified as Encrypt import Data.Maybe import Control.Monad import Control.Exception @@ -602,6 +603,46 @@ transactional brains action = do err $ "BRAINS: " <+> viaShow e execute_ conn [qc|ROLLBACK TO SAVEPOINT {sp}|] +insertPeerAsymmKey :: forall e m . + ( e ~ L4Proto + , MonadIO m + ) + => BasicBrains e + -> PeerAddr e + -> Encrypt.PublicKey + -> m () + +insertPeerAsymmKey br peer hAsymmKey = do + let conn = view brainsDb br + void $ liftIO $ execute conn [qc| + INSERT INTO peer_asymmkey (peer,asymmkey) + VALUES (?,?) + ON CONFLICT (peer) + DO UPDATE SET + asymmkey = excluded.asymmkey + + |] (show $ pretty peer, show hAsymmKey) + +insertPeerSymmKey :: forall e m . + ( e ~ L4Proto + , MonadIO m + ) + => BasicBrains e + -> PeerAddr e + -> Encrypt.CombinedKey + -> m () + +insertPeerSymmKey br peer hSymmKey = do + let conn = view brainsDb br + void $ liftIO $ execute conn [qc| + INSERT INTO peer_symmkey (peer,symmkey) + VALUES (?,?) + ON CONFLICT (peer) + DO UPDATE SET + symmkey = excluded.symmkey + + |] (show $ pretty peer, show hSymmKey) + -- FIXME: eventually-close-db newBasicBrains :: forall e m . (Hashable (Peer e), MonadIO m) => PeerConfig @@ -690,6 +731,22 @@ newBasicBrains cfg = liftIO do ) |] + execute_ conn [qc| + create table if not exists peer_asymmkey + ( peer text not null + , asymmkey text not null + , primary key (peer) + ) + |] + + execute_ conn [qc| + create table if not exists peer_symmkey + ( peer text not null + , symmkey text not null + , primary key (peer) + ) + |] + BasicBrains <$> newTVarIO mempty <*> newTVarIO mempty <*> Cache.newCache (Just (toTimeSpec (30 :: Timeout 'Seconds))) diff --git a/hbs2-peer/app/EncryptionKeys.hs b/hbs2-peer/app/EncryptionKeys.hs new file mode 100644 index 00000000..32820c79 --- /dev/null +++ b/hbs2-peer/app/EncryptionKeys.hs @@ -0,0 +1,74 @@ +module EncryptionKeys where + +import HBS2.Actors.Peer +import HBS2.Base58 +import HBS2.Clock +import HBS2.Data.Detect +import HBS2.Data.Types.Refs +import HBS2.Events +import HBS2.Hash +import HBS2.Merkle +import HBS2.Net.Auth.Credentials +import HBS2.Net.PeerLocator +import HBS2.Net.Proto +import HBS2.Net.Proto.EncryptionHandshake +import HBS2.Net.Proto.Peer +import HBS2.Net.Proto.Sessions +import HBS2.Prelude.Plated +import HBS2.Storage +import HBS2.System.Logger.Simple + +import PeerConfig +import PeerTypes + +import Codec.Serialise +import Control.Concurrent.Async +import Control.Concurrent.STM +import Control.Monad +import Control.Monad.Reader +import Control.Monad.Trans.Maybe +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as LBS +import Data.Foldable(for_) +import Data.Function(fix) +import Data.Functor +import Data.HashMap.Strict qualified as HashMap +import Data.HashSet (HashSet) +import Data.HashSet qualified as HashSet +import Data.Maybe +import Data.Text qualified as Text + + +encryptionHandshakeWorker :: forall e m s . + ( MonadIO m + , m ~ PeerM e IO + , s ~ Encryption e + , e ~ L4Proto + , HasPeerLocator e m + -- , HasPeer e + -- , HasNonces (EncryptionHandshake e) m + -- , Request e (EncryptionHandshake e) m + -- , Sessions e (EncryptionHandshake e) m + -- , Sessions e (PeerInfo e) m + -- , Sessions e (KnownPeer e) m + -- , Pretty (Peer e) + ) + => PeerConfig + -> PeerEnv e + -> EncryptionHandshakeAdapter e m s + -> m () + +encryptionHandshakeWorker pconf penv EncryptionHandshakeAdapter{..} = do + + -- e <- ask + let ourpubkey = pubKeyFromKeypair @s $ _envAsymmetricKeyPair penv + + pl <- getPeerLocator @e + + forever do + liftIO $ pause @'Seconds 10 + + pips <- knownPeers @e pl + + forM_ pips \p -> do + sendEncryptionPubKey @e p ourpubkey diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index 8f340ab2..51e4cf43 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -45,6 +45,7 @@ import PeerInfo import PeerConfig import Bootstrap import CheckMetrics +import EncryptionKeys import RefLog qualified import RefLog (reflogWorker) import HttpWorker @@ -645,6 +646,18 @@ runPeer opts = U.handle (\e -> myException e let hshakeAdapter = PeerHandshakeAdapter addNewRtt + let encryptionHshakeAdapter :: + ( MonadIO m + ) => EncryptionHandshakeAdapter L4Proto m s + encryptionHshakeAdapter = EncryptionHandshakeAdapter + { encHandshake_considerPeerAsymmKey = \addr pk -> do + insertPeerAsymmKey brains addr pk + insertPeerSymmKey brains addr $ + genCommonSecret @s + (privKeyFromKeypair @s (view envAsymmetricKeyPair penv)) + pk + } + env <- ask pnonce <- peerNonce @e @@ -793,6 +806,9 @@ runPeer opts = U.handle (\e -> myException e peerThread "blockDownloadLoop" (blockDownloadLoop denv) + peerThread "encryptionHandshakeWorker" + (EncryptionKeys.encryptionHandshakeWorker @e conf penv encryptionHshakeAdapter) + let tcpProbeWait :: Timeout 'Seconds tcpProbeWait = (fromInteger . fromMaybe 300) (cfgValue @PeerTcpProbeWaitKey conf) @@ -909,7 +925,7 @@ runPeer opts = U.handle (\e -> myException e , makeResponse (blockChunksProto adapter) , makeResponse blockAnnounceProto , makeResponse (withCredentials @e pc . peerHandShakeProto hshakeAdapter penv) - , makeResponse (withCredentials @e pc . encryptionHandshakeProto penv) + , makeResponse (withCredentials @e pc . encryptionHandshakeProto encryptionHshakeAdapter penv) , makeResponse (peerExchangeProto pexFilt) , makeResponse (refLogUpdateProto reflogAdapter) , makeResponse (refLogRequestProto reflogReqAdapter) diff --git a/hbs2-peer/hbs2-peer.cabal b/hbs2-peer/hbs2-peer.cabal index 9bbea4dc..0710bdef 100644 --- a/hbs2-peer/hbs2-peer.cabal +++ b/hbs2-peer/hbs2-peer.cabal @@ -122,6 +122,7 @@ executable hbs2-peer other-modules: BlockDownload , BlockHttpDownload , DownloadQ + , EncryptionKeys , Bootstrap , PeerInfo , PeerMeta