wip

hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs

@@ -10,6 +10,7 @@ import HBS2.Data.Types
 import HBS2.Events
 import HBS2.Net.Auth.Credentials
 import HBS2.Net.Proto
+import HBS2.Net.Proto.Peer
 import HBS2.Net.Proto.Sessions
 import HBS2.Prelude.Plated
 import HBS2.System.Logger.Simple
@@ -30,49 +31,86 @@ newtype EENonce = EENonce { unEENonce :: BS.ByteString }
   deriving newtype (Eq, Serialise, Hashable)
   deriving (Pretty, Show) via AsBase58 BS.ByteString
 
+instance
+    ( Show (PubKey 'Encrypt (Encryption e))
+    , Show (PubKey 'Sign (Encryption e))
+    , Show (Nonce ())
+    )
+    => Pretty (PeerData e) where
+  pretty = viaShow
+
 data EncryptionHandshake e =
-    BeginEncryptionExchange EENonce (PubKey 'Encrypt (Encryption e))
+    BeginEncryptionExchange EENonce (Signature (Encryption e)) (PubKey 'Encrypt (Encryption e))
   | AckEncryptionExchange EENonce (Signature (Encryption e)) (PubKey 'Encrypt (Encryption e))
+  | ResetEncryptionKeys
   deriving stock (Generic)
 
-sendEncryptionPubKey :: forall e m . ( MonadIO m
+sendResetEncryptionKeys :: forall e s m .
+    ( MonadIO m
+    , Request e (EncryptionHandshake e) m
+    , e ~ L4Proto
+    , s ~ Encryption e
+    )
+  => Peer e
+  -> m ()
+
+sendResetEncryptionKeys peer = do
+    request peer (ResetEncryptionKeys @e)
+
+sendBeginEncryptionExchange :: forall e s m .
+    ( MonadIO m
     , Request e (EncryptionHandshake e) m
     , Sessions e (EncryptionHandshake e) m
     , HasNonces (EncryptionHandshake e) m
+    -- , HasCredentials s m
+    , Asymm s
+    , Signatures s
+    , Serialise (PubKey 'Encrypt s)
     , Nonce (EncryptionHandshake e) ~ EENonce
     , Pretty (Peer e)
     , HasProtocol e (EncryptionHandshake e)
     , e ~ L4Proto
+    , s ~ Encryption e
     )
-         => Peer e -> PubKey 'Encrypt (Encryption e) -> m ()
+  => PeerEnv e
+  -> PeerCredentials s
+  -> Peer e
+  -> PubKey 'Encrypt (Encryption e)
+  -> m ()
 
-sendEncryptionPubKey pip pubkey = do
+sendBeginEncryptionExchange penv creds peer pubkey = do
-  nonce <- newNonce @(EncryptionHandshake e)
+    nonce0 <- newNonce @(EncryptionHandshake e)
-  tt <- liftIO $ getTimeCoarse
+    let ourpubkey = pubKeyFromKeypair @s $ view envAsymmetricKeyPair penv
-  request pip (BeginEncryptionExchange @e nonce pubkey)
+    let sign = makeSign @s (view peerSignSk creds) (unEENonce nonce0 <> (cs . serialise) ourpubkey)
+    request peer (BeginEncryptionExchange @e nonce0 sign pubkey)
 
 data EncryptionHandshakeAdapter e m s = EncryptionHandshakeAdapter
-  { encHandshake_considerPeerAsymmKey :: PeerAddr e -> Encrypt.PublicKey -> m ()
+  { encHandshake_considerPeerAsymmKey :: PeerAddr e -> Maybe (PeerData e) -> Maybe Encrypt.PublicKey -> m ()
   }
 
 
-encryptionHandshakeProto :: forall e s m . ( MonadIO m
+encryptionHandshakeProto :: forall e s m .
+    ( MonadIO m
     , Response e (EncryptionHandshake e) m
     , Request e (EncryptionHandshake e) m
-                                     , Sessions e (EncryptionHandshake e) m
+    , Sessions e (KnownPeer e) m
-                                     , HasNonces (EncryptionHandshake e) m
+    -- , Sessions e (EncryptionHandshake e) m
-                                     , HasPeerNonce e m
+    -- , HasNonces (EncryptionHandshake e) m
-                                     , Nonce (EncryptionHandshake e) ~ EENonce
+    -- , HasPeerNonce e m
-                                     , Pretty (Peer e)
+    -- , Nonce (EncryptionHandshake e) ~ EENonce
-                                     , EventEmitter e (EncryptionHandshake e) m
+    -- , Pretty (Peer e)
+    -- , EventEmitter e (EncryptionHandshake e) m
     , EventEmitter e (PeerAsymmInfo e) m
     , HasCredentials s m
     , Asymm s
     , Signatures s
+    , Sessions e (EncryptionHandshake e) m
     , Serialise (PubKey 'Encrypt (Encryption e))
     , s ~ Encryption e
     , e ~ L4Proto
     , PubKey Encrypt s ~ Encrypt.PublicKey
+    , Show (PubKey 'Sign s)
+    , Show (Nonce ())
     )
   => EncryptionHandshakeAdapter e m s
   -> PeerEnv e
@@ -81,12 +119,27 @@ encryptionHandshakeProto :: forall e s m . ( MonadIO m
 
 encryptionHandshakeProto EncryptionHandshakeAdapter{..} penv = \case
 
-    BeginEncryptionExchange nonce theirpubkey -> do
+  ResetEncryptionKeys -> do
-      pip <- thatPeer proto
+      peer <- thatPeer proto
-      trace $ "GOT BeginEncryptionExchange from" <+> pretty pip
+      paddr <- toPeerAddr peer
+      mpeerData <- find (KnownPeerKey peer) id
+      -- TODO: check theirsign
+      trace $ "EHSP ResetEncryptionKeys from" <+> viaShow (peer, paddr, mpeerData)
+      encHandshake_considerPeerAsymmKey paddr mpeerData Nothing
 
-      paddr <- toPeerAddr pip
+      creds <- getCredentials @s
-      encHandshake_considerPeerAsymmKey paddr theirpubkey
+      let ourpubkey = pubKeyFromKeypair @s $ view envAsymmetricKeyPair penv
+      sendBeginEncryptionExchange @e penv creds peer ourpubkey
+
+  BeginEncryptionExchange nonce0 theirsign theirpubkey -> do
+      peer <- thatPeer proto
+      paddr <- toPeerAddr peer
+      mpeerData <- find (KnownPeerKey peer) id
+      -- TODO: check theirsign
+
+      trace $ "EHSP BeginEncryptionExchange from" <+> viaShow (peer, paddr, mpeerData)
+
+      encHandshake_considerPeerAsymmKey paddr mpeerData (Just theirpubkey)
 
       -- взять свои ключи
       creds <- getCredentials @s
@@ -94,28 +147,24 @@ encryptionHandshakeProto EncryptionHandshakeAdapter{..} penv = \case
       let ourpubkey = pubKeyFromKeypair @s $ view envAsymmetricKeyPair penv
 
       -- подписать нонс
-      let sign = makeSign @s (view peerSignSk creds) (unEENonce nonce <> (cs . serialise) ourpubkey)
+      let sign = makeSign @s (view peerSignSk creds) (unEENonce nonce0 <> (cs . serialise) ourpubkey)
 
       -- отправить обратно вместе с публичным ключом
-      response (AckEncryptionExchange @e nonce sign ourpubkey)
+      response (AckEncryptionExchange @e nonce0 sign ourpubkey)
 
-      -- Нужно ли запомнить его theirpubkey или достаточно того, что будет
+      emit PeerAsymmInfoKey (PeerAsymmPubKey peer theirpubkey)
-      -- получено в обратном AckEncryptionExchange?
-      -- Нужно!
-      emit PeerAsymmInfoKey (PeerAsymmPubKey pip theirpubkey)
 
-      -- se <- find (KnownPeerKey pip) id <&> isJust
+  AckEncryptionExchange nonce0 theirsign theirpubkey -> do
-      -- unless se $ do
+      peer <- thatPeer proto
-      --   sendEncryptionPubKey pip ourpubkey
+      paddr <- toPeerAddr peer
+      mpeerData <- find (KnownPeerKey peer) id
+      -- TODO: check theirsign
 
-    AckEncryptionExchange nonce0 sign theirpubkey -> do
+      trace $ "EHSP AckEncryptionExchange from" <+> viaShow (peer, paddr, mpeerData)
-      pip <- thatPeer proto
-      -- trace $ "AckEncryptionExchange" <+> pretty pip
 
-      paddr <- toPeerAddr pip
+      encHandshake_considerPeerAsymmKey paddr mpeerData (Just theirpubkey)
-      encHandshake_considerPeerAsymmKey paddr theirpubkey
 
-      emit PeerAsymmInfoKey (PeerAsymmPubKey pip theirpubkey)
+      emit PeerAsymmInfoKey (PeerAsymmPubKey peer theirpubkey)
 
   where
     proto = Proxy @(EncryptionHandshake e)

hbs2-peer/app/Brains.hs

@@ -603,6 +603,8 @@ transactional brains action = do
       err $ "BRAINS: " <+> viaShow e
       execute_ conn [qc|ROLLBACK TO SAVEPOINT {sp}|]
 
+---
+
 insertPeerAsymmKey :: forall e m .
     ( e ~ L4Proto
     , MonadIO m
@@ -643,6 +645,26 @@ insertPeerSymmKey br peer hSymmKey = do
 
     |] (show $ pretty peer, show hSymmKey)
 
+deletePeerAsymmKey :: forall e m . (e ~ L4Proto, MonadIO m)
+    => BasicBrains e -> PeerAddr e -> m ()
+
+deletePeerAsymmKey br peer =
+    void $ liftIO $ execute (view brainsDb br) [qc|
+        DELETE FROM peer_symmkey
+        WHERE peer = ?
+    |] (Only (show $ pretty peer))
+
+deletePeerSymmKey :: forall e m . (e ~ L4Proto, MonadIO m)
+    => BasicBrains e -> PeerAddr e -> m ()
+
+deletePeerSymmKey br peer =
+    void $ liftIO $ execute (view brainsDb br) [qc|
+        DELETE FROM peer_symmkey
+        WHERE peer = ?
+    |] (Only (show $ pretty peer))
+
+---
+
 -- FIXME: eventually-close-db
 newBasicBrains :: forall e m . (Hashable (Peer e), MonadIO m)
                => PeerConfig
@@ -735,6 +757,7 @@ newBasicBrains cfg = liftIO do
     create table if not exists peer_asymmkey
     ( peer text not null
     , asymmkey text not null
+    , ts DATE DEFAULT (datetime('now','localtime'))
     , primary key (peer)
     )
   |]
@@ -743,6 +766,7 @@ newBasicBrains cfg = liftIO do
     create table if not exists peer_symmkey
     ( peer text not null
     , symmkey text not null
+    , ts DATE DEFAULT (datetime('now','localtime'))
     , primary key (peer)
     )
   |]

hbs2-peer/app/EncryptionKeys.hs

@@ -52,15 +52,17 @@ encryptionHandshakeWorker :: forall e m s .
     -- , Sessions e (PeerInfo e) m
     -- , Sessions e (KnownPeer e) m
     -- , Pretty (Peer e)
+    -- , HasCredentials s m
     )
   => PeerConfig
   -> PeerEnv e
+  -> PeerCredentials s
   -> EncryptionHandshakeAdapter e m s
   -> m ()
 
-encryptionHandshakeWorker pconf penv EncryptionHandshakeAdapter{..} = do
+encryptionHandshakeWorker pconf penv creds EncryptionHandshakeAdapter{..} = do
 
-    -- e <- ask
+    -- e :: PeerEnv e <- ask
     let ourpubkey = pubKeyFromKeypair @s $ _envAsymmetricKeyPair penv
 
     pl <- getPeerLocator @e
@@ -68,7 +70,7 @@ encryptionHandshakeWorker pconf penv EncryptionHandshakeAdapter{..} = do
     forever do
         liftIO $ pause @'Seconds 10
 
-        pips <- knownPeers @e pl
+        peers <- knownPeers @e pl
 
-        forM_ pips \p -> do
+        forM_ peers \peer -> do
-            sendEncryptionPubKey @e p ourpubkey
+            sendBeginEncryptionExchange @e penv creds peer ourpubkey

hbs2-peer/app/PeerMain.hs

@@ -650,7 +650,11 @@ runPeer opts = U.handle (\e -> myException e
                       ( MonadIO m
                       ) => EncryptionHandshakeAdapter L4Proto m s
                   encryptionHshakeAdapter = EncryptionHandshakeAdapter
-                    { encHandshake_considerPeerAsymmKey = \addr pk -> do
+                    { encHandshake_considerPeerAsymmKey = \addr mpeerData -> \case
+                        Nothing -> do
+                            deletePeerAsymmKey brains addr
+                            deletePeerSymmKey brains addr
+                        Just pk -> do
                             insertPeerAsymmKey brains addr pk
                             insertPeerSymmKey brains addr $
                                 genCommonSecret @s
@@ -807,7 +811,7 @@ runPeer opts = U.handle (\e -> myException e
                 peerThread "blockDownloadLoop" (blockDownloadLoop denv)
 
                 peerThread "encryptionHandshakeWorker"
-                    (EncryptionKeys.encryptionHandshakeWorker @e conf penv encryptionHshakeAdapter)
+                    (EncryptionKeys.encryptionHandshakeWorker @e conf penv pc encryptionHshakeAdapter)
 
                 let tcpProbeWait :: Timeout 'Seconds
                     tcpProbeWait = (fromInteger . fromMaybe 300) (cfgValue @PeerTcpProbeWaitKey conf)

hbs2-peer/app/ProxyMessaging.hs

@@ -151,6 +151,13 @@ receiveFromProxyMessaging bus _ = liftIO do
         encKeys <- (liftIO . readTVarIO) (view proxyEncryptionKeys bus)
         fmap (w, ) <$> dfm whom (Map.lookup whom encKeys) msg
 
+    -- TODO:
+    -- Если мы не смогли, по любой причине, расшифровать сообщение,
+    --   то нужно стереть у себя ключ
+    -- Если мы не смогли, по любой причине, расшифровать сообщение,
+    --   но уверены что оно зашифровано, то нужно отправить
+    -- sendResetEncryptionKeys
+
     where
       dfm :: Peer L4Proto -> Maybe Encrypt.CombinedKey -> LBS.ByteString -> IO (Maybe LBS.ByteString)
       dfm = \whom mk msg -> case mk of