wip

2023-07-12 22:34:21 +04:00 · 2023-07-12 22:34:21 +04:00 · 9eed3a6d3f
parent 801e081c58
commit 9eed3a6d3f
5 changed files with 160 additions and 74 deletions
--- a/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs
+++ b/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,63 +31,115 @@ 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
-                         , Request e (EncryptionHandshake e) m
-                         , Sessions e (EncryptionHandshake e) m
-                         , HasNonces (EncryptionHandshake e) m
-                         , Nonce (EncryptionHandshake e) ~ EENonce
-                         , Pretty (Peer e)
-                         , HasProtocol e (EncryptionHandshake e)
-                         , e ~ L4Proto
-                         )
-         => Peer e -> PubKey 'Encrypt (Encryption e) -> m ()
+sendResetEncryptionKeys :: forall e s m .
+    ( MonadIO m
+    , Request e (EncryptionHandshake e) m
+    , e ~ L4Proto
+    , s ~ Encryption e
+    )
+  => Peer e
+  -> m ()

-sendEncryptionPubKey pip pubkey = do
-  nonce <- newNonce @(EncryptionHandshake e)
-  tt <- liftIO $ getTimeCoarse
-  request pip (BeginEncryptionExchange @e nonce pubkey)
+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
+    )
+  => PeerEnv e
+  -> PeerCredentials s
+  -> Peer e
+  -> PubKey 'Encrypt (Encryption e)
+  -> m ()
+
+sendBeginEncryptionExchange penv creds peer pubkey = do
+    nonce0 <- newNonce @(EncryptionHandshake e)
+    let ourpubkey = pubKeyFromKeypair @s $ view envAsymmetricKeyPair penv
+    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
-                                     , Response e (EncryptionHandshake e) m
-                                     , Request e (EncryptionHandshake e) m
-                                     , Sessions e (EncryptionHandshake e) m
-                                     , HasNonces (EncryptionHandshake e) m
-                                     , HasPeerNonce e m
-                                     , Nonce (EncryptionHandshake e) ~ EENonce
-                                     , Pretty (Peer e)
-                                     , EventEmitter e (EncryptionHandshake e) m
-                                     , EventEmitter e (PeerAsymmInfo e) m
-                                     , HasCredentials s m
-                                     , Asymm s
-                                     , Signatures s
-                                     , Serialise (PubKey 'Encrypt (Encryption e))
-                                     , s ~ Encryption e
-                                     , e ~ L4Proto
-                                     , PubKey Encrypt s ~ Encrypt.PublicKey
-                                     )
-                   => EncryptionHandshakeAdapter e m s
-                   -> PeerEnv e
-                   -> EncryptionHandshake e
-                   -> m ()
+encryptionHandshakeProto :: forall e s m .
+    ( MonadIO m
+    , Response e (EncryptionHandshake e) m
+    , Request e (EncryptionHandshake e) m
+    , Sessions e (KnownPeer e) m
+    -- , Sessions e (EncryptionHandshake e) m
+    -- , HasNonces (EncryptionHandshake e) m
+    -- , HasPeerNonce e m
+    -- , Nonce (EncryptionHandshake e) ~ EENonce
+    -- , 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
+  -> EncryptionHandshake e
+  -> m ()

 encryptionHandshakeProto EncryptionHandshakeAdapter{..} penv = \case

-    BeginEncryptionExchange nonce theirpubkey -> do
-      pip <- thatPeer proto
-      trace $ "GOT BeginEncryptionExchange from" <+> pretty pip
+  ResetEncryptionKeys -> do
+      peer <- thatPeer proto
+      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
-      encHandshake_considerPeerAsymmKey paddr theirpubkey
+      creds <- getCredentials @s
+      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 или достаточно того, что будет
-      -- получено в обратном AckEncryptionExchange?
-      -- Нужно!
-      emit PeerAsymmInfoKey (PeerAsymmPubKey pip theirpubkey)
+      emit PeerAsymmInfoKey (PeerAsymmPubKey peer theirpubkey)

-      -- se <- find (KnownPeerKey pip) id <&> isJust
-      -- unless se $ do
-      --   sendEncryptionPubKey pip ourpubkey
+  AckEncryptionExchange nonce0 theirsign theirpubkey -> do
+      peer <- thatPeer proto
+      paddr <- toPeerAddr peer
+      mpeerData <- find (KnownPeerKey peer) id
+      -- TODO: check theirsign

-    AckEncryptionExchange nonce0 sign theirpubkey -> do
-      pip <- thatPeer proto
-      -- trace $ "AckEncryptionExchange" <+> pretty pip
+      trace $ "EHSP AckEncryptionExchange from" <+> viaShow (peer, paddr, mpeerData)

-      paddr <- toPeerAddr pip
-      encHandshake_considerPeerAsymmKey paddr theirpubkey
+      encHandshake_considerPeerAsymmKey paddr mpeerData (Just theirpubkey)

-      emit PeerAsymmInfoKey (PeerAsymmPubKey pip theirpubkey)
+      emit PeerAsymmInfoKey (PeerAsymmPubKey peer theirpubkey)

  where
    proto = Proxy @(EncryptionHandshake e)
--- a/hbs2-peer/app/Brains.hs
+++ b/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)
    )
  |]
--- a/hbs2-peer/app/EncryptionKeys.hs
+++ b/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
-    -> EncryptionHandshakeAdapter e m 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
-            sendEncryptionPubKey @e p ourpubkey
+        forM_ peers \peer -> do
+            sendBeginEncryptionExchange @e penv creds peer ourpubkey
--- a/hbs2-peer/app/PeerMain.hs
+++ b/hbs2-peer/app/PeerMain.hs
@ -650,12 +650,16 @@ runPeer opts = U.handle (\e -> myException e
                      ( 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
+                    { 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
+                                    (privKeyFromKeypair @s (view envAsymmetricKeyPair penv))
+                                    pk
                    }

              env <- ask
@ -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)
--- a/hbs2-peer/app/ProxyMessaging.hs
+++ b/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