wip

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

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)))

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

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)

hbs2-peer/hbs2-peer.cabal

@@ -122,6 +122,7 @@ executable hbs2-peer
     other-modules:    BlockDownload
                     , BlockHttpDownload
                     , DownloadQ
+                    , EncryptionKeys
                     , Bootstrap
                     , PeerInfo
                     , PeerMeta