Move encryption keys to ProxyMessaging

Change key for encryption key map from PeerData to EncryptionKeyIDKey

Test for quasidistributiveness of the encodeFrames

Move Dialog to HBS2.Net

Fixes with hlint:   hbs2-peer/app/PeerMain/DialogCliCommand.hs

.fixme/log

@@ -1,3 +0,0 @@
-
-(fixme-set "assigned" "HPoqtobDAT" "voidlizard")
-(fixme-set "workflow" "test" "HPoqtobDAT")

hbs2-core/hbs2-core.cabal

@@ -120,10 +120,10 @@ library
                     , HBS2.Storage.Operations
                     , HBS2.System.Logger.Simple
                     , HBS2.System.Logger.Simple.Class
-                    , Dialog.Core
+                    , HBS2.Net.Dialog.Core
-                    , Dialog.Client
+                    , HBS2.Net.Dialog.Client
-                    , Dialog.Helpers.List
+                    , HBS2.Net.Dialog.Helpers.List
-                    , Dialog.Helpers.Streaming
+                    , HBS2.Net.Dialog.Helpers.Streaming
 
 
     -- other-modules:

hbs2-core/lib/HBS2/Actors/Peer.hs

@@ -11,6 +11,7 @@ module HBS2.Actors.Peer
 import HBS2.Actors
 import HBS2.Actors.Peer.Types
 import HBS2.Clock
+import HBS2.Data.Types.Crypto
 import HBS2.Data.Types.Peer
 import HBS2.Defaults
 import HBS2.Events
@@ -158,30 +159,8 @@ data PeerEnv e =
   , _envSweepers      :: TVar (HashMap SKey [PeerM e IO ()])
   , _envReqMsgLimit   :: Cache (Peer e, Integer, Encoded e) ()
   , _envReqProtoLimit :: Cache (Peer e, Integer) ()
-  , _envAsymmetricKeyPair :: AsymmKeypair (Encryption e)
-  , _envEncryptionKeys :: TVar (HashMap (PeerData e) (CommonSecret (Encryption e)))
   }
 
-setEncryptionKey ::
-  ( Hashable (PubKey 'Sign (Encryption L4Proto))
-  , Hashable PeerNonce
-  , Show (PubKey 'Sign (Encryption L4Proto))
-  , Show PeerNonce
-  , Show (CommonSecret (Encryption L4Proto))
-  ) => PeerEnv L4Proto -> Peer L4Proto -> PeerData L4Proto -> Maybe (CommonSecret (Encryption L4Proto)) -> IO ()
-setEncryptionKey penv peer pd msecret = do
-    atomically $ modifyTVar' (_envEncryptionKeys penv) $ Lens.at pd .~ msecret
-    case msecret of
-        Nothing -> trace $ "ENCRYPTION delete key" <+> pretty peer <+> viaShow pd
-        Just k ->  trace $ "ENCRYPTION store key" <+> pretty peer <+> viaShow pd <+> viaShow k
-
-getEncryptionKey ::
-  ( Hashable (PubKey 'Sign (Encryption L4Proto))
-  , Hashable PeerNonce
-  ) => PeerEnv L4Proto -> PeerData L4Proto -> IO (Maybe (CommonSecret (Encryption L4Proto)))
-getEncryptionKey penv pd =
-    readTVarIO (_envEncryptionKeys penv) <&> preview (Lens.ix pd)
-
 newtype PeerM e m a = PeerM { fromPeerM :: ReaderT (PeerEnv e) m a }
                       deriving newtype ( Functor
                                        , Applicative
@@ -435,8 +414,6 @@ newPeerEnv s bus p = do
   _envSweepers      <- liftIO (newTVarIO mempty)
   _envReqMsgLimit   <- liftIO (Cache.newCache (Just defRequestLimit))
   _envReqProtoLimit <- liftIO (Cache.newCache (Just defRequestLimit))
-  _envAsymmetricKeyPair <- asymmNewKeypair @(Encryption e)
-  _envEncryptionKeys <- liftIO (newTVarIO mempty)
   pure PeerEnv {..}
 
 runPeerM :: forall e m . ( MonadIO m

hbs2-core/lib/HBS2/Data/Types/Refs.hs

@@ -8,7 +8,7 @@ module HBS2.Data.Types.Refs
 import HBS2.Base58
 import HBS2.Hash
 import HBS2.Merkle
-import HBS2.Net.Proto.Types (Encryption)
+import HBS2.Net.Proto.Types
 import HBS2.Net.Auth.Credentials
 import HBS2.Prelude
 

hbs2-core/lib/HBS2/Net/Auth/AccessKey.hs

@@ -10,6 +10,7 @@ import HBS2.Data.Types
 import HBS2.Merkle
 import HBS2.Net.Auth.Credentials
 import HBS2.Net.Proto.Definition
+import HBS2.Net.Proto.Types
 import HBS2.Prelude.Plated
 
 import Codec.Serialise

hbs2-core/lib/HBS2/Net/Auth/Credentials.hs

@@ -28,11 +28,6 @@ import Data.Kind
 
 type family EncryptPubKey e :: Type
 
-data CryptoAction = Sign | Encrypt
-
-type family PubKey  ( a :: CryptoAction) e  :: Type
-type family PrivKey ( a :: CryptoAction) e  :: Type
-
 class Signatures e where
   type family Signature e :: Type
   makeSign   :: PrivKey 'Sign e -> ByteString  -> Signature e
@@ -207,4 +202,3 @@ instance IsEncoding (PubKey 'Encrypt e)
   => Pretty (KeyringEntry e) where
   pretty ke = fill 10 "pub-key:" <+> pretty (AsBase58 (Crypto.encode (view krPk ke)))
 
-

hbs2-core/lib/HBS2/Net/Dialog/Client.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE OverloadedLabels #-}
 {-# LANGUAGE StrictData #-}
 {-# LANGUAGE ImpredicativeTypes #-}
-module Dialog.Client where
+module HBS2.Net.Dialog.Client where
 
 -- import System.Clock
 -- import System.Timeout
@@ -34,8 +34,8 @@ import UnliftIO.Exception
 import UnliftIO.STM
 import UnliftIO.Timeout
 
-import Dialog.Core
+import HBS2.Net.Dialog.Core
-import Dialog.Helpers.Streaming
+import HBS2.Net.Dialog.Helpers.Streaming
 
 ---
 

hbs2-core/lib/HBS2/Net/Dialog/Core.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE StrictData #-}
 -- {-# LANGUAGE OverloadedLists #-}
 -- {-# LANGUAGE UndecidableInstances #-}
-module Dialog.Core where
+module HBS2.Net.Dialog.Core where
 
 -- import Data.ByteString.Builder as Builder
 -- import Data.ByteString.Builder.Internal as Builder
@@ -50,7 +50,7 @@ import UnliftIO.STM
 -- import HBS2.Base58
 import Data.ByteString.Base16 qualified as B16
 
-import Dialog.Helpers.List
+import HBS2.Net.Dialog.Helpers.List
 
 type Frames = Frames' ByteString
 newtype Frames' a = Frames { unFrames :: [a] }
@@ -78,8 +78,8 @@ tailAfterP p focus = fix \go -> \case
 
 ---
 
--- encodeFrames :: Frames -> ByteString
+encodeFrames :: Frames -> ByteString
-encodeFrames :: Foldable t => t ByteString -> ByteString
+-- encodeFrames :: Foldable t => t ByteString -> ByteString
 encodeFrames = F.toList >>> BSL.toStrict . runPut . \case
 
     []   -> pure ()

hbs2-core/lib/HBS2/Net/Dialog/Helpers/List.hs

@@ -1,4 +1,4 @@
-module Dialog.Helpers.List where
+module HBS2.Net.Dialog.Helpers.List where
 
 import Control.Monad.Trans.Writer.CPS qualified as W
 import Data.Functor.Identity

hbs2-core/lib/HBS2/Net/Dialog/Helpers/Streaming.hs

@@ -1,4 +1,4 @@
-module Dialog.Helpers.Streaming where
+module HBS2.Net.Dialog.Helpers.Streaming where
 
 import Control.Monad.Fix
 import Data.ByteString qualified as BS

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

@@ -3,8 +3,8 @@
 
 module HBS2.Net.Proto.Dialog
 ( module HBS2.Net.Proto.Dialog
-, module Dialog.Core
+, module HBS2.Net.Dialog.Core
-, module Dialog.Client
+, module HBS2.Net.Dialog.Client
 ) where
 
 import HBS2.Actors.Peer
@@ -34,8 +34,8 @@ import Streaming.Prelude qualified as S
 import UnliftIO.Exception
 import UnliftIO.STM
 
-import Dialog.Client
+import HBS2.Net.Dialog.Client
-import Dialog.Core
+import HBS2.Net.Dialog.Core
 
 ---
 

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

@@ -15,6 +15,7 @@ import HBS2.System.Logger.Simple
 
 import Crypto.Saltine.Core.Box qualified as Encrypt
 import Data.ByteString qualified as BS
+import Data.Hashable hiding (Hashed)
 import Data.String.Conversions (cs)
 import Lens.Micro.Platform
 
@@ -68,6 +69,10 @@ sendBeginEncryptionExchange creds ourpubkey peer = do
 
 data EncryptionHandshakeAdapter e m s = EncryptionHandshakeAdapter
   { encHandshake_considerPeerAsymmKey :: Peer e -> Maybe Encrypt.PublicKey -> m ()
+
+  , encAsymmetricKeyPair :: AsymmKeypair (Encryption e)
+
+  , encGetEncryptionKey :: EncryptionKeyIDKey e -> m (Maybe (CommonSecret (Encryption e)))
   }
 
 
@@ -88,11 +93,10 @@ encryptionHandshakeProto :: forall e s m .
     , Show (Nonce ())
     )
   => EncryptionHandshakeAdapter e m s
-  -> PeerEnv e
   -> EncryptionHandshake e
   -> m ()
 
-encryptionHandshakeProto EncryptionHandshakeAdapter{..} penv = \case
+encryptionHandshakeProto EncryptionHandshakeAdapter{..} = \case
 
   ResetEncryptionKeys -> do
       peer <- thatPeer proto
@@ -104,7 +108,7 @@ encryptionHandshakeProto EncryptionHandshakeAdapter{..} penv = \case
       encHandshake_considerPeerAsymmKey peer Nothing
 
       creds <- getCredentials @s
-      let ourpubkey = pubKeyFromKeypair @s $ view envAsymmetricKeyPair penv
+      ourpubkey <- pure $ pubKeyFromKeypair @s $ encAsymmetricKeyPair
       sendBeginEncryptionExchange @e creds ourpubkey peer
 
   BeginEncryptionExchange theirsign theirpubkey -> do
@@ -117,7 +121,7 @@ encryptionHandshakeProto EncryptionHandshakeAdapter{..} penv = \case
       -- взять свои ключи
       creds <- getCredentials @s
 
-      let ourpubkey = pubKeyFromKeypair @s $ view envAsymmetricKeyPair penv
+      ourpubkey <- pure $ pubKeyFromKeypair @s $ encAsymmetricKeyPair
 
       -- подписать нонс
       let sign = makeSign @s (view peerSignSk creds) ((cs . serialise) ourpubkey)

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

@@ -7,6 +7,7 @@ import HBS2.Actors.Peer
 import HBS2.Data.Types
 import HBS2.Events
 import HBS2.Net.Proto
+import HBS2.Net.Proto.Types
 import HBS2.Clock
 import HBS2.Net.Proto.Sessions
 import HBS2.Prelude.Plated
@@ -228,3 +229,36 @@ instance ( Serialise (PubKey 'Sign (Encryption e))
 
   => Serialise (PeerHandshake e)
 
+
+---
+
+data EncryptionKeyIDKey e =
+  EncryptionKeyIDKey
+  { ekeyIDPeerSignKey :: PubKey 'Sign (Encryption e)
+  , ekeyIDPeerNonce :: PeerNonce
+  }
+  deriving (Generic)
+
+deriving instance
+  ( Show (PubKey 'Sign (Encryption e))
+  , Show (Nonce ())
+  ) => Show (EncryptionKeyIDKey e)
+
+deriving instance
+  ( Eq (PubKey 'Sign (Encryption e))
+  , Eq (Nonce ())
+  ) => Eq (EncryptionKeyIDKey e)
+
+instance (
+    Hashable (PubKey 'Sign (Encryption e))
+  , Hashable (Nonce ())
+  ) => Hashable (EncryptionKeyIDKey e) where
+  hashWithSalt s EncryptionKeyIDKey {..} =
+      hashWithSalt s (ekeyIDPeerSignKey, ekeyIDPeerNonce)
+
+encryptionKeyIDKeyFromPeerData :: PeerData e -> EncryptionKeyIDKey e
+encryptionKeyIDKeyFromPeerData PeerData{..} =
+    EncryptionKeyIDKey
+        { ekeyIDPeerSignKey = _peerSignKey
+        , ekeyIDPeerNonce = _peerOwnNonce
+        }

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

@@ -28,6 +28,11 @@ import Control.Monad.Trans.Maybe
 -- e -> Transport (like, UDP or TChan)
 -- p -> L4 Protocol (like Ping/Pong)
 
+data CryptoAction = Sign | Encrypt
+
+type family PubKey  ( a :: CryptoAction) e  :: Type
+type family PrivKey ( a :: CryptoAction) e  :: Type
+
 type family Encryption e :: Type
 
 -- FIXME: move-to-a-crypto-definition-modules
@@ -206,4 +211,3 @@ instance FromStringMaybe (PeerAddr L4Proto) where
 instance Serialise L4Proto
 instance Serialise (PeerAddr L4Proto)
 
-

hbs2-core/test/DialogSpec.hs

@@ -14,8 +14,8 @@ import GHC.Generics (Generic)
 import Lens.Micro.Platform
 import System.IO
 
-import Dialog.Core
+import HBS2.Net.Dialog.Core
-import Dialog.Helpers.List
+import HBS2.Net.Dialog.Helpers.List
 
 newtype BSA = BSA { unBSA :: ByteString }
   deriving (Generic, Show)
@@ -57,3 +57,7 @@ testDialog = testGroup "dialog" $ buildList do
         property' "roundtrip encode Frames" \ xs ->
             (decodeFrames . encodeFrames) xs == Right xs
 
+        property' "encodeFrames is quasidistributive over mappend" \ (xs, ys) ->
+            BS.drop (BS.length (encodeFrames xs)) (encodeFrames (xs <> ys))
+                == encodeFrames ys
+

hbs2-peer/app/EncryptionKeys.hs

@@ -56,15 +56,14 @@ encryptionHandshakeWorker :: forall e m s .
     -- , HasCredentials s m
     )
   => PeerConfig
-  -> PeerEnv e
   -> PeerCredentials s
   -> EncryptionHandshakeAdapter e m s
   -> m ()
 
-encryptionHandshakeWorker pconf penv creds EncryptionHandshakeAdapter{..} = do
+encryptionHandshakeWorker pconf creds EncryptionHandshakeAdapter{..} = do
 
     -- e :: PeerEnv e <- ask
-    let ourpubkey = pubKeyFromKeypair @s $ _envAsymmetricKeyPair penv
+    ourpubkey <- pure $ pubKeyFromKeypair @s $ encAsymmetricKeyPair
 
     pl <- getPeerLocator @e
 
@@ -75,9 +74,9 @@ encryptionHandshakeWorker pconf penv creds EncryptionHandshakeAdapter{..} = do
 
         forM_ peers \peer -> do
             -- Только если ещё не знаем ключ ноды
-            mpeerData <- find (KnownPeerKey peer) id
+            mencKeyID <- (fmap . fmap) encryptionKeyIDKeyFromPeerData $
-            mkey <- liftIO do
+                find (KnownPeerKey peer) id
-                join <$> forM mpeerData \peerData -> getEncryptionKey penv peerData
+            mkey <- join <$> mapM encGetEncryptionKey mencKeyID
             case mkey of
                 Just _ -> pure ()
                 Nothing -> sendBeginEncryptionExchange @e creds ourpubkey peer

hbs2-peer/app/PeerMain.hs

@@ -448,7 +448,7 @@ runPeer :: forall e s . ( e ~ L4Proto
                         , FromStringMaybe (PeerAddr e)
                         , s ~ Encryption e
                         , HasStorage (PeerM e IO)
-                        ) => PeerOpts -> IO ()
+                        )=> PeerOpts -> IO ()
 
 runPeer opts = Exception.handle (\e -> myException e
                         >> performGC
@@ -574,32 +574,35 @@ runPeer opts = Exception.handle (\e -> myException e
            pure $ Just tcpEnv
 
   (proxy, penv) <- mdo
-      proxy <- newProxyMessaging mess tcp >>= \peer -> pure peer
+      proxy <- newProxyMessaging mess tcp >>= \proxy' -> pure proxy'
             { _proxy_getEncryptionKey = \peer -> do
-                  mpeerData <- withPeerM penv $ find (KnownPeerKey peer) id
+                  mencKeyID <- (fmap . fmap) encryptionKeyIDKeyFromPeerData $
-                  mkey <- join <$> forM mpeerData \peerData -> getEncryptionKey penv peerData
+                      withPeerM penv $ find (KnownPeerKey peer) id
+                  mkey <- join <$> forM mencKeyID \encKeyID ->
+                      getEncryptionKey proxy encKeyID
                   case mkey of
                       Nothing ->
                           trace1 $ "ENCRYPTION empty getEncryptionKey"
-                              <+> pretty peer <+> viaShow mpeerData
+                              <+> pretty peer <+> viaShow mencKeyID
                       Just k ->
                           trace1 $ "ENCRYPTION success getEncryptionKey"
-                              <+> pretty peer <+> viaShow mpeerData <+> viaShow k
+                              <+> pretty peer <+> viaShow mencKeyID <+> viaShow k
                   pure mkey
 
             , _proxy_clearEncryptionKey = \peer -> do
-                  mpeerData <- withPeerM penv $ find (KnownPeerKey peer) id
+                  mencKeyID <- (fmap . fmap) encryptionKeyIDKeyFromPeerData $
-                  forM_ mpeerData \peerData -> setEncryptionKey penv peer peerData Nothing
+                      withPeerM penv $ find (KnownPeerKey peer) id
+                  forM_ mencKeyID \encKeyID -> setEncryptionKey proxy peer encKeyID Nothing
                   -- deletePeerAsymmKey brains peer
-                  forM_ mpeerData \peerData ->
+                  forM_ mencKeyID \encKeyID ->
-                      deletePeerAsymmKey' brains (show peerData)
+                      deletePeerAsymmKey' brains (show encKeyID)
 
             , _proxy_sendResetEncryptionKeys = \peer -> withPeerM penv do
                   sendResetEncryptionKeys peer
 
             , _proxy_sendBeginEncryptionExchange = \peer -> withPeerM penv do
                   sendBeginEncryptionExchange pc
-                      ((pubKeyFromKeypair @s . view envAsymmetricKeyPair) penv)
+                      ((pubKeyFromKeypair @s . _proxy_asymmetricKeyPair) proxy)
                       peer
 
           }
@@ -687,27 +690,32 @@ runPeer opts = Exception.handle (\e -> myException e
                       ) => EncryptionHandshakeAdapter L4Proto m s
                   encryptionHshakeAdapter = EncryptionHandshakeAdapter
                     { encHandshake_considerPeerAsymmKey = \peer mpubkey -> withPeerM penv do
-                          mpeerData <- withPeerM penv $ find (KnownPeerKey peer) id
+                          mencKeyID <- (fmap . fmap) encryptionKeyIDKeyFromPeerData $
+                              withPeerM penv $ find (KnownPeerKey peer) id
                           case mpubkey of
                               Nothing -> do
-                                  -- trace $ "ENCRYPTION delete key" <+> pretty peer <+> viaShow mpeerData
+                                  -- trace $ "ENCRYPTION delete key" <+> pretty peer <+> viaShow mencKeyID
                                   -- deletePeerAsymmKey brains peer
-                                  forM_ mpeerData \peerData ->
+                                  forM_ mencKeyID \encKeyID ->
-                                      deletePeerAsymmKey' brains (show peerData)
+                                      deletePeerAsymmKey' brains (show encKeyID)
                               Just pk -> do
                                   -- emit PeerAsymmInfoKey (PeerAsymmPubKey peer pk)
                                   let symmk = genCommonSecret @s
-                                          (privKeyFromKeypair @s (view envAsymmetricKeyPair penv))
+                                          (privKeyFromKeypair @s (_proxy_asymmetricKeyPair proxy))
                                           pk
-                                  case mpeerData of
+                                  case mencKeyID of
                                       Nothing -> do
                                           -- insertPeerAsymmKey brains peer pk symmk
                                           -- insertPeerAsymmKey' brains (show peer) pk symmk
-                                          trace $ "ENCRYPTION can not store key. No peerData"
+                                          trace $ "ENCRYPTION can not store key. No encKeyID"
-                                              <+> pretty peer <+> viaShow mpeerData
+                                              <+> pretty peer <+> viaShow mencKeyID
-                                      Just peerData -> do
+                                      Just encKeyID -> do
-                                          liftIO $ setEncryptionKey penv peer peerData (Just symmk)
+                                          liftIO $ setEncryptionKey proxy peer encKeyID (Just symmk)
-                                          insertPeerAsymmKey' brains (show peerData) pk symmk
+                                          insertPeerAsymmKey' brains (show encKeyID) pk symmk
+
+                    , encAsymmetricKeyPair = _proxy_asymmetricKeyPair proxy
+
+                    , encGetEncryptionKey = liftIO . getEncryptionKey proxy
 
                     }
 
@@ -724,11 +732,12 @@ runPeer opts = Exception.handle (\e -> myException e
               addPeers @e pl ps
 
               subscribe @e PeerExpiredEventKey \(PeerExpiredEvent peer {-mpeerData-}) -> liftIO do
-                  mpeerData <- withPeerM penv $ find (KnownPeerKey peer) id
+                  mencKeyID <- (fmap . fmap) encryptionKeyIDKeyFromPeerData $
-                  forM_ mpeerData \peerData -> setEncryptionKey penv peer peerData Nothing
+                               withPeerM penv $ find (KnownPeerKey peer) id
+                  forM_ mencKeyID \encKeyID -> setEncryptionKey proxy peer encKeyID Nothing
                   -- deletePeerAsymmKey brains peer
-                  forM_ mpeerData \peerData ->
+                  forM_ mencKeyID \encKeyID ->
-                      deletePeerAsymmKey' brains (show peerData)
+                      deletePeerAsymmKey' brains (show encKeyID)
 
               subscribe @e PeerAnnounceEventKey $ \(PeerAnnounceEvent pip nonce) -> do
                unless (nonce == pnonce) $ do
@@ -871,7 +880,7 @@ runPeer opts = Exception.handle (\e -> myException e
                 peerThread "blockDownloadLoop" (blockDownloadLoop denv)
 
                 peerThread "encryptionHandshakeWorker"
-                    (EncryptionKeys.encryptionHandshakeWorker @e conf penv pc encryptionHshakeAdapter)
+                    (EncryptionKeys.encryptionHandshakeWorker @e conf pc encryptionHshakeAdapter)
 
                 let tcpProbeWait :: Timeout 'Seconds
                     tcpProbeWait = (fromInteger . fromMaybe 300) (cfgValue @PeerTcpProbeWaitKey conf)
@@ -991,7 +1000,7 @@ runPeer opts = Exception.handle (\e -> myException e
                     , makeResponse (blockChunksProto adapter)
                     , makeResponse blockAnnounceProto
                     , makeResponse (withCredentials @e pc . peerHandShakeProto hshakeAdapter penv)
-                    , makeResponse (withCredentials @e pc . encryptionHandshakeProto encryptionHshakeAdapter penv)
+                    , makeResponse (withCredentials @e pc . encryptionHandshakeProto encryptionHshakeAdapter)
                     , makeResponse (peerExchangeProto pexFilt)
                     , makeResponse (refLogUpdateProto reflogAdapter)
                     , makeResponse (refLogRequestProto reflogReqAdapter)

hbs2-peer/app/PeerMain/DialogCliCommand.hs

@@ -2,81 +2,32 @@
 
 module PeerMain.DialogCliCommand where
 
--- import Data.Generics.Labels
+import Data.Generics.Labels
--- import Data.Generics.Product.Fields
+import Data.Generics.Product.Fields
 import HBS2.Actors.Peer
-import HBS2.Base58
-import HBS2.Clock
-import HBS2.Net.Proto.RefLog (RefLogKey(..))
-import HBS2.Defaults
-import HBS2.Events
-import HBS2.Hash
-import HBS2.Merkle
-import HBS2.Net.Auth.Credentials
 import HBS2.Net.IP.Addr
-import HBS2.Net.Messaging
-import HBS2.Net.Messaging.TCP
 import HBS2.Net.Messaging.UDP
-import HBS2.Net.PeerLocator
 import HBS2.Net.Proto
-import HBS2.Net.Proto.Definition
 import HBS2.Net.Proto.Dialog
-import HBS2.Net.Proto.Peer
-import HBS2.Net.Proto.PeerAnnounce
-import HBS2.Net.Proto.PeerExchange
-import HBS2.Net.Proto.PeerMeta
-import HBS2.Net.Proto.RefLog
-import HBS2.Net.Proto.Sessions
-import HBS2.Net.Proto.Types
 import HBS2.OrDie
 import HBS2.Prelude
-import HBS2.Prelude.Plated
-import HBS2.Storage.Simple
 import HBS2.System.Logger.Simple hiding (info)
-import HBS2.System.Logger.Simple qualified as Log
 
-import BlockDownload
-import BlockHttpDownload
-import Bootstrap
-import Brains
-import CheckMetrics
-import DownloadQ
-import HttpWorker
 import PeerConfig
-import PeerInfo
-import PeerMeta
-import PeerTypes
-import ProxyMessaging
-import RefLog (reflogWorker)
-import RefLog qualified
 import RPC
 
-import Control.Monad
-import Control.Monad.IO.Unlift
-import Control.Monad.Reader
 import Control.Monad.Trans.Cont
-import Control.Monad.Trans.Maybe
-import Crypto.Saltine.Core.Box qualified as Encrypt
-import Data.ByteString qualified as BS
-import Data.ByteString.Char8 qualified as BS8
-import Data.ByteString.Lazy (ByteString)
-import Data.ByteString.Lazy qualified as LBS
 import Data.Default
 import Data.Function
 import Data.Functor
+import Data.Kind
 import Data.List qualified as List
-import Data.Map.Strict qualified as Map
-import Data.Maybe
-import Data.Monoid qualified as Monoid
-import Data.Set qualified as Set
 import Data.String.Conversions as X (cs)
 import Data.Void (absurd, Void)
 import Lens.Micro.Platform
 import Network.Socket
 import Options.Applicative
-import Streaming as S
 import Streaming.Prelude qualified as S
-import System.Directory
 import UnliftIO.Async
 import UnliftIO.Concurrent
 import UnliftIO.Exception as U
@@ -84,7 +35,6 @@ import UnliftIO.Resource
 
 -- import System.FilePath.Posix
 import System.IO
-import System.Exit
 
 
 pDialog :: Parser (IO ())
@@ -95,16 +45,16 @@ pDialog = hsubparser $ mempty
 confOpt :: Parser FilePath
 confOpt = strOption ( long "config"  <> short 'c' <> help "config" )
 
-data OptInitial (f :: * -> *) a b = OptInitial { unOptInitial :: f a }
+newtype OptInitial (f :: Type -> Type) a b = OptInitial { unOptInitial :: f a }
   deriving (Generic, Show)
 
-data OptResolved (f :: * -> *) a b = OptResolved { unOptResolved :: b }
+newtype OptResolved (f :: Type -> Type) a b = OptResolved { unOptResolved :: b }
   deriving (Generic, Show)
 
 type DialOptInitial = DialOpt OptInitial
 type DialOptResolved = DialOpt OptResolved
 
-data DialOpt (f :: (* -> *) -> * -> * -> *) = DialOpt
+data DialOpt (f :: (Type -> Type) -> Type -> Type -> Type) = DialOpt
   { dialOptConf :: f Maybe FilePath PeerConfig
   , dialOptAddr :: f Maybe String (Peer L4Proto)
   }
@@ -133,7 +83,7 @@ resolveDialOpt dopt = do
         `orDieM` "Dial endpoint not set"
 
     as <- parseAddrUDP (cs saddr) <&> fmap (fromSockAddr @'UDP . addrAddress)
-    peer <- (headMay $ List.sortBy (compare `on` addrPriority) as)
+    peer <- headMay (List.sortBy (compare `on` addrPriority) as)
         `orDieM` "Can't parse Dial endpoint"
 
     pure DialOpt

hbs2-peer/app/PeerMain/PeerDialog.hs

@@ -6,7 +6,7 @@ import Data.Bool
 import Data.ByteString qualified as BS
 import Data.Map qualified as Map
 
-import Dialog.Core
+import HBS2.Net.Dialog.Core
 import HBS2.Net.Proto.Types
 
 

hbs2-peer/app/PeerTypes.hs

@@ -415,15 +415,9 @@ mkPeerMeta conf penv = do
             . fromStringMay @(PeerAddr L4Proto)
           )
           =<< cfgValue @PeerListenTCPKey conf
-    -- let useEncryption = True  -- move to config
     annMetaFromPeerMeta . PeerMeta $ W.execWriter do
       mHttpPort `forM` \p -> elem "http-port" (TE.encodeUtf8 . Text.pack . show $ p)
       mTcpPort `forM` \p -> elem "listen-tcp" (TE.encodeUtf8 . Text.pack . show $ p)
-      -- when useEncryption do
-      --     elem "ekey" (TE.encodeUtf8 . Text.pack . show $
-      --         (Encrypt.publicKey . _envAsymmetricKeyPair) penv
-      --         -- mayby sign this pubkey by node key ?
-      --         )
 
   where
     elem k = W.tell . L.singleton . (k ,)

hbs2-peer/app/ProxyMessaging.hs

@@ -4,6 +4,9 @@ module ProxyMessaging
   , newProxyMessaging
   , runProxyMessaging
   , sendToPlainProxyMessaging
+  , getEncryptionKey
+  , setEncryptionKey
+  , encryptionKeyIDKeyFromPeerData
   ) where
 
 import HBS2.Prelude.Plated
@@ -34,6 +37,7 @@ import Control.Monad.Trans.Maybe
 import Data.ByteString (ByteString)
 import Data.ByteString qualified as BS
 import Data.ByteString.Lazy qualified as LBS
+import Data.Hashable hiding (Hashed)
 import Data.Maybe
 import Data.String.Conversions (cs)
 import Data.List qualified as L
@@ -41,6 +45,10 @@ import Data.Map (Map)
 import Data.Map qualified as Map
 import Lens.Micro.Platform as Lens
 import Control.Monad
+import Data.HashMap.Strict (HashMap)
+import Data.HashMap.Strict qualified as HashMap
+
+import HBS2.Data.Types.Peer
 
 -- TODO: protocol-encryption-goes-here
 
@@ -54,6 +62,9 @@ data ProxyMessaging =
   , _proxy_clearEncryptionKey :: Peer L4Proto -> IO ()
   , _proxy_sendResetEncryptionKeys :: Peer L4Proto -> IO ()
   , _proxy_sendBeginEncryptionExchange :: Peer L4Proto -> IO ()
+
+  , _proxy_asymmetricKeyPair :: AsymmKeypair (Encryption L4Proto)
+  , _proxy_encryptionKeys :: TVar (HashMap (EncryptionKeyIDKey L4Proto) (CommonSecret (Encryption L4Proto)))
   }
 
 -- 1 нода X создаёт себе Encrypt.Keypair
@@ -78,8 +89,36 @@ newProxyMessaging u t = liftIO do
     let _proxy_sendResetEncryptionKeys = const (pure ())
     let _proxy_sendBeginEncryptionExchange = const (pure ())
 
+    _proxy_asymmetricKeyPair <- asymmNewKeypair @(Encryption L4Proto)
+    _proxy_encryptionKeys <- liftIO (newTVarIO mempty)
+
     pure ProxyMessaging {..}
 
+---
+
+setEncryptionKey ::
+  ( Hashable (PubKey 'Sign (Encryption L4Proto))
+  , Hashable PeerNonce
+  , Show (PubKey 'Sign (Encryption L4Proto))
+  , Show PeerNonce
+  , Show (CommonSecret (Encryption L4Proto))
+  , Show (EncryptionKeyIDKey L4Proto)
+  ) => ProxyMessaging -> Peer L4Proto -> EncryptionKeyIDKey L4Proto -> Maybe (CommonSecret (Encryption L4Proto)) -> IO ()
+setEncryptionKey proxy peer pd msecret = do
+    atomically $ modifyTVar' (_proxy_encryptionKeys proxy) $ Lens.at pd .~ msecret
+    case msecret of
+        Nothing -> trace $ "ENCRYPTION delete key" <+> pretty peer <+> viaShow pd
+        Just k ->  trace $ "ENCRYPTION store key" <+> pretty peer <+> viaShow pd <+> viaShow k
+
+getEncryptionKey ::
+  ( Hashable (PubKey 'Sign (Encryption L4Proto))
+  , Hashable PeerNonce
+  ) => ProxyMessaging -> EncryptionKeyIDKey L4Proto -> IO (Maybe (CommonSecret (Encryption L4Proto)))
+getEncryptionKey proxy pd =
+    readTVarIO (_proxy_encryptionKeys proxy) <&> preview (Lens.ix pd)
+
+---
+
 runProxyMessaging :: forall m . MonadIO  m
                   => ProxyMessaging
                   -> m ()
@@ -103,7 +142,6 @@ runProxyMessaging env = liftIO do
 
   liftIO $ mapM_ waitCatch [u,t]
 
-
 instance Messaging ProxyMessaging L4Proto LBS.ByteString where
 
   sendTo = sendToProxyMessaging