Squashed commit of the following:

commit cc3d5a357eee5c0e01f530808f8122f83b5103a2
Author: Dmitry Zuikov <dzuikov@gmail.com>
Date:   Tue Jul 4 15:29:09 2023 +0300

    fixme

commit abae50a7895fdfc70e3a9204288a1af1a00f1c77
Author: Sergey Ivanov <ivanovs-4@yandex.ru>
Date:   Mon Jul 3 20:05:08 2023 +0400

    encryption debug -> traces

commit e8cab85da295ad81896726bf41f118bc2eb6e79e
Author: Sergey Ivanov <ivanovs-4@yandex.ru>
Date:   Mon Jul 3 00:21:34 2023 +0400

    bus encryption fixed

commit cbb3e796b0d919d6d425a5d8c669cfce2ed02182
Merge: a740db8 55cdf97
Author: Sergey Ivanov <ivanovs-4@yandex.ru>
Date:   Sat Jul 1 23:17:52 2023 +0400

    Merge branch 'master' into iv/bus-crypt

commit a740db82351dcbc40604413df9af210212e1cbc1
Author: Sergey Ivanov <ivanovs-4@yandex.ru>
Date:   Wed Jun 21 16:08:05 2023 +0400

    drop one traceShowId uasge

commit 82de8d8c675cf21e732dc8db9b64139c7c2407ad
Author: Sergey Ivanov <ivanovs-4@yandex.ru>
Date:   Wed Jun 21 13:33:34 2023 +0400

    Edit README.md fix typo

commit ec4dc7733215f19009da9334b82fd568e16eb143
Author: Sergey Ivanov <ivanovs-4@yandex.ru>
Date:   Wed Jun 21 13:32:54 2023 +0400

    Rename deserialiseTrace -> deserialiseCustom

commit 863394449798d8c534c58dc2d69add3e5a807e56
Author: Sergey Ivanov <ivanovs-4@yandex.ru>
Date:   Thu Jun 15 05:37:52 2023 +0400

    PR bus-crypt

commit 78dd65959906944935f99371ee973fc6c2c659b9
Author: Sergey Ivanov <ivanovs-4@yandex.ru>
Date:   Thu Jun 15 05:33:13 2023 +0400

    Drop unused lines

commit 9736077a96061c62e928b657e7c7558f9172636c
Author: Sergey Ivanov <ivanovs-4@yandex.ru>
Date:   Thu Jun 15 05:24:33 2023 +0400

    Encryption works

commit c69aede965242281b525c088e1f27708a6741651
Author: Sergey Ivanov <ivanovs-4@yandex.ru>
Date:   Wed Jun 14 20:52:48 2023 +0400

    wip

commit 88fc2aac5b4fc1d452e74bf99213a57dad09b1c3
Author: Sergey Ivanov <ivanovs-4@yandex.ru>
Date:   Wed Jun 14 15:52:32 2023 +0400

    Test roundtrip combineNonceBS/extractNonce

commit 2d2f6945f4c917347c8f30e195764e2b0837fb25
Author: Sergey Ivanov <ivanovs-4@yandex.ru>
Date:   Tue Jun 13 14:08:56 2023 +0400

    wip

commit 31466fd036d74d8c4b769c7ffb0fa9dfda03eb26
Author: Sergey Ivanov <ivanovs-4@yandex.ru>
Date:   Tue Jun 13 10:03:15 2023 +0400

    trace locked requests

commit 85eb68a6747fb307c07fb0fcf681118250b37fab
Author: Sergey Ivanov <ivanovs-4@yandex.ru>
Date:   Mon Jun 12 20:02:32 2023 +0400

    added Show instances

commit 74383bd7db9dd6838b4d026a3997c5c5b4799fa4
Author: Sergey Ivanov <ivanovs-4@yandex.ru>
Date:   Mon Jun 12 09:56:14 2023 +0400

    DEBUG

commit d62b30dbcdae6584f78cc2b6d8a801ff46cfdfa8
Author: Sergey Ivanov <ivanovs-4@yandex.ru>
Date:   Sun Jun 11 18:28:49 2023 +0400

    wip

commit 78b3f24ae1c4b632756f3a28873f4d03bbaa1330
Author: Sergey Ivanov <ivanovs-4@yandex.ru>
Date:   Sun Jun 11 08:45:58 2023 +0400

    trace encrypted receiveing

commit 93e2b9f7a7c2b579e5e46b6329a6509b8e5119de
Author: Sergey Ivanov <ivanovs-4@yandex.ru>
Date:   Sat Jun 10 16:57:59 2023 +0400

    wip

commit 4686274d0fb401b722fca10ec0c2dbee00a4c68a
Author: Sergey Ivanov <ivanovs-4@yandex.ru>
Date:   Fri Jun 9 23:38:56 2023 +0400

    Use PeerDataExt

commit 0c24c2702b47db262fa086efb6cff108b8ce28e8
Author: Sergey Ivanov <ivanovs-4@yandex.ru>
Date:   Thu Jun 8 03:04:39 2023 +0400

    Encrypted Handshake

commit 789536f20bc4f95320d2a4779a4a5b06d52b98f2
Author: Sergey Ivanov <ivanovs-4@yandex.ru>
Date:   Wed Jun 7 00:56:34 2023 +0400

    Fixed fillPeerMeta timeout algorithm

commit d52ac19777ba1c47f1123c5452309da4391ca21f
Author: Sergey Ivanov <ivanovs-4@yandex.ru>
Date:   Fri Jun 2 01:50:17 2023 +0400

    wip

commit ea6833f812f9f137880229547622a3cf1ae55222
Author: Sergey Ivanov <ivanovs-4@yandex.ru>
Date:   Tue May 30 22:14:25 2023 +0400

    wip

commit 4ffdfc60ccc5c053da2d81ea16847f25f14c6220
Author: Sergey Ivanov <ivanovs-4@yandex.ru>
Date:   Sat May 27 21:42:01 2023 +0400

    Symmetrical encryption in ProxyMessaging

commit 7cd1214e9e00901fcd3d9e2966348dd800ab4119
Author: Sergey Ivanov <ivanovs-4@yandex.ru>
Date:   Fri May 26 15:03:43 2023 +0400

    pex monitor

README.md

@@ -258,7 +258,7 @@ keeyring "/path/to/new.key"
 5. Add git remote and push
 
 ```
-git add mynerepo hbs2://eq5ZFnB9HQTMTeYasYC3pSZLedcP7Zp2eDkJNdehVVk
+git remote add mynerepo hbs2://eq5ZFnB9HQTMTeYasYC3pSZLedcP7Zp2eDkJNdehVVk
 git push mynerepo
 ```
 

docs/devlog.md

@@ -1295,3 +1295,11 @@ PR: implement-http-block-download-worker
 PR: tcp-pex
   branch: iv/tcp-pex_3
   commit: f1de7c58d5dc36dec5c318a3297733791de9a3d8
+
+## 2023-06-15
+
+PR: bus-crypt
+  branch: iv/bus-crypt
+  Шифрование протокола общения нод. 
+  Обмен асимметричными публичными ключами выполняется на стадии хэндшейка в ping/pong.
+  Для шифрования данных создаётся симметричный ключ по diffie-hellman.

hbs2-core/hbs2-core.cabal

@@ -53,6 +53,7 @@ common shared-properties
                      , MultiParamTypeClasses
                      , OverloadedStrings
                      , QuasiQuotes
+                     , RecordWildCards
                      , ScopedTypeVariables
                      , StandaloneDeriving
                      , TupleSections
@@ -69,6 +70,7 @@ library
                     , HBS2.Actors.Peer
                     , HBS2.Base58
                     , HBS2.Clock
+                    , HBS2.Crypto
                     , HBS2.Data.Detect
                     , HBS2.Data.Types
                     , HBS2.Data.Types.Crypto
@@ -149,9 +151,11 @@ library
                     , stm
                     , stm-chans
                     , streaming
+                    , string-conversions
                     , suckless-conf
                     , temporary
                     , text
+                    , time
                     , transformers
                     , uniplate
                     , unordered-containers
@@ -188,17 +192,21 @@ test-suite test
         , mtl
         , prettyprinter
         , QuickCheck
+        , quickcheck-instances
         , random
         , safe
         , serialise
         , stm
         , streaming
         , tasty
+        , tasty-quickcheck
         , tasty-hunit
         , transformers
         , uniplate
         , vector
+        , saltine
         , simple-logger
+        , string-conversions
 
 
 

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

@@ -10,6 +10,7 @@ import HBS2.Clock
 import HBS2.Defaults
 import HBS2.Events
 import HBS2.Hash
+import HBS2.Net.Auth.Credentials
 import HBS2.Net.Messaging
 import HBS2.Net.PeerLocator
 import HBS2.Net.PeerLocator.Static
@@ -17,7 +18,9 @@ import HBS2.Net.Proto
 import HBS2.Net.Proto.Sessions
 import HBS2.Prelude.Plated
 import HBS2.Storage
+import HBS2.System.Logger.Simple
 
+import Control.Applicative
 import Control.Monad.Trans.Maybe
 import Control.Concurrent.Async
 import Control.Monad.Reader
@@ -36,10 +39,13 @@ import Data.HashMap.Strict qualified as HashMap
 import Control.Concurrent.STM.TVar
 import Control.Concurrent.STM
 import Data.Hashable (hash)
+import Crypto.Saltine.Core.SecretBox qualified as SBox  -- Симметричное шифрование с nonce без подписи
+import Crypto.Saltine.Core.Box qualified as Encrypt  -- Асимметричное шифрование без подписи
 
 import Codec.Serialise (serialise, deserialiseOrFail)
 
 import Prettyprinter hiding (pipe)
+-- import Debug.Trace
 
 
 data AnyStorage = forall zu . ( Block ByteString ~ ByteString
@@ -148,6 +154,7 @@ 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)
   }
 
 newtype PeerM e m a = PeerM { fromPeerM :: ReaderT (PeerEnv e) m a }
@@ -278,14 +285,16 @@ instance (MonadIO m, HasProtocol e p, Hashable (Encoded e))
       pure (not here)
 
 instance ( MonadIO m
-         , HasProtocol e p
+         , HasProtocol e msg
          , HasFabriq e m -- (PeerM e m)
          , HasOwnPeer e m
          , PeerMessaging e
-         , HasTimeLimits e p m
+         , HasTimeLimits e msg m
-         ) => Request e p m where
+         , Show (Peer e)
-  request p msg = do
+         , Show msg
-    let proto = protoId @e @p (Proxy @p)
+         ) => Request e msg m where
+  request peer_e msg = do
+    let proto = protoId @e @msg (Proxy @msg)
     pipe <- getFabriq @e
     me <- ownPeer @e
 
@@ -294,12 +303,17 @@ instance ( MonadIO m
     --
     -- TODO: where to store the timeout?
     -- TODO: where the timeout come from?
-    -- withTimeLimit @e @p p msg $ do
+    -- withTimeLimit @e @msg peer_e msg $ do
       -- liftIO $ print "request!"
-    allowed <- tryLockForPeriod p msg
+    allowed <- tryLockForPeriod peer_e msg
+
+    when (not allowed) do
+      trace $ "REQUEST: not allowed to send" <+> viaShow msg
 
     when allowed do
-      sendTo pipe (To p) (From me) (AnyMessage @(Encoded e) @e proto (encode msg))
+      sendTo pipe (To peer_e) (From me) (AnyMessage @(Encoded e) @e proto (encode msg))
+      -- trace $ "REQUEST: after sendTo" <+> viaShow peer_e <+> viaShow msg
+
 
 
 instance ( Typeable (EventHandler e p (PeerM e IO))
@@ -383,6 +397,7 @@ newPeerEnv :: forall e m . ( MonadIO m
                            , Ord (Peer e)
                            , Pretty (Peer e)
                            , HasNonces () m
+                           , Asymm (Encryption e)
                            )
           => AnyStorage
           -> Fabriq e
@@ -390,18 +405,20 @@ newPeerEnv :: forall e m . ( MonadIO m
           -> m (PeerEnv e)
 
 newPeerEnv s bus p = do
-
+  let _envSelf      = p
-  pl <- AnyPeerLocator <$> newStaticPeerLocator @e mempty
+  _envPeerNonce     <- newNonce @()
-
+  let _envFab       = bus
-  nonce <- newNonce @()
+  let _envStorage   = s
-
+  _envPeerLocator   <- AnyPeerLocator <$> newStaticPeerLocator @e mempty
-  PeerEnv p nonce bus s pl <$> newPipeline defProtoPipelineSize
+  _envDeferred      <- newPipeline defProtoPipelineSize
-                           <*> liftIO (Cache.newCache (Just defCookieTimeout))
+  _envSessions      <- liftIO (Cache.newCache (Just defCookieTimeout))
-                           <*> liftIO (newTVarIO mempty)
+  _envEvents        <- liftIO (newTVarIO mempty)
-                           <*> liftIO (Cache.newCache (Just defCookieTimeout))
+  _envExpireTimes   <- liftIO (Cache.newCache (Just defCookieTimeout))
-                           <*> liftIO (newTVarIO mempty)
+  _envSweepers      <- liftIO (newTVarIO mempty)
-                           <*> liftIO (Cache.newCache (Just defRequestLimit))
+  _envReqMsgLimit   <- liftIO (Cache.newCache (Just defRequestLimit))
-                           <*> liftIO (Cache.newCache (Just defRequestLimit))
+  _envReqProtoLimit <- liftIO (Cache.newCache (Just defRequestLimit))
+  _envAsymmetricKeyPair <- asymmNewKeypair @(Encryption e)
+  pure PeerEnv {..}
 
 runPeerM :: forall e m . ( MonadIO m
                          , HasPeer e

hbs2-core/lib/HBS2/Clock.hs

@@ -10,6 +10,7 @@ import Control.Monad.IO.Class
 import Data.Fixed
 import Data.Int (Int64)
 import Data.Proxy
+import Data.Time
 import Prettyprinter
 import System.Clock
 
@@ -35,6 +36,9 @@ class IsTimeout a where
   toTimeSpec    :: Timeout a -> TimeSpec
   toTimeSpec x = fromNanoSecs (fromIntegral (toNanoSeconds x))
 
+toNominalDiffTime :: IsTimeout t => Timeout t -> NominalDiffTime
+toNominalDiffTime = fromRational . (/ (10^6)) . fromIntegral . toMicroSeconds
+
 class IsTimeout a => MonadPause a m where
   pause :: Timeout a -> m ()
 

hbs2-core/lib/HBS2/Crypto.hs

@@ -0,0 +1,28 @@
+module HBS2.Crypto where
+
+import Control.Monad
+import Crypto.Saltine.Class as SCl
+import Crypto.Saltine.Core.Box qualified as Encrypt
+import Crypto.Saltine.Internal.Box qualified as Encrypt
+
+import Data.ByteString (ByteString)
+import Data.ByteString qualified as BS
+import Data.ByteString.Lazy qualified as LBS
+import Data.String.Conversions (cs)
+
+
+combineNonceBS :: Encrypt.Nonce -> ByteString -> ByteString
+combineNonceBS n = (SCl.encode n <>)
+
+extractNonce :: ByteString -> Maybe (Encrypt.Nonce, ByteString)
+extractNonce bs = do
+    let (p,bs') = BS.splitAt Encrypt.box_noncebytes bs
+    guard (BS.length p == Encrypt.box_noncebytes)
+    nonce <- SCl.decode p
+    pure (nonce, bs')
+
+boxAfterNMLazy :: Encrypt.CombinedKey -> Encrypt.Nonce -> LBS.ByteString -> LBS.ByteString
+boxAfterNMLazy k n = cs . combineNonceBS n . Encrypt.boxAfterNM k n . cs
+
+boxOpenAfterNMLazy :: Encrypt.CombinedKey -> Encrypt.Nonce -> ByteString -> Maybe LBS.ByteString
+boxOpenAfterNMLazy k n = fmap cs . Encrypt.boxOpenAfterNM k n

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

@@ -38,6 +38,15 @@ class Signatures e where
   makeSign   :: PrivKey 'Sign e -> ByteString  -> Signature e
   verifySign :: PubKey 'Sign e  -> Signature e -> ByteString -> Bool
 
+class AsymmPubKey e ~ PubKey 'Encrypt e => Asymm e where
+  type family AsymmKeypair e :: Type
+  type family AsymmPrivKey e :: Type
+  type family AsymmPubKey e :: Type
+  type family CommonSecret e :: Type
+  asymmNewKeypair :: MonadIO m => m (AsymmKeypair e)
+  privKeyFromKeypair :: AsymmKeypair e -> AsymmPrivKey e
+  pubKeyFromKeypair :: AsymmKeypair e -> AsymmPubKey e
+  genCommonSecret :: Asymm e => AsymmPrivKey e -> AsymmPubKey e -> CommonSecret e
 
 class HasCredentials s m where
   getCredentials :: m (PeerCredentials s)

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

@@ -42,6 +42,8 @@ instance Serialise (BlockAnnounceInfo e)
 data BlockAnnounce e = BlockAnnounce PeerNonce (BlockAnnounceInfo e)
                        deriving stock (Generic)
 
+deriving instance (Show (Nonce ())) => Show (BlockAnnounce e)
+
 instance Serialise PeerNonce => Serialise (BlockAnnounce e)
 
 

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

@@ -51,14 +51,14 @@ data BlockChunksI e m =
 
 
 data BlockChunks e = BlockChunks (Cookie e) (BlockChunksProto e)
-                     deriving stock (Generic)
+                     deriving stock (Generic, Show)
 
 data BlockChunksProto e = BlockGetAllChunks (Hash HbSync) ChunkSize
                         | BlockGetChunks (Hash HbSync) ChunkSize Word32 Word32
                         | BlockNoChunks
                         | BlockChunk ChunkNum ByteString
                         | BlockLost
-                        deriving stock (Generic)
+                        deriving stock (Generic, Show)
 
 
 instance HasCookie e (BlockChunks e) where

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

@@ -21,12 +21,12 @@ import HBS2.Net.Proto.PeerMeta
 import HBS2.Net.Proto.RefLog
 import HBS2.Prelude
 
+import Control.Monad
 import Data.Functor
 import Data.ByteString.Lazy (ByteString)
 import Data.ByteString qualified as BS
 import Codec.Serialise (deserialiseOrFail,serialise)
 
-import Crypto.Saltine.Core.Box qualified as Crypto
 import Crypto.Saltine.Class qualified as Crypto
 import Crypto.Saltine.Core.Sign qualified as Sign
 import Crypto.Saltine.Core.Box qualified as Encrypt
@@ -52,10 +52,15 @@ instance Serialise Encrypt.PublicKey
 instance Serialise Sign.SecretKey
 instance Serialise Encrypt.SecretKey
 
+deserialiseCustom :: (Serialise a, MonadPlus m) => ByteString -> m a
+deserialiseCustom = either (const mzero) pure . deserialiseOrFail
+-- deserialiseCustom = either (\msg -> trace ("deserialiseCustom: " <> show msg) mzero) pure . deserialiseOrFail
+-- deserialiseCustom = either (error . show) pure . deserialiseOrFail
+
 instance HasProtocol L4Proto (BlockInfo L4Proto) where
   type instance ProtocolId (BlockInfo L4Proto) = 1
   type instance Encoded L4Proto = ByteString
-  decode = either (const Nothing) Just . deserialiseOrFail
+  decode = deserialiseCustom
   encode = serialise
 
   -- FIXME: requestMinPeriod-breaks-fast-block-download
@@ -65,7 +70,7 @@ instance HasProtocol L4Proto (BlockInfo L4Proto) where
 instance HasProtocol L4Proto (BlockChunks L4Proto) where
   type instance ProtocolId (BlockChunks L4Proto) = 2
   type instance Encoded L4Proto = ByteString
-  decode = either (const Nothing) Just . deserialiseOrFail
+  decode = deserialiseCustom
   encode = serialise
 
 instance Expires (SessionKey L4Proto (BlockChunks L4Proto)) where
@@ -74,13 +79,13 @@ instance Expires (SessionKey L4Proto (BlockChunks L4Proto)) where
 instance HasProtocol L4Proto (BlockAnnounce L4Proto) where
   type instance ProtocolId (BlockAnnounce L4Proto) = 3
   type instance Encoded L4Proto = ByteString
-  decode = either (const Nothing) Just . deserialiseOrFail
+  decode = deserialiseCustom
   encode = serialise
 
 instance HasProtocol L4Proto (PeerHandshake L4Proto) where
   type instance ProtocolId (PeerHandshake L4Proto) = 4
   type instance Encoded L4Proto = ByteString
-  decode = either (const Nothing) Just . deserialiseOrFail
+  decode = deserialiseCustom
   encode = serialise
 
   requestPeriodLim = ReqLimPerProto 0.5
@@ -88,19 +93,19 @@ instance HasProtocol L4Proto (PeerHandshake L4Proto) where
 instance HasProtocol L4Proto (PeerAnnounce L4Proto) where
   type instance ProtocolId (PeerAnnounce L4Proto) = 5
   type instance Encoded L4Proto = ByteString
-  decode = either (const Nothing) Just . deserialiseOrFail
+  decode = deserialiseCustom
   encode = serialise
 
 instance HasProtocol L4Proto (PeerExchange L4Proto) where
   type instance ProtocolId (PeerExchange L4Proto) = 6
   type instance Encoded L4Proto = ByteString
-  decode = either (const Nothing) Just . deserialiseOrFail
+  decode = deserialiseCustom
   encode = serialise
 
 instance HasProtocol L4Proto (RefLogUpdate L4Proto) where
   type instance ProtocolId (RefLogUpdate L4Proto) = 7
   type instance Encoded L4Proto = ByteString
-  decode = either (const Nothing) Just . deserialiseOrFail
+  decode = deserialiseCustom
   encode = serialise
 
   requestPeriodLim = ReqLimPerMessage 600
@@ -108,13 +113,13 @@ instance HasProtocol L4Proto (RefLogUpdate L4Proto) where
 instance HasProtocol L4Proto (RefLogRequest L4Proto) where
   type instance ProtocolId (RefLogRequest L4Proto) = 8
   type instance Encoded L4Proto = ByteString
-  decode = either (const Nothing) Just . deserialiseOrFail
+  decode = deserialiseCustom
   encode = serialise
 
 instance HasProtocol L4Proto (PeerMetaProto L4Proto) where
   type instance ProtocolId (PeerMetaProto L4Proto) = 9
   type instance Encoded L4Proto = ByteString
-  decode = either (const Nothing) Just . deserialiseOrFail
+  decode = deserialiseCustom
   encode = serialise
 
   -- FIXME: real-period
@@ -147,31 +152,31 @@ instance Expires (EventKey L4Proto (PeerMetaProto L4Proto)) where
 -- instance MonadIO m => HasNonces () m where
 --   type instance Nonce (PeerHandshake L4Proto) = BS.ByteString
 --   newNonce = do
---     n <- liftIO ( Crypto.newNonce <&> Crypto.encode )
+--     n <- liftIO ( Encrypt.newNonce <&> Crypto.encode )
 --     pure $ BS.take 32 n
 
 instance MonadIO m => HasNonces (PeerHandshake L4Proto) m where
   type instance Nonce (PeerHandshake L4Proto) = BS.ByteString
   newNonce = do
-    n <- liftIO ( Crypto.newNonce <&> Crypto.encode )
+    n <- liftIO ( Encrypt.newNonce <&> Crypto.encode )
     pure $ BS.take 32 n
 
 instance MonadIO m => HasNonces (PeerExchange L4Proto) m where
   type instance Nonce (PeerExchange L4Proto) = BS.ByteString
   newNonce = do
-    n <- liftIO ( Crypto.newNonce <&> Crypto.encode )
+    n <- liftIO ( Encrypt.newNonce <&> Crypto.encode )
     pure $ BS.take 32 n
 
 instance MonadIO m => HasNonces (RefLogUpdate L4Proto) m where
   type instance Nonce (RefLogUpdate L4Proto) = BS.ByteString
   newNonce = do
-    n <- liftIO ( Crypto.newNonce <&> Crypto.encode )
+    n <- liftIO ( Encrypt.newNonce <&> Crypto.encode )
     pure $ BS.take 32 n
 
 instance MonadIO m => HasNonces () m where
   type instance Nonce () = BS.ByteString
   newNonce = do
-    n <- liftIO ( Crypto.newNonce <&> Crypto.encode )
+    n <- liftIO ( Encrypt.newNonce <&> Crypto.encode )
     pure $ BS.take 32 n
 
 instance Serialise Sign.Signature
@@ -181,6 +186,16 @@ instance Signatures HBS2Basic where
   makeSign = Sign.signDetached
   verifySign = Sign.signVerifyDetached
 
+instance Asymm HBS2Basic where
+  type AsymmKeypair HBS2Basic = Encrypt.Keypair
+  type AsymmPrivKey HBS2Basic = Encrypt.SecretKey
+  type AsymmPubKey HBS2Basic = Encrypt.PublicKey
+  type CommonSecret HBS2Basic = Encrypt.CombinedKey
+  asymmNewKeypair = liftIO Encrypt.newKeypair
+  privKeyFromKeypair = Encrypt.secretKey
+  pubKeyFromKeypair = Encrypt.publicKey
+  genCommonSecret = Encrypt.beforeNM
+
 instance Hashed HbSync Sign.PublicKey where
   hashObject pk = hashObject (Crypto.encode pk)
 

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

@@ -3,6 +3,7 @@
 module HBS2.Net.Proto.Peer where
 
 -- import HBS2.Base58
+import HBS2.Actors.Peer
 import HBS2.Data.Types
 import HBS2.Events
 import HBS2.Net.Proto
@@ -10,13 +11,15 @@ import HBS2.Clock
 import HBS2.Net.Proto.Sessions
 import HBS2.Prelude.Plated
 import HBS2.Net.Auth.Credentials
+import HBS2.System.Logger.Simple
 
--- import HBS2.System.Logger.Simple
+import Control.Monad
-
+import Crypto.Saltine.Core.Box qualified as Encrypt
 import Data.Maybe
 import Codec.Serialise()
 import Data.ByteString qualified as BS
 import Data.Hashable
+import Data.String.Conversions (cs)
 import Lens.Micro.Platform
 import Type.Reflection (someTypeRep)
 
@@ -30,13 +33,36 @@ data PeerData e =
   }
   deriving stock (Typeable,Generic)
 
+deriving instance
+    ( Show (PubKey 'Sign (Encryption e))
+    , Show (Nonce ())
+    )
+    => Show (PeerData e)
+
 makeLenses 'PeerData
 
+data PeerDataExt e = PeerDataExt
+  { _peerData :: PeerData e
+  , _peerEncPubKey :: Maybe (PubKey 'Encrypt (Encryption e))
+  }
+  deriving stock (Typeable,Generic)
+
+makeLenses 'PeerDataExt
+
 data PeerHandshake e =
     PeerPing  PingNonce
   | PeerPong  PingNonce (Signature (Encryption e)) (PeerData e)
+  | PeerPingCrypted PingNonce (PubKey 'Encrypt (Encryption e))
+  | PeerPongCrypted PingNonce (Signature (Encryption e)) (PubKey 'Encrypt (Encryption e)) (PeerData e)
   deriving stock (Generic)
 
+deriving instance
+    ( Show (PubKey 'Encrypt (Encryption e))
+    , Show (Signature (Encryption e))
+    , Show (PeerData e)
+    )
+    => Show (PeerHandshake e)
+
 newtype KnownPeer e = KnownPeer (PeerData e)
   deriving stock (Typeable,Generic)
 
@@ -48,12 +74,13 @@ data PeerPingData e =
   PeerPingData
   { _peerPingNonce :: PingNonce
   , _peerPingSent  :: TimeSpec
+  , _peerPingEncPubKey :: Maybe (PubKey 'Encrypt (Encryption e))
   }
   deriving stock (Generic,Typeable)
 
 makeLenses 'PeerPingData
 
-type instance SessionData e (KnownPeer e) = PeerData e
+type instance SessionData e (KnownPeer e) = PeerDataExt e
 
 newtype instance SessionKey e (PeerHandshake e) =
   PeerHandshakeKey (PingNonce, Peer e)
@@ -82,10 +109,28 @@ sendPing :: forall e m . ( MonadIO m
 sendPing pip = do
   nonce <- newNonce @(PeerHandshake e)
   tt <- liftIO $ getTimeCoarse
-  let pdd = PeerPingData nonce tt
+  let pdd = PeerPingData nonce tt Nothing
   update pdd (PeerHandshakeKey (nonce,pip)) id
   request pip (PeerPing @e nonce)
 
+sendPingCrypted :: forall e m . ( MonadIO m
+                         , Request e (PeerHandshake e) m
+                         , Sessions e (PeerHandshake e) m
+                         , HasNonces (PeerHandshake e) m
+                         , Nonce (PeerHandshake e) ~ PingNonce
+                         , Pretty (Peer e)
+                         , HasProtocol e (PeerHandshake e)
+                         , e ~ L4Proto
+                         )
+         => Peer e -> PubKey 'Encrypt (Encryption e) -> m ()
+
+sendPingCrypted pip pubkey = do
+  nonce <- newNonce @(PeerHandshake e)
+  tt <- liftIO $ getTimeCoarse
+  let pdd = PeerPingData nonce tt (Just pubkey)
+  update pdd (PeerHandshakeKey (nonce,pip)) id
+  request pip (PeerPingCrypted @e nonce pubkey)
+
 newtype PeerHandshakeAdapter e m =
   PeerHandshakeAdapter
   { onPeerRTT :: (Peer e, Integer) -> m ()
@@ -103,15 +148,20 @@ peerHandShakeProto :: forall e s m . ( MonadIO m
                                      , Pretty (Peer e)
                                      , EventEmitter e (PeerHandshake e) m
                                      , EventEmitter e (ConcretePeer e) m
+                                     , EventEmitter e (PeerAsymmInfo e) m
                                      , HasCredentials s m
+                                     , Asymm s
                                      , Signatures s
+                                     , Serialise (PubKey 'Encrypt (Encryption e))
                                      , s ~ Encryption e
                                      , e ~ L4Proto
                                      )
                    => PeerHandshakeAdapter e m
-                   -> PeerHandshake e -> m ()
+                   -> PeerEnv e
+                   -> PeerHandshake e
+                   -> m ()
 
-peerHandShakeProto adapter =
+peerHandShakeProto adapter penv =
   \case
     PeerPing nonce  -> do
       pip <- thatPeer proto
@@ -138,7 +188,11 @@ peerHandShakeProto adapter =
 
       se' <- find @e (PeerHandshakeKey (nonce0,pip)) id
 
-      maybe1 se' (pure ()) $ \(PeerPingData nonce t0) -> do
+      maybe1 se' (pure ()) $ \(PeerPingData nonce t0 mpubkey) -> do
+
+        -- Мы отправляли ключ шифрования, но собеседник отказался
+        -- от шифрованной сессии
+        -- when (isJust mpubkey) do
 
         let pk = view peerSignKey d
 
@@ -155,10 +209,76 @@ peerHandShakeProto adapter =
 
           -- FIXME: check if peer is blacklisted
           --        right here
-          update d (KnownPeerKey pip) id
+          let pde = PeerDataExt d Nothing
+          update pde (KnownPeerKey pip) id
 
-          emit AnyKnownPeerEventKey (KnownPeerEvent pip d)
+          emit AnyKnownPeerEventKey (KnownPeerEvent pip pde)
-          emit (ConcretePeerKey pip) (ConcretePeerData pip d)
+          emit (ConcretePeerKey pip) (ConcretePeerData pip pde)
+
+    ---- Crypted
+    PeerPingCrypted nonce theirpubkey -> do
+      pip <- thatPeer proto
+      trace $ "GOT PING CRYPTED from" <+> pretty pip
+
+      -- взять свои ключи
+      creds <- getCredentials @s
+
+      let ourpubkey = pubKeyFromKeypair @s $ view envAsymmetricKeyPair penv
+
+      -- подписать нонс
+      let sign = makeSign @s (view peerSignSk creds) (nonce <> (cs . serialise) ourpubkey)
+
+      own <- peerNonce @e
+
+      -- отправить обратно вместе с публичным ключом
+      response (PeerPongCrypted @e nonce sign ourpubkey (PeerData (view peerSignPk creds) own))
+
+      -- да и пингануть того самим
+
+      se <- find (KnownPeerKey pip) id <&> isJust
+
+      -- Нужно ли запомнить его theirpubkey или достаточно того, что будет
+      -- получено в обратном PeerPongCrypted?
+      -- Нужно!
+      emit PeerAsymmInfoKey (PeerAsymmPubKey pip theirpubkey)
+
+      unless se $ do
+        sendPingCrypted pip ourpubkey
+
+    PeerPongCrypted nonce0 sign theirpubkey pd -> do
+      pip <- thatPeer proto
+      trace $ "GOT PONG CRYPTED from" <+> pretty pip
+
+      se' <- find @e (PeerHandshakeKey (nonce0,pip)) id
+
+      maybe1 se' (pure ()) $ \(PeerPingData nonce t0 mpubkey) -> do
+
+        -- TODO: Мы не отправляли ключ шифрования, а собеседник ответил как будто
+        -- отправляли. Как тут поступать?
+        -- guard (isNothing mpubkey)
+
+        let pk = view peerSignKey pd
+            pde = PeerDataExt pd (Just theirpubkey)
+
+        let signed = verifySign @s pk sign (nonce <> (cs . serialise) theirpubkey)
+
+        when signed $ do
+
+          now <- liftIO getTimeCoarse
+          let rtt = toNanoSecs $ now - t0
+
+          onPeerRTT adapter (pip,rtt)
+
+          expire (PeerHandshakeKey (nonce0,pip))
+
+          -- FIXME: check if peer is blacklisted
+          --        right here
+          update pde (KnownPeerKey pip) id
+
+          emit AnyKnownPeerEventKey (KnownPeerEvent pip pde)
+          emit (ConcretePeerKey pip) (ConcretePeerData pip pde)
+
+    ---- /Crypted
 
   where
     proto = Proxy @(PeerHandshake e)
@@ -173,15 +293,32 @@ deriving stock instance (Eq (Peer e)) => Eq (EventKey e (ConcretePeer e))
 instance (Hashable (Peer e)) => Hashable (EventKey e (ConcretePeer e))
 
 data instance Event e (ConcretePeer e) =
-  ConcretePeerData (Peer e) (PeerData e)
+  ConcretePeerData (Peer e) (PeerDataExt e)
   deriving stock (Typeable)
 
+---
+
+data PeerAsymmInfo e = PeerAsymmInfo
+
+data instance EventKey e (PeerAsymmInfo e) =
+  PeerAsymmInfoKey
+  deriving stock (Generic)
+
+deriving stock instance (Eq (Peer e)) => Eq (EventKey e (PeerAsymmInfo e))
+instance (Hashable (Peer e)) => Hashable (EventKey e (PeerAsymmInfo e))
+
+data instance Event e (PeerAsymmInfo e) =
+  PeerAsymmPubKey (Peer e) (AsymmPubKey (Encryption e))
+  deriving stock (Typeable)
+
+---
+
 data instance EventKey e (PeerHandshake e) =
   AnyKnownPeerEventKey
   deriving stock (Typeable, Eq,Generic)
 
 data instance Event e (PeerHandshake e) =
-  KnownPeerEvent (Peer e) (PeerData e)
+  KnownPeerEvent (Peer e) (PeerDataExt e)
   deriving stock (Typeable)
 
 instance ( Typeable (KnownPeer e)
@@ -197,6 +334,9 @@ instance EventType ( Event e ( PeerHandshake e) ) where
 instance Expires (EventKey e (PeerHandshake e)) where
   expiresIn _ = Nothing
 
+instance Expires (EventKey e (PeerAsymmInfo e)) where
+  expiresIn _ = Nothing
+
 instance Expires (EventKey e (ConcretePeer e)) where
   expiresIn _ = Just 60
 
@@ -209,6 +349,7 @@ deriving instance Eq (Peer e) => Eq (SessionKey e (PeerHandshake e))
 instance Hashable (Peer e) => Hashable (SessionKey e (PeerHandshake e))
 
 instance ( Serialise (PubKey 'Sign (Encryption e))
+         , Serialise (PubKey 'Encrypt (Encryption e))
          , Serialise (Signature (Encryption e))
          , Serialise PeerNonce
          )
@@ -216,6 +357,7 @@ instance ( Serialise (PubKey 'Sign (Encryption e))
   => Serialise (PeerData e)
 
 instance ( Serialise (PubKey 'Sign (Encryption e))
+         , Serialise (PubKey 'Encrypt (Encryption e))
          , Serialise (Signature (Encryption e))
          , Serialise PeerNonce
          )

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

@@ -30,6 +30,8 @@ newtype PeerAnnounce e =
   PeerAnnounce PeerNonce
   deriving stock (Typeable, Generic)
 
+deriving instance Show (Nonce ()) => Show (PeerAnnounce e)
+
 
 peerAnnounceProto :: forall e m  . ( MonadIO m
                                    , EventEmitter e (PeerAnnounce e) m

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

@@ -31,6 +31,11 @@ data PeerExchange e =
   | PeerExchangePeers2 (Nonce (PeerExchange e)) [PeerAddr e]
   deriving stock (Generic, Typeable)
 
+deriving instance
+  ( Show (Nonce (PeerExchange e))
+  , Show (PeerAddr e)
+  ) => Show (PeerExchange e)
+
 data PeerExchangePeersEv e
 
 
@@ -110,30 +115,47 @@ peerExchangeProto pexFilt  msg = do
 
       case pex of
         PEX1 -> do
-
+          pa <- take defPexMaxPeers <$> getAllPex1Peers
-          -- TODO: tcp-peer-support-in-pex
-          pa'   <- forM pips $ \p -> do
-                     auth <- find (KnownPeerKey p) id <&> isJust
-                     pa <- toPeerAddr p
-                     case pa of
-                      (L4Address UDP x) | auth -> pure [x]
-                      _ -> pure mempty
-
-          let pa = take defPexMaxPeers $ mconcat pa'
-
           response (PeerExchangePeers @e n pa)
 
         PEX2 -> do
-
+          pa <- take defPexMaxPeers <$> getAllPex2Peers
-          pa'   <- forM pips $ \p -> do
-                     auth <- find (KnownPeerKey p) id
-                     maybe1 auth (pure mempty) ( const $ fmap L.singleton (toPeerAddr p) )
-
-          -- FIXME: asap-random-shuffle-peers
-          let pa = take defPexMaxPeers $ mconcat pa'
-
           response (PeerExchangePeers2 @e n pa)
 
+getAllPex1Peers :: forall e m .
+  ( MonadIO m
+  , Sessions e (KnownPeer e) m
+  , HasPeerLocator L4Proto m
+  , e ~ L4Proto
+  )
+  => m [IPAddrPort L4Proto]
+getAllPex1Peers = do
+    pl   <- getPeerLocator @e
+    pips <- knownPeers @e pl
+    -- TODO: tcp-peer-support-in-pex
+    pa' <- forM pips $ \p -> do
+                auth <- find (KnownPeerKey p) id <&> isJust
+                pa <- toPeerAddr p
+                case pa of
+                    (L4Address UDP x) | auth -> pure [x]
+                    _ -> pure mempty
+    pure $ mconcat pa'
+
+getAllPex2Peers :: forall e m .
+  ( MonadIO m
+  , Sessions e (KnownPeer e) m
+  , HasPeerLocator L4Proto m
+  , e ~ L4Proto
+  )
+  => m [PeerAddr L4Proto]
+getAllPex2Peers = do
+    pl   <- getPeerLocator @e
+    pips <- knownPeers @e pl
+    pa' <- forM pips $ \p -> do
+                auth <- find (KnownPeerKey p) id
+                maybe1 auth (pure mempty) ( const $ fmap L.singleton (toPeerAddr p) )
+    -- FIXME: asap-random-shuffle-peers
+    pure $ mconcat pa'
 
 newtype instance SessionKey e (PeerExchange e) =
   PeerExchangeKey (Nonce (PeerExchange e))

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

@@ -27,6 +27,10 @@ data RefLogRequest e =
   | RefLogResponse (PubKey 'Sign (Encryption e)) (Hash HbSync)
   deriving stock (Generic)
 
+deriving instance
+  ( Show (PubKey 'Sign (Encryption e))
+  ) => Show (RefLogRequest e)
+
 data RefLogUpdate e =
   RefLogUpdate
   { _refLogId           :: PubKey 'Sign (Encryption e)
@@ -36,6 +40,12 @@ data RefLogUpdate e =
   }
   deriving stock (Generic)
 
+deriving instance
+  ( Show (PubKey 'Sign (Encryption e))
+  , Show (Signature (Encryption e))
+  , Show (Nonce (RefLogUpdate e))
+  ) => Show (RefLogUpdate e)
+
 makeLenses 'RefLogUpdate
 
 newtype RefLogUpdateI e m =

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

@@ -107,7 +107,8 @@ data ReqLimPeriod = NoLimit
                   | ReqLimPerProto   (Timeout 'Seconds)
                   | ReqLimPerMessage (Timeout 'Seconds)
 
-class (KnownNat (ProtocolId p), HasPeer e) => HasProtocol e p | p -> e  where
+class (KnownNat (ProtocolId p), HasPeer e, Show (Encoded e)
+    ) => HasProtocol e p | p -> e  where
   type family ProtocolId p = (id :: Nat) | id -> p
   type family Encoded e :: Type
 

hbs2-core/test/Main.hs

@@ -3,6 +3,7 @@ module Main where
 import TestFakeMessaging
 import TestActors
 -- import TestUniqProtoId
+import TestCrypto
 
 import Test.Tasty
 import Test.Tasty.HUnit
@@ -15,6 +16,7 @@ main =
         testCase "testFakeMessaging1" testFakeMessaging1
       , testCase "testActorsBasic" testActorsBasic
       -- , testCase "testUniqProtoId" testUniqProtoId
+      , testCrypto
       ]
 
 

hbs2-core/test/TestCrypto.hs

@@ -0,0 +1,53 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module TestCrypto where
+
+import Test.QuickCheck.Instances.ByteString
+import Test.Tasty
+import Test.Tasty.QuickCheck as QC
+
+-- import Control.Monad.Trans.Maybe
+import Control.Monad
+import Crypto.Saltine.Class qualified as Saltine
+import Crypto.Saltine.Core.Box qualified as Encrypt
+import Crypto.Saltine.Internal.Box qualified as Encrypt
+import Data.ByteString (ByteString)
+import Data.ByteString qualified as BS
+import Data.Maybe
+import Data.String.Conversions (cs)
+
+import HBS2.Crypto
+
+
+testCrypto :: TestTree
+testCrypto = testGroup "testCrypto"
+  [ QC.testProperty "roundtripCombineExtractNonce" prop_roundtripCombineExtractNonce
+  , QC.testProperty "roundtripEncodingAfterNM" prop_roundtripEncodingAfterNM
+  ]
+
+instance Arbitrary Encrypt.Nonce where
+  arbitrary = Encrypt.Nonce . BS.pack <$> vectorOf Encrypt.box_noncebytes arbitrary
+
+instance Arbitrary Encrypt.SecretKey where
+  arbitrary = (fromMaybe (error "Should be Just value") . Saltine.decode)
+      . BS.pack <$> vectorOf Encrypt.box_beforenmbytes arbitrary
+
+instance Arbitrary Encrypt.PublicKey where
+  arbitrary = (fromMaybe (error "Should be Just value") . Saltine.decode)
+      . BS.pack <$> vectorOf Encrypt.box_beforenmbytes arbitrary
+
+prop_roundtripCombineExtractNonce :: (Encrypt.Nonce, ByteString) -> Bool
+prop_roundtripCombineExtractNonce (n, b) =
+    extractNonce (combineNonceBS n b) == Just (n, b)
+
+prop_roundtripEncodingAfterNM :: (Encrypt.SecretKey, Encrypt.PublicKey, Encrypt.Nonce, ByteString) -> Bool
+prop_roundtripEncodingAfterNM (sk, pk, n, b) = fromMaybe False do
+    let
+        ck = Encrypt.beforeNM sk pk
+
+    let box = boxAfterNMLazy ck n (cs b)
+
+    (n', x) <- extractNonce (cs box)
+    guard (n' == n)
+    b'' <- boxOpenAfterNMLazy ck n' x
+
+    pure (cs b'' == b)

hbs2-peer/app/HttpWorker.hs

@@ -5,6 +5,7 @@ import HBS2.Actors.Peer
 import HBS2.Net.Proto.PeerMeta
 import HBS2.Storage
 import HBS2.Data.Types.Refs
+import HBS2.Merkle (AnnMetaData)
 import HBS2.Net.Proto.Types
 
 import HBS2.System.Logger.Simple
@@ -31,9 +32,10 @@ httpWorker :: forall e s m . ( MyPeer e
                              , HasStorage m
                              , IsRefPubKey s
                              , s ~ Encryption e
-                             ) => PeerConfig -> DownloadEnv e -> m ()
+                             )
+  => PeerConfig -> AnnMetaData -> DownloadEnv e -> m ()
 
-httpWorker conf e = do
+httpWorker conf pmeta e = do
 
   sto <- getStorage
   let port' = cfgValue @PeerHttpPortKey conf  <&>  fromIntegral
@@ -71,7 +73,7 @@ httpWorker conf e = do
               text [qc|{pretty val}|]
 
       get "/metadata" do
-          raw $ serialise $ mkPeerMeta conf
+          raw $ serialise $ pmeta
 
       put "/" do
         -- FIXME: optional-header-based-authorization

hbs2-peer/app/PeerInfo.hs

@@ -5,6 +5,7 @@ module PeerInfo where
 import HBS2.Actors.Peer
 import HBS2.Clock
 import HBS2.Events
+import HBS2.Net.Auth.Credentials
 import HBS2.Net.PeerLocator
 import HBS2.Net.Proto.Peer
 import HBS2.Net.Proto.PeerExchange
@@ -145,8 +146,8 @@ peerPingLoop :: forall e m . ( HasPeerLocator e m
                              , m ~ PeerM e IO
                              , e ~ L4Proto
                              )
-             => PeerConfig -> m ()
+             => PeerConfig -> PeerEnv e -> m ()
-peerPingLoop cfg = do
+peerPingLoop cfg penv = do
 
   e <- ask
 
@@ -240,7 +241,18 @@ peerPingLoop cfg = do
     pips <- knownPeers @e pl <&> (<> sas) <&> List.nub
 
     for_ pips $ \p -> do
-      trace $ "SEND PING TO" <+> pretty p
+      -- trace $ "SEND PING TO" <+> pretty p
       sendPing @e p
+      -- trace $ "SENT PING TO" <+> pretty p
+      pause dt
+      sendPingCrypted @e p
+          (pubKeyFromKeypair @(Encryption e) (view envAsymmetricKeyPair penv))
+      -- trace $ "SENT PING CRYPTED TO" <+> pretty p
+
+  where
+    dt = case (requestPeriodLim @e @(PeerHandshake e)) of
+        NoLimit -> 0
+        ReqLimPerProto   t -> t + 0.1
+        ReqLimPerMessage t -> t + 0.1
 
 

hbs2-peer/app/PeerMain.hs

@@ -15,10 +15,11 @@ import HBS2.Data.Types.Refs (RefLogKey(..))
 import HBS2.Merkle
 import HBS2.Net.Auth.Credentials
 import HBS2.Net.IP.Addr
+import HBS2.Net.Messaging
 import HBS2.Net.Messaging.UDP
 import HBS2.Net.Messaging.TCP
 import HBS2.Net.PeerLocator
-import HBS2.Net.Proto
+import HBS2.Net.Proto as Proto
 import HBS2.Net.Proto.Definition
 import HBS2.Net.Proto.Peer
 import HBS2.Net.Proto.PeerAnnounce
@@ -49,7 +50,7 @@ import HttpWorker
 import ProxyMessaging
 import PeerMeta
 
-import Codec.Serialise
+import Codec.Serialise as Serialise
 -- import Control.Concurrent.Async
 import Control.Concurrent.STM
 import Control.Exception as Exception
@@ -62,7 +63,8 @@ import Data.ByteString.Lazy qualified as LBS
 import Data.ByteString qualified as BS
 import Data.Cache qualified as Cache
 import Data.Function
-import Data.List qualified  as L
+import Data.List qualified as L
+import Data.Map (Map)
 import Data.Map qualified as Map
 import Data.Maybe
 import Data.Set qualified as Set
@@ -73,7 +75,7 @@ import Data.Text (Text)
 import Data.HashSet qualified as HashSet
 import GHC.Stats
 import GHC.TypeLits
-import Lens.Micro.Platform
+import Lens.Micro.Platform as Lens
 import Network.Socket
 import Options.Applicative
 import System.Directory
@@ -83,6 +85,7 @@ import System.Mem
 import System.Metrics
 import System.Posix.Process
 import System.Environment
+import Text.InterpolatedString.Perl6 (qc)
 
 import UnliftIO.Exception qualified as U
 -- import UnliftIO.STM
@@ -177,6 +180,7 @@ data RPCCommand =
   | CHECK PeerNonce (PeerAddr L4Proto) (Hash HbSync)
   | FETCH (Hash HbSync)
   | PEERS
+  | PEXINFO
   | SETLOG SetLogging
   | REFLOGUPDATE ByteString
   | REFLOGFETCH (PubKey 'Sign (Encryption L4Proto))
@@ -245,6 +249,7 @@ runCLI = join . customExecParser (prefs showHelpOnError) $
                         <> command "fetch"     (info pFetch (progDesc "fetch block"))
                         <> command "reflog"    (info pRefLog (progDesc "reflog commands"))
                         <> command "peers"     (info pPeers (progDesc "show known peers"))
+                        <> command "pexinfo"   (info pPexInfo (progDesc "show pex"))
                         <> command "log"       (info pLog   (progDesc "set logging level"))
                         )
 
@@ -306,6 +311,10 @@ runCLI = join . customExecParser (prefs showHelpOnError) $
       rpc <- pRpcCommon
       pure $ runRpcCommand rpc PEERS
 
+    pPexInfo = do
+      rpc <- pRpcCommon
+      pure $ runRpcCommand rpc PEXINFO
+
     onOff l =
             hsubparser ( command "on" (info (pure (l True) ) (progDesc "on")  ) )
       <|>   hsubparser ( command "off" (info (pure (l False) ) (progDesc "off")  ) )
@@ -496,16 +505,16 @@ runPeer opts = U.handle (\e -> myException e
   liftIO $ print $ pretty accptAnn
 
   -- FIXME: move-peerBanned-somewhere
-  let peerBanned p d = do
+  let peerBanned p pd = do
-        let k = view peerSignKey d
+        let k = view peerSignKey pd
         let blacklisted = k `Set.member` blkeys
         let whitelisted = Set.null wlkeys || (k `Set.member` wlkeys)
         pure $ blacklisted || not whitelisted
 
-  let acceptAnnounce p d = do
+  let acceptAnnounce p pd = do
         case accptAnn of
           AcceptAnnounceAll    -> pure True
-          AcceptAnnounceFrom s -> pure $ view peerSignKey d `Set.member` s
+          AcceptAnnounceFrom s -> pure $ view peerSignKey pd `Set.member` s
 
   rpcQ <- liftIO $ newTQueueIO @RPCCommand
 
@@ -571,6 +580,8 @@ runPeer opts = U.handle (\e -> myException e
 
   penv <- newPeerEnv (AnyStorage s) (Fabriq proxy) (getOwnPeer mess)
 
+  let peerMeta = mkPeerMeta conf penv
+
   nbcache <- liftIO $ Cache.newCache (Just $ toTimeSpec ( 600 :: Timeout 'Seconds))
 
   void $ async $ forever do
@@ -590,8 +601,8 @@ runPeer opts = U.handle (\e -> myException e
   let onNoBlock (p, h) = do
         already <- liftIO $ Cache.lookup nbcache (p,h) <&> isJust
         unless already do
-          pd' <- find (KnownPeerKey p) id
+          mpde <- find (KnownPeerKey p) id
-          maybe1 pd' none $ \pd -> do
+          maybe1 mpde none $ \pde@(PeerDataExt {_peerData = pd}) -> do
             let pk = view peerSignKey pd
             when (Set.member pk helpFetchKeys) do
               liftIO $ Cache.insert nbcache (p,h) ()
@@ -644,26 +655,40 @@ runPeer opts = U.handle (\e -> myException e
               subscribe @e PeerAnnounceEventKey $ \(PeerAnnounceEvent pip nonce) -> do
                unless (nonce == pnonce) $ do
                  debug $ "Got peer announce!" <+> pretty pip
-                 pd <- find (KnownPeerKey pip) id -- <&> isJust
+                 mpde :: Maybe (PeerDataExt e) <- find (KnownPeerKey pip) id
-                 banned <- maybe (pure False) (peerBanned pip) pd
+                 banned <- maybe (pure False) (peerBanned pip . view peerData) mpde
-                 let known = isJust pd && not banned
+                 let known = isJust mpde && not banned
                  sendPing pip
 
               subscribe @e BlockAnnounceInfoKey $ \(BlockAnnounceEvent p bi no) -> do
                  pa <- toPeerAddr p
                  liftIO $ atomically $ writeTQueue rpcQ (CHECK no pa (view biHash bi))
 
-              subscribe @e AnyKnownPeerEventKey $ \(KnownPeerEvent p d) -> do
+              subscribe @e PeerAsymmInfoKey $ \(PeerAsymmPubKey p peerpubkey) -> do
+                defPeerInfo <- newPeerInfo
+                fetch True defPeerInfo (PeerInfoKey p) id >>= \pinfo -> do
+                      let updj = genCommonSecret @s (privKeyFromKeypair @s (view envAsymmetricKeyPair penv))
+                              $ peerpubkey
+                      liftIO $ atomically $ modifyTVar' (view proxyEncryptionKeys proxy) $ Lens.at p .~ Just updj
+                      liftIO $ trace [qc| UPDJust from PeerAsymmInfoKey at {p} {updj} |]
 
-                let thatNonce = view peerOwnNonce d
+              subscribe @e AnyKnownPeerEventKey $ \(KnownPeerEvent p pde@(PeerDataExt{_peerData = pd})) -> do
+
+                let thatNonce = view peerOwnNonce pd
 
                 now <- liftIO getTimeCoarse
-                pinfo' <- find (PeerInfoKey p) id -- (view peerPingFailed)
-                maybe1 pinfo' none $ \pinfo -> do
-                  liftIO $ atomically $ writeTVar (view peerPingFailed pinfo) 0
-                  liftIO $ atomically $ writeTVar (view peerLastWatched pinfo) now
 
-                banned <- peerBanned p d
+                defPeerInfo <- newPeerInfo
+                fetch True defPeerInfo (PeerInfoKey p) id >>= \pinfo -> do
+                      liftIO $ atomically $ writeTVar (view peerPingFailed pinfo) 0
+                      liftIO $ atomically $ writeTVar (view peerLastWatched pinfo) now
+                      let mupd = genCommonSecret @s (privKeyFromKeypair @s (view envAsymmetricKeyPair penv))
+                              <$> view peerEncPubKey pde
+                      forM_ mupd \upd -> do
+                          liftIO $ atomically $ modifyTVar' (view proxyEncryptionKeys proxy) $ Lens.at p .~ Just upd
+                          liftIO $ trace [qc| UPDJust from AnyKnownPeerEventKey at {p} {upd} |]
+
+                banned <- peerBanned p pd
 
                 let doAddPeer p = do
                       addPeers pl [p]
@@ -675,7 +700,7 @@ runPeer opts = U.handle (\e -> myException e
 
                       unless here do
                         debug $ "Got authorized peer!" <+> pretty p
-                                                       <+> pretty (AsBase58 (view peerSignKey d))
+                                                       <+> pretty (AsBase58 (view peerSignKey pd))
                         request @e p (GetPeerMeta @e)
 
 
@@ -691,14 +716,11 @@ runPeer opts = U.handle (\e -> myException e
 
                    | otherwise -> do
 
-                    update d (KnownPeerKey p) id
+                    update pde (KnownPeerKey p) id
 
-                    pd' <- knownPeers @e pl >>=
+                    pd :: Map BS.ByteString (Peer L4Proto) <- fmap (Map.fromList . catMaybes)
-                              \peers -> forM peers $ \pip -> do
+                        $ knownPeers @e pl >>= mapM \pip ->
-                                          pd <- find (KnownPeerKey pip) (view peerOwnNonce)
+                              fmap (, pip) <$> find (KnownPeerKey pip) (view (peerData . peerOwnNonce))
-                                          pure $ (,pip) <$> pd
-
-                    let pd = Map.fromList $ catMaybes pd'
 
                     let proto1 = view sockType p
 
@@ -767,11 +789,11 @@ runPeer opts = U.handle (\e -> myException e
 
                 -- peerThread "tcpWorker" (tcpWorker conf)
 
-                peerThread "httpWorker" (httpWorker conf denv)
+                peerThread "httpWorker" (httpWorker conf peerMeta denv)
 
                 peerThread "checkMetrics" (checkMetrics metrics)
 
-                peerThread "peerPingLoop" (peerPingLoop @e conf)
+                peerThread "peerPingLoop" (peerPingLoop @e conf penv)
 
                 peerThread "knownPeersPingLoop" (knownPeersPingLoop @e conf)
 
@@ -805,13 +827,64 @@ runPeer opts = U.handle (\e -> myException e
                             PING pa r -> do
                               debug $ "ping" <+> pretty pa
                               pip <- fromPeerAddr @e pa
-                              subscribe (ConcretePeerKey pip) $ \(ConcretePeerData{}) -> do
+                              subscribe (ConcretePeerKey pip) $ \(ConcretePeerData _ pde) -> do
 
                                 maybe1 r (pure ()) $ \rpcPeer -> do
                                   pinged <- toPeerAddr pip
                                   request rpcPeer (RPCPong @e pinged)
+                                  -- case (view peerEncPubKey pde) of
+                                  --     Nothing -> unencrypted ping
+                                  --     Just pubkey -> encryptengd
 
-                              sendPing pip
+                              let
+                                  requestPlain :: forall m msg .
+                                    ( MonadIO m
+                                    -- , HasProtocol L4Proto msg
+                                    , msg ~ PeerHandshake L4Proto
+                                    , HasOwnPeer L4Proto m
+                                    -- , Messaging MessagingTCP L4Proto (AnyMessage ByteString L4Proto)
+                                    -- , Messaging MessagingUDP L4Proto (AnyMessage ByteString L4Proto)
+                                    , HasTimeLimits L4Proto (PeerHandshake L4Proto) m
+                                    ) => Peer e -> msg -> m ()
+                                  requestPlain peer_e msg = do
+                                      let protoN = protoId @e @msg (Proxy @msg)
+                                      me <- ownPeer @e
+
+                                      allowed <- tryLockForPeriod peer_e msg
+
+                                      when (not allowed) do
+                                          trace $ "REQUEST: not allowed to send" <+> viaShow msg
+
+                                      -- when allowed do
+                                      --     sendTo proxy (To peer_e) (From me) (AnyMessage @(Encoded e) @e protoN (encode msg))
+
+                                      when allowed do
+                                          sendToPlainProxyMessaging (PlainProxyMessaging proxy) (To peer_e) (From me)
+                                              -- (AnyMessage @(Encoded e) @e protoN (Proto.encode msg))
+                                              (serialise (protoN, (Proto.encode msg)))
+
+                              let
+                                  sendPingCrypted' pip pubkey = do
+                                      nonce <- newNonce @(PeerHandshake e)
+                                      tt <- liftIO $ getTimeCoarse
+                                      let pdd = PeerPingData nonce tt (Just pubkey)
+                                      update pdd (PeerHandshakeKey (nonce,pip)) id
+                                      requestPlain pip (PeerPingCrypted @e nonce pubkey)
+
+                              let
+                                  sendPing' pip = do
+                                      nonce <- newNonce @(PeerHandshake e)
+                                      tt <- liftIO $ getTimeCoarse
+                                      let pdd = PeerPingData nonce tt Nothing
+                                      update pdd (PeerHandshakeKey (nonce,pip)) id
+                                      requestPlain pip (PeerPing @e nonce)
+
+                              sendPingCrypted' pip (pubKeyFromKeypair @s (view envAsymmetricKeyPair penv))
+                              pause $ case (requestPeriodLim @e @(PeerHandshake e)) of
+                                  NoLimit -> 0
+                                  ReqLimPerProto   t -> t + 0.1
+                                  ReqLimPerMessage t -> t + 0.1
+                              sendPing' pip
 
                             ANNOUNCE h  -> do
                               debug $ "got announce rpc" <+> pretty h
@@ -839,18 +912,18 @@ runPeer opts = U.handle (\e -> myException e
 
                               unless (nonce == n1) do
 
-                                peer <- find @e (KnownPeerKey pip) id
+                                mpde <- find @e (KnownPeerKey pip) id
 
                                 debug $ "received announce from"
                                               <+> pretty pip
                                               <+> pretty h
 
-                                case peer of
+                                case mpde of
                                   Nothing -> do
                                     sendPing @e pip
                                     -- TODO: enqueue-announce-from-unknown-peer?
 
-                                  Just pd  -> do
+                                  Just (pde@(PeerDataExt {_peerData = pd}))  -> do
 
                                     banned <- peerBanned pip pd
 
@@ -893,11 +966,11 @@ runPeer opts = U.handle (\e -> myException e
                     [ makeResponse (blockSizeProto blk dontHandle onNoBlock)
                     , makeResponse (blockChunksProto adapter)
                     , makeResponse blockAnnounceProto
-                    , makeResponse (withCredentials @e pc . peerHandShakeProto hshakeAdapter)
+                    , makeResponse (withCredentials @e pc . peerHandShakeProto hshakeAdapter penv)
                     , makeResponse (peerExchangeProto pexFilt)
                     , makeResponse (refLogUpdateProto reflogAdapter)
                     , makeResponse (refLogRequestProto reflogReqAdapter)
-                    , makeResponse (peerMetaProto (mkPeerMeta conf))
+                    , makeResponse (peerMetaProto peerMeta)
                     ]
 
               void $ liftIO $ waitAnyCancel workers
@@ -941,11 +1014,19 @@ runPeer opts = U.handle (\e -> myException e
   let peersAction _ = do
         who <- thatPeer (Proxy @(RPC e))
         void $ liftIO $ async $ withPeerM penv $ do
-          forKnownPeers @e $ \p pd -> do
+          forKnownPeers @e $ \p pde -> do
               pa <- toPeerAddr p
-              let k = view peerSignKey pd
+              let k = view (peerData . peerSignKey) pde
               request who (RPCPeersAnswer @e pa k)
 
+  let pexInfoAction :: RPC L4Proto -> ResponseM L4Proto (RpcM (ResourceT IO)) ()
+      pexInfoAction _ = do
+        who <- thatPeer (Proxy @(RPC e))
+        void $ liftIO $ async $ withPeerM penv $ do
+            -- FIXME: filter-pexinfo-entries
+            ps <- getAllPex2Peers
+            request who (RPCPexInfoAnswer @e ps)
+
   let logLevelAction = \case
         DebugOn True  -> do
           setLogging @DEBUG debugPrefix
@@ -981,21 +1062,25 @@ runPeer opts = U.handle (\e -> myException e
           h <- liftIO $ getRef sto (RefLogKey @(Encryption e) puk)
           request who (RPCRefLogGetAnswer @e  h)
 
-  let arpc = RpcAdapter pokeAction
+  let arpc = RpcAdapter
-                        dieAction
+          { rpcOnPoke          = pokeAction
-                        dontHandle
+          , rpcOnDie           = dieAction
-                        dontHandle
+          , rpcOnPokeAnswer    = dontHandle
-                        annAction
+          , rpcOnPokeAnswerFull = dontHandle
-                        pingAction
+          , rpcOnAnnounce      = annAction
-                        dontHandle
+          , rpcOnPing          = pingAction
-                        fetchAction
+          , rpcOnPong          = dontHandle
-                        peersAction
+          , rpcOnFetch         = fetchAction
-                        dontHandle
+          , rpcOnPeers         = peersAction
-                        logLevelAction
+          , rpcOnPeersAnswer   = dontHandle
-                        reflogUpdateAction
+          , rpcOnPexInfo       = pexInfoAction
-                        reflogFetchAction
+          , rpcOnPexInfoAnswer = dontHandle
-                        reflogGetAction
+          , rpcOnLogLevel      = logLevelAction
-                        dontHandle
+          , rpcOnRefLogUpdate  = reflogUpdateAction
+          , rpcOnRefLogFetch   = reflogFetchAction
+          , rpcOnRefLogGet     = reflogGetAction
+          , rpcOnRefLogGetAnsw = dontHandle
+          }
 
   rpc <- async $ runRPC udp1 do
                    runProto @e
@@ -1071,26 +1156,25 @@ withRPC o cmd = rpcClientMain o $ runResourceT do
 
   refQ <- liftIO newTQueueIO
 
-  let  adapter =
+  let  adapter = RpcAdapter
-        RpcAdapter dontHandle
+            { rpcOnPoke          = dontHandle
-                   dontHandle
+            , rpcOnDie           = dontHandle
-                   (liftIO . atomically . writeTQueue pokeQ)
+            , rpcOnPokeAnswer    = (liftIO . atomically . writeTQueue pokeQ)
-                   (liftIO . atomically . writeTQueue pokeFQ)
+            , rpcOnPokeAnswerFull = (liftIO . atomically . writeTQueue pokeFQ)
-                   (const $ liftIO exitSuccess)
+            , rpcOnAnnounce      = (const $ liftIO exitSuccess)
-                   (const $ notice "ping?")
+            , rpcOnPing          = (const $ notice "ping?")
-                   (liftIO . atomically . writeTQueue pingQ)
+            , rpcOnPong          = (liftIO . atomically . writeTQueue pingQ)
-                   dontHandle
+            , rpcOnFetch         = dontHandle
-                   dontHandle
+            , rpcOnPeers         = dontHandle
-
+            , rpcOnPeersAnswer   = (\(pa, k) -> Log.info $ pretty (AsBase58 k) <+> pretty pa)
-                   (\(pa, k) -> Log.info $ pretty (AsBase58 k) <+> pretty pa
+            , rpcOnPexInfo       = dontHandle
-                   )
+            , rpcOnPexInfoAnswer = (\ps -> mapM_ (Log.info . pretty) ps)
-
+            , rpcOnLogLevel      = dontHandle
-                   dontHandle
+            , rpcOnRefLogUpdate  = dontHandle
-                   dontHandle
+            , rpcOnRefLogFetch   = dontHandle
-                   dontHandle
+            , rpcOnRefLogGet     = dontHandle
-                   dontHandle
+            , rpcOnRefLogGetAnsw = ( liftIO . atomically . writeTQueue refQ )
-
+            }
-                   ( liftIO . atomically . writeTQueue refQ )
 
   prpc <- async $ runRPC udp1 do
                     env <- ask
@@ -1132,6 +1216,10 @@ withRPC o cmd = rpcClientMain o $ runResourceT do
                         pause @'Seconds 1
                         exitSuccess
 
+                      RPCPexInfo{} -> liftIO do
+                        pause @'Seconds 1
+                        exitSuccess
+
                       RPCLogLevel{} -> liftIO exitSuccess
 
                       RPCRefLogUpdate{} -> liftIO do
@@ -1166,6 +1254,7 @@ runRpcCommand opt = \case
   ANNOUNCE h -> withRPC opt (RPCAnnounce h)
   FETCH h  -> withRPC opt (RPCFetch h)
   PEERS -> withRPC opt RPCPeers
+  PEXINFO -> withRPC opt RPCPexInfo
   SETLOG s -> withRPC opt (RPCLogLevel s)
   REFLOGUPDATE bs -> withRPC opt (RPCRefLogUpdate bs)
   REFLOGFETCH k -> withRPC opt (RPCRefLogFetch k)

hbs2-peer/app/PeerMeta.hs

@@ -21,12 +21,16 @@ import Control.Concurrent.Async
 import Control.Concurrent.STM
 import Control.Monad.Reader
 import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.State.Strict qualified as State
 import Data.ByteString (ByteString)
 import Data.Foldable hiding (find)
 import Data.HashMap.Strict qualified as HashMap
+import Data.Map.Strict qualified as Map
 import Data.Maybe
+import Data.Set qualified as Set
 import Data.Text qualified as Text
 import Data.Text.Encoding qualified as TE
+import Data.Time
 import Data.Word
 import Lens.Micro.Platform
 import Network.HTTP.Simple (getResponseBody, httpLbs, parseRequest, getResponseStatus)
@@ -53,14 +57,24 @@ fillPeerMeta mtcp probePeriod = do
   debug "I'm fillPeerMeta"
   pl <- getPeerLocator @e
 
-  pause @'Seconds 10 -- wait 'till everything calm down
+  pause @'Seconds 5 -- wait 'till everything calm down
+  flip State.evalStateT Map.empty $ forever do
+    pause @'Seconds 12
 
-  forever $ (>> pause probePeriod) $ do
+    ps <- knownPeers pl
+    now <- liftIO getCurrentTime
+    let pss = Set.fromList ps
+    psActual <- Map.filterWithKey (\k _ -> k `Set.member` pss) <$> State.get
+    let psNew = pss Set.\\ (Map.keysSet psActual)
+    let psReady = Map.keysSet . Map.filter (\t -> t < now) $ psActual
+    let ps' = Set.toList (psNew <> psReady)
+    (State.put . (<> psActual) . Map.fromList) $
+        (, now & addUTCTime (toNominalDiffTime probePeriod)) <$> ps'
 
-    ps <- knownPeers @e pl
+    when ((not . null) ps') $ lift do
-    debug $ "fillPeerMeta peers:" <+> pretty ps
+      debug $ "fillPeerMeta peers:" <+> pretty ps'
-    npi <- newPeerInfo
+      for_ ps' $ \p -> do
-    for_ ps $ \p -> do
+        npi <- newPeerInfo
 
         pinfo <- fetch True npi (PeerInfoKey p) id
         mmApiAddr <- liftIO $ readTVarIO (_peerHttpApiAddress pinfo)

hbs2-peer/app/PeerTypes.hs

@@ -9,6 +9,8 @@ import HBS2.Clock
 import HBS2.Defaults
 import HBS2.Events
 import HBS2.Hash
+import HBS2.Merkle (AnnMetaData)
+import HBS2.Net.Auth.Credentials
 import HBS2.Net.IP.Addr
 import HBS2.Net.Proto
 import HBS2.Net.Proto.Peer
@@ -29,12 +31,15 @@ import Data.Foldable (for_)
 import Control.Concurrent.Async
 import Control.Concurrent.STM
 import Control.Monad.Reader
+import Control.Monad.Writer qualified as W
+import Crypto.Saltine.Core.Box qualified as Encrypt
 import Data.ByteString.Lazy (ByteString)
 import Data.Cache (Cache)
 import Data.Cache qualified as Cache
 import Data.HashSet (HashSet)
 import Data.HashMap.Strict (HashMap)
 import Data.HashMap.Strict qualified as HashMap
+import Data.List qualified as L
 import Data.Maybe
 import Lens.Micro.Platform
 import Data.Hashable
@@ -43,6 +48,7 @@ import Data.IntMap (IntMap)
 import Data.IntSet (IntSet)
 import Data.Text qualified as Text
 import Data.Text.Encoding qualified as TE
+import Data.Word
 
 
 data PeerInfo e =
@@ -72,23 +78,25 @@ makeLenses 'PeerInfo
 
 newPeerInfo :: MonadIO m => m (PeerInfo e)
 newPeerInfo = liftIO do
-  PeerInfo <$> newTVarIO defBurst
+  _peerBurst          <- newTVarIO defBurst
-           <*> newTVarIO Nothing
+  _peerBurstMax       <- newTVarIO Nothing
-           <*> newTVarIO mempty
+  _peerBurstSet       <- newTVarIO mempty
-           <*> newTVarIO 0
+  _peerErrors         <- newTVarIO 0
-           <*> newTVarIO 0
+  _peerErrorsLast     <- newTVarIO 0
-           <*> newTVarIO 0
+  _peerErrorsPerSec   <- newTVarIO 0
-           <*> newTVarIO 0
+  _peerLastWatched    <- newTVarIO 0
-           <*> newTVarIO 0
+  _peerDownloaded     <- newTVarIO 0
-           <*> newTVarIO 0
+  _peerDownloadedLast <- newTVarIO 0
-           <*> newTVarIO 0
+  _peerPingFailed     <- newTVarIO 0
-           <*> newTVarIO 0
+  _peerDownloadedBlk  <- newTVarIO 0
-           <*> newTVarIO 0
+  _peerDownloadFail   <- newTVarIO 0
-           <*> newTVarIO 0
+  _peerDownloadMiss   <- newTVarIO 0
-           <*> newTVarIO []
+  _peerRTTBuffer      <- newTVarIO []
-           <*> newTVarIO (Left 0)
+                                          -- Acts like a circular buffer.
-           <*> newTVarIO 0
+  _peerHttpApiAddress <- newTVarIO (Left 0)
-           <*> newTVarIO Nothing
+  _peerHttpDownloaded <- newTVarIO 0
+  _peerMeta           <- newTVarIO Nothing
+  pure PeerInfo {..}
 
 type instance SessionData e (PeerInfo e) = PeerInfo e
 
@@ -351,13 +359,13 @@ forKnownPeers :: forall e  m . ( MonadIO m
                                , Sessions e (KnownPeer e) m
                                , HasPeer e
                                )
-               =>  ( Peer e -> PeerData e -> m () ) -> m ()
+               =>  ( Peer e -> PeerDataExt e -> m () ) -> m ()
 forKnownPeers m = do
   pl <- getPeerLocator @e
   pips <- knownPeers @e pl
   for_ pips $ \p -> do
-    pd' <- find (KnownPeerKey p) id
+    mpde <- find (KnownPeerKey p) id
-    maybe1 pd' (pure ()) (m p)
+    maybe1 mpde (pure ()) (m p)
 
 getKnownPeers :: forall e  m . ( MonadIO m
                                , HasPeerLocator e m
@@ -374,16 +382,27 @@ getKnownPeers  = do
     maybe1 pd' (pure mempty) (const $ pure [p])
   pure $ mconcat r
 
-mkPeerMeta conf = do
+mkPeerMeta :: PeerConfig -> PeerEnv e -> AnnMetaData
-    let mHttpPort = cfgValue @PeerHttpPortKey conf  <&> fromIntegral
+mkPeerMeta conf penv = do
-    let mTcpPort =
+    let mHttpPort :: Maybe Integer
+        mHttpPort = cfgValue @PeerHttpPortKey conf <&> fromIntegral
+    let mTcpPort :: Maybe Word16
+        mTcpPort =
           (
           fmap (\(L4Address _ (IPAddrPort (_, p))) -> p)
             . fromStringMay @(PeerAddr L4Proto)
           )
           =<< cfgValue @PeerListenTCPKey conf
-    annMetaFromPeerMeta . PeerMeta . catMaybes $
+    -- let useEncryption = True  -- move to config
-      [ mHttpPort <&> \p -> ("http-port", TE.encodeUtf8 . Text.pack . show $ p)
+    annMetaFromPeerMeta . PeerMeta $ W.execWriter do
-      , mTcpPort <&> \p -> ("listen-tcp", TE.encodeUtf8 . Text.pack . show $ p)
+      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

@@ -1,37 +1,64 @@
 {-# Language TemplateHaskell #-}
 module ProxyMessaging
   ( ProxyMessaging
+  , PlainProxyMessaging(..)
   , newProxyMessaging
   , runProxyMessaging
+  , proxyEncryptionKeys
+  , sendToPlainProxyMessaging
   ) where
 
 import HBS2.Prelude.Plated
 import HBS2.Net.Messaging
 import HBS2.Clock
+import HBS2.Crypto
+import HBS2.Net.Auth.Credentials
+import HBS2.Net.Proto.Definition ()
+import HBS2.Net.Proto.Peer
 import HBS2.Net.Proto.Types
 import HBS2.Net.Messaging.UDP
 import HBS2.Net.Messaging.TCP
 
 import HBS2.System.Logger.Simple
 
+import Crypto.Saltine.Class as SCl
+import Crypto.Saltine.Core.Box qualified as Encrypt
+
+import Codec.Serialise
+import Control.Applicative
+import Control.Arrow hiding ((<+>))
 import Control.Concurrent.Async
 import Control.Concurrent.STM
 import Control.Concurrent.STM.TQueue
-import Data.ByteString.Lazy (ByteString)
+import Control.Monad.Trans.Maybe
+import Data.ByteString (ByteString)
+import Data.ByteString qualified as BS
 import Data.ByteString.Lazy qualified as LBS
+import Data.Maybe
+import Data.String.Conversions (cs)
 import Data.List qualified as L
+import Data.Map (Map)
+import Data.Map qualified as Map
 import Lens.Micro.Platform
 import Control.Monad
 
 -- TODO: protocol-encryption-goes-here
 
-data ProxyMessaging  =
+data ProxyMessaging =
   ProxyMessaging
   { _proxyUDP :: MessagingUDP
   , _proxyTCP  :: Maybe MessagingTCP
-  , _proxyAnswers :: TQueue (From L4Proto, ByteString)
+  , _proxyAnswers :: TQueue (From L4Proto, LBS.ByteString)
+  , _proxyEncryptionKeys :: TVar (Map (Peer L4Proto) (CommonSecret (Encryption L4Proto)))
   }
 
+newtype PlainProxyMessaging = PlainProxyMessaging ProxyMessaging
+
+-- 1 нода X создаёт себе Encrypt.Keypair
+-- 2 подписывает из него публичный ключ ключом подписи ноды X и отправляет ноде Y
+-- 3 нода Y получила Публичный ключ ноды X, создала симметричный Key,
+--   зашифровала его для полученного Публичного ключа ноды X и отравила ей
+
 makeLenses 'ProxyMessaging
 
 newProxyMessaging :: forall m . MonadIO m
@@ -42,6 +69,7 @@ newProxyMessaging :: forall m . MonadIO m
 newProxyMessaging u t = liftIO do
   ProxyMessaging u t
     <$> newTQueueIO
+    <*> newTVarIO mempty
 
 runProxyMessaging :: forall m . MonadIO  m
                   => ProxyMessaging
@@ -66,23 +94,82 @@ runProxyMessaging env = liftIO do
 
   liftIO $ mapM_ waitCatch [u,t]
 
-instance Messaging ProxyMessaging L4Proto ByteString where
+instance Messaging PlainProxyMessaging L4Proto LBS.ByteString where
+  sendTo = sendToPlainProxyMessaging
+  receive (PlainProxyMessaging bus) = receive bus
 
-  sendTo bus t@(To whom) f m = do
+sendToPlainProxyMessaging :: (MonadIO m)
-    -- sendTo (view proxyUDP bus)  t f m
+  => PlainProxyMessaging
-    -- trace $ "PROXY: SEND" <+> pretty whom
+  -> To L4Proto
+  -> From L4Proto
+  -> LBS.ByteString
+  -- -> AnyMessage LBS.ByteString L4Proto
+  -> m ()
+sendToPlainProxyMessaging (PlainProxyMessaging bus) t@(To whom) proto msg = do
     let udp = view proxyUDP bus
     case view sockType whom of
-      UDP -> sendTo udp  t f m
+      UDP -> sendTo udp  t proto msg
       TCP -> maybe1 (view proxyTCP bus) none $ \tcp -> do
-               sendTo tcp t f m
+               sendTo tcp t proto msg
 
-  receive bus _ = liftIO do
+instance Messaging ProxyMessaging L4Proto LBS.ByteString where
+  sendTo = sendToProxyMessaging
+  receive = receiveFromProxyMessaging
+
+sendToProxyMessaging bus t@(To whom) proto msg = do
+    -- sendTo (view proxyUDP bus)  t proto msg
+    -- trace $ "PROXY: SEND" <+> pretty whom
+    encKey <- Map.lookup whom <$> (liftIO . readTVarIO) (view proxyEncryptionKeys bus)
+    cf <- case encKey of
+        Nothing -> do
+            trace $ "ENCRYPTION SEND: sending plain message to" <+> pretty whom
+            pure id
+        Just k -> do
+            trace $ "ENCRYPTION SEND: sending encrypted message to" <+> pretty whom <+> "with key" <+> viaShow k
+            boxAfterNMLazy k <$> liftIO Encrypt.newNonce
+    sendTo (PlainProxyMessaging bus) t proto (cf msg)
+
+receiveFromProxyMessaging :: MonadIO m
+  => ProxyMessaging -> To L4Proto -> m [(From L4Proto, LBS.ByteString)]
+receiveFromProxyMessaging bus _ = liftIO do
     -- trace "PROXY: RECEIVE"
     -- receive (view proxyUDP bus) w
     let answ = view proxyAnswers bus
-    atomically $ do
+    rs <- atomically $ liftM2 (:) (readTQueue answ) (flushTQueue answ)
-      r <- readTQueue answ
+    fmap catMaybes $ forM rs \(w@(From whom), msg) -> do
-      rs <- flushTQueue answ
+        encKeys <- (liftIO . readTVarIO) (view proxyEncryptionKeys bus)
-      pure (r:rs)
+        fmap (w, ) <$> dfm whom (Map.lookup whom encKeys) msg
 
+    where
+      dfm :: Peer L4Proto -> Maybe Encrypt.CombinedKey -> LBS.ByteString -> IO (Maybe LBS.ByteString)
+      dfm = \whom mk msg -> case mk of
+          Nothing -> do
+              trace $ "ENCRYPTION RECEIVE: we do not have a key to decode" <+> pretty whom
+              pure (Just msg)
+          Just k -> runMaybeT $ (<|> pure msg) $ do
+              trace $ "ENCRYPTION RECEIVE: we have a key to decode from" <+> pretty whom <+> ":" <+> viaShow k
+              case ((extractNonce . cs) msg) of
+                  Nothing -> do
+                      trace $ "ENCRYPTION RECEIVE: can not extract nonce from" <+> pretty whom <+> "message" <+> viaShow msg
+                      pure msg
+                  Just (nonce, msg') ->
+                      ((MaybeT . pure) (boxOpenAfterNMLazy k nonce msg')
+                          <* (trace $ "ENCRYPTION RECEIVE: message successfully decoded from" <+> pretty whom)
+                      )
+                    <|>
+                      (do
+                          (trace $ "ENCRYPTION RECEIVE: can not decode message from" <+> pretty whom)
+
+                          -- А будем-ка мы просто передавать сообщение дальше как есть, если не смогли расшифровать
+                          pure msg
+
+                          -- -- Попытаться десериализовать сообщение как PeerPing или PeerPingCrypted
+                          -- case deserialiseOrFail msg of
+                          --   Right (_ :: PeerHandshake L4Proto) -> do
+                          --       trace $ "ENCRYPTION RECEIVE: plain message decoded as PeerHandshake" <+> pretty whom
+                          --       pure msg
+                          --   Left _ -> do
+                          --       trace $ "ENCRYPTION RECEIVE: failed" <+> pretty whom
+                          --       mzero
+
+                      )

hbs2-peer/app/RPC.hs

@@ -33,6 +33,8 @@ data RPC e =
   | RPCFetch (Hash HbSync)
   | RPCPeers
   | RPCPeersAnswer (PeerAddr e) (PubKey 'Sign (Encryption e))
+  | RPCPexInfo
+  | RPCPexInfoAnswer [PeerAddr L4Proto]
   | RPCLogLevel SetLogging
   | RPCRefLogUpdate ByteString
   | RPCRefLogFetch (PubKey 'Sign (Encryption e))
@@ -40,6 +42,11 @@ data RPC e =
   | RPCRefLogGetAnswer (Maybe (Hash HbSync))
   deriving stock (Generic)
 
+deriving instance
+  ( Show (PubKey 'Sign (Encryption e))
+  , Show (PeerAddr e)
+  ) => Show (RPC e)
+
 instance (Serialise (PeerAddr e), Serialise (PubKey 'Sign (Encryption e))) => Serialise (RPC e)
 
 instance HasProtocol L4Proto (RPC L4Proto) where
@@ -69,6 +76,8 @@ data RpcAdapter e m =
   , rpcOnFetch         :: Hash HbSync -> m ()
   , rpcOnPeers         :: RPC e -> m ()
   , rpcOnPeersAnswer   :: (PeerAddr e, PubKey 'Sign (Encryption e)) -> m ()
+  , rpcOnPexInfo       :: RPC e -> m ()
+  , rpcOnPexInfoAnswer :: [PeerAddr L4Proto] -> m ()
   , rpcOnLogLevel      :: SetLogging -> m ()
   , rpcOnRefLogUpdate  :: ByteString -> m ()
   , rpcOnRefLogFetch   :: PubKey 'Sign (Encryption e) -> m ()
@@ -124,6 +133,8 @@ rpcHandler adapter = \case
     (RPCFetch h)       -> rpcOnFetch adapter h
     p@RPCPeers{}       -> rpcOnPeers adapter p
     (RPCPeersAnswer pa k) -> rpcOnPeersAnswer adapter (pa,k)
+    p@RPCPexInfo{}     -> rpcOnPexInfo adapter p
+    (RPCPexInfoAnswer pa) -> rpcOnPexInfoAnswer adapter pa
     (RPCLogLevel l)    -> rpcOnLogLevel adapter l
     (RPCRefLogUpdate bs)  -> rpcOnRefLogUpdate adapter bs
     (RPCRefLogFetch e) -> rpcOnRefLogFetch adapter e

hbs2-peer/hbs2-peer.cabal

@@ -48,6 +48,7 @@ common common-deps
         , stm
         , streaming
         , sqlite-simple
+        , time
         , temporary
         , text
         , timeit
@@ -59,6 +60,7 @@ common common-deps
         , filelock
         , ekg-core
         , scotty
+        , string-conversions
         , warp
         , http-conduit
         , http-types
@@ -103,6 +105,7 @@ common shared-properties
                      , MultiParamTypeClasses
                      , OverloadedStrings
                      , QuasiQuotes
+                     , RecordWildCards
                      , ScopedTypeVariables
                      , StandaloneDeriving
                      , TupleSections

hbs2/Main.hs

@@ -568,6 +568,7 @@ main = join . customExecParser (prefs showHelpOnError) $
                         <> command "lref-update"     (info pUpdateLRef (progDesc "updates a linear ref"))
                         <> command "reflog"          (info pReflog (progDesc "reflog commands"))
                         -- <> command "lref-del"        (info pDelLRef (progDesc "removes a linear ref from node linear ref list"))
+                        <> command "showpex"         (info pReflog (progDesc "reflog commands"))
                         )
 
     common = do