Merge iv/integrate-encryption-test-dev2 into refchan-merge-2 (using imerge)

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

@@ -1299,3 +1299,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,11 +53,13 @@ common shared-properties
                      , MultiParamTypeClasses
                      , OverloadedStrings
                      , QuasiQuotes
+                     , RecordWildCards
                      , ScopedTypeVariables
                      , StandaloneDeriving
                      , TupleSections
                      , TypeApplications
                      , TypeFamilies
+                     , TemplateHaskell
 
 
 
@@ -70,9 +72,11 @@ library
                     , HBS2.Actors.Peer.Types
                     , HBS2.Base58
                     , HBS2.Clock
+                    , HBS2.Crypto
                     , HBS2.Data.Detect
                     , HBS2.Data.Types
                     , HBS2.Data.Types.Crypto
+                    , HBS2.Data.Types.Peer
                     , HBS2.Data.Types.Refs
                     , HBS2.Defaults
                     , HBS2.Events
@@ -92,6 +96,8 @@ library
                     , HBS2.Net.Proto.BlockChunks
                     , HBS2.Net.Proto.BlockInfo
                     , HBS2.Net.Proto.Definition
+                    , HBS2.Net.Proto.EncryptionHandshake
+                    , HBS2.Net.Proto.Event.PeerExpired
                     , HBS2.Net.Proto.Peer
                     , HBS2.Net.Proto.PeerAnnounce
                     , HBS2.Net.Proto.PeerExchange
@@ -151,9 +157,11 @@ library
                     , stm
                     , stm-chans
                     , streaming
+                    , string-conversions
                     , suckless-conf
                     , temporary
                     , text
+                    , time
                     , transformers
                     , uniplate
                     , unordered-containers
@@ -190,17 +198,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

@@ -11,9 +11,11 @@ module HBS2.Actors.Peer
 import HBS2.Actors
 import HBS2.Actors.Peer.Types
 import HBS2.Clock
+import HBS2.Data.Types.Peer
 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
@@ -21,7 +23,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
@@ -30,18 +34,24 @@ import Data.Cache (Cache)
 import Data.Cache qualified as Cache
 import Data.Dynamic
 import Data.Foldable hiding (find)
+import Data.Map (Map)
 import Data.Map qualified as Map
 import Data.Maybe
 import GHC.TypeLits
-import Lens.Micro.Platform
+import Lens.Micro.Platform as Lens
 import Data.HashMap.Strict (HashMap)
 import Data.HashMap.Strict qualified as HashMap
 import Control.Concurrent.STM.TVar
 import Control.Concurrent.STM
-import UnliftIO (MonadUnliftIO)
+import Data.Hashable (hash)
+import UnliftIO (MonadUnliftIO(..))
+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 AnyMessage enc e = AnyMessage !Integer !(Encoded e)
@@ -132,8 +142,30 @@ 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
@@ -264,14 +296,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
 
@@ -280,12 +314,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))
@@ -369,6 +408,9 @@ newPeerEnv :: forall e m . ( MonadIO m
                            , Ord (Peer e)
                            , Pretty (Peer e)
                            , HasNonces () m
+                           , Asymm (Encryption e)
+                           , Hashable (PubKey 'Sign (Encryption e))
+                           , Hashable PeerNonce
                            )
           => AnyStorage
           -> Fabriq e
@@ -376,18 +418,21 @@ 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)
+  _envEncryptionKeys <- liftIO (newTVarIO mempty)
+  pure PeerEnv {..}
 
 runPeerM :: forall e m . ( MonadIO m
                          , HasPeer e

hbs2-core/lib/HBS2/Base58.hs

@@ -29,3 +29,6 @@ instance Pretty (AsBase58 ByteString) where
 instance Pretty (AsBase58 LBS.ByteString) where
   pretty (AsBase58 bs) = pretty $ BS8.unpack $ toBase58 (LBS.toStrict bs)
 
+instance Show (AsBase58 ByteString) where
+  show (AsBase58 bs) = BS8.unpack $ toBase58 bs
+

hbs2-core/lib/HBS2/Clock.hs

@@ -9,6 +9,7 @@ import Control.Monad.IO.Class
 import Data.Fixed
 import Data.Int (Int64)
 import Data.Proxy
+import Data.Time
 import Prettyprinter
 import System.Clock
 import Data.Time.Clock
@@ -34,6 +35,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/Data/Types.hs

@@ -1,13 +1,13 @@
 module HBS2.Data.Types
-  ( module HBS2.Hash
+  ( module X
-  , module HBS2.Data.Types.Refs
   -- , module HBS2.Data.Types.Crypto
   , AsSyntax(..)
   )
   where
 
-import HBS2.Hash
+import HBS2.Hash as X
-import HBS2.Data.Types.Refs
+import HBS2.Data.Types.Refs as X
+import HBS2.Data.Types.Peer as X
 -- import HBS2.Data.Types.Crypto
 
 -- import Data.Config.Suckless

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

@@ -1,4 +1,29 @@
 module HBS2.Data.Types.Crypto where
 
+import Codec.Serialise
+import Crypto.Saltine.Core.Box qualified as Encrypt
+import Crypto.Saltine.Core.Sign qualified as Sign
+
+import HBS2.Net.Auth.Credentials
+import HBS2.Net.Proto.Types
+import HBS2.Prelude
+
 -- type SignPubKey    = ()
 -- type EncryptPubKey = ()
+
+type instance PubKey  'Sign HBS2Basic = Sign.PublicKey
+type instance PrivKey 'Sign HBS2Basic = Sign.SecretKey
+type instance PubKey  'Encrypt HBS2Basic = Encrypt.PublicKey
+type instance PrivKey 'Encrypt HBS2Basic = Encrypt.SecretKey
+
+instance Serialise Sign.PublicKey
+instance Serialise Encrypt.PublicKey
+instance Serialise Sign.SecretKey
+instance Serialise Encrypt.SecretKey
+
+instance Serialise Sign.Signature
+
+instance Signatures HBS2Basic where
+  type Signature HBS2Basic = Sign.Signature
+  makeSign = Sign.signDetached
+  verifySign = Sign.signVerifyDetached

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

@@ -0,0 +1,45 @@
+{-# Language UndecidableInstances #-}
+module HBS2.Data.Types.Peer where
+
+import Codec.Serialise
+import Data.ByteString qualified as BS
+import Data.Hashable
+import Lens.Micro.Platform
+
+import HBS2.Prelude
+import HBS2.Data.Types.Crypto
+import HBS2.Net.Auth.Credentials
+import HBS2.Net.Proto.Types
+
+
+type PingSign e = Signature (Encryption e)
+type PingNonce = BS.ByteString
+
+data PeerData e =
+  PeerData
+  { _peerSignKey  :: PubKey 'Sign (Encryption e)
+  , _peerOwnNonce :: PeerNonce -- TODO: to use this field to detect if it's own peer to avoid loops
+  }
+  deriving stock (Typeable,Generic)
+
+deriving instance
+    ( Eq (PubKey 'Sign (Encryption e))
+    , Eq PeerNonce
+    )
+    => Eq (PeerData e)
+
+instance
+    ( Hashable (PubKey 'Sign (Encryption e))
+    , Hashable PeerNonce
+    )
+    => Hashable (PeerData e) where
+  hashWithSalt s PeerData{..} = hashWithSalt s (_peerOwnNonce)
+
+deriving instance
+    ( Show (PubKey 'Sign (Encryption e))
+    , Show PeerNonce
+    )
+    => Show (PeerData e)
+
+makeLenses 'PeerData
+

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

@@ -7,6 +7,7 @@ module HBS2.Net.Proto.Definition
   where
 
 import HBS2.Clock
+import HBS2.Data.Types.Crypto
 import HBS2.Defaults
 import HBS2.Hash
 import HBS2.Net.Auth.Credentials
@@ -14,6 +15,7 @@ import HBS2.Net.Proto
 import HBS2.Net.Proto.BlockAnnounce
 import HBS2.Net.Proto.BlockChunks
 import HBS2.Net.Proto.BlockInfo
+import HBS2.Net.Proto.EncryptionHandshake
 import HBS2.Net.Proto.Peer
 import HBS2.Net.Proto.PeerAnnounce
 import HBS2.Net.Proto.PeerExchange
@@ -22,25 +24,21 @@ import HBS2.Net.Proto.RefLog
 import HBS2.Net.Proto.RefChan
 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
 
+import HBS2.Data.Types.Crypto
 
 
 type instance Encryption L4Proto = HBS2Basic
 
-type instance PubKey  'Sign HBS2Basic = Sign.PublicKey
-type instance PrivKey 'Sign HBS2Basic = Sign.SecretKey
-type instance PubKey  'Encrypt HBS2Basic = Encrypt.PublicKey
-type instance PrivKey 'Encrypt HBS2Basic = Encrypt.SecretKey
-
 -- FIXME: proper-serialise-for-keys
 --   Возможно, нужно написать ручные инстансы Serialise
 --   использовать encode/decode для каждого инстанса ниже $(c:end + 4)
@@ -48,15 +46,15 @@ type instance PrivKey 'Encrypt HBS2Basic = Encrypt.SecretKey
 --   но возможно, будет работать и так, ведь ключи
 --   это же всего лишь байтстроки внутри.
 
-instance Serialise Sign.PublicKey
+deserialiseCustom :: (Serialise a, MonadPlus m) => ByteString -> m a
-instance Serialise Encrypt.PublicKey
+deserialiseCustom = either (const mzero) pure . deserialiseOrFail
-instance Serialise Sign.SecretKey
+-- deserialiseCustom = either (\msg -> trace ("deserialiseCustom: " <> show msg) mzero) pure . deserialiseOrFail
-instance Serialise Encrypt.SecretKey
+-- 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
@@ -66,7 +64,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
@@ -75,13 +73,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
@@ -89,19 +87,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
 
   -- TODO: find-out-optimal-max-safe-frequency
@@ -110,13 +108,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
@@ -153,6 +151,14 @@ instance HasProtocol L4Proto (RefChanRequest L4Proto) where
   -- но poll у нас в минутах, и с минимальным периодом 1 минута
   requestPeriodLim = ReqLimPerMessage 1
 
+instance HasProtocol L4Proto (EncryptionHandshake L4Proto) where
+  type instance ProtocolId (EncryptionHandshake L4Proto) = 10
+  type instance Encoded L4Proto = ByteString
+  decode = deserialiseCustom
+  encode = serialise
+
+  requestPeriodLim = ReqLimPerProto 0.5
+
 instance Expires (SessionKey L4Proto (BlockInfo L4Proto)) where
   expiresIn _ = Just defCookieTimeoutSec
 
@@ -171,48 +177,57 @@ instance Expires (SessionKey L4Proto (KnownPeer L4Proto)) where
 instance Expires (SessionKey L4Proto (PeerHandshake L4Proto)) where
   expiresIn _ = Just 60
 
+instance Expires (SessionKey L4Proto (EncryptionHandshake L4Proto)) where
+  expiresIn _ = Just 60
+
 instance Expires (EventKey L4Proto (PeerAnnounce L4Proto)) where
   expiresIn _ = Nothing
 
 instance Expires (EventKey L4Proto (PeerMetaProto L4Proto)) where
   expiresIn _ = Just 600
 
+-- instance Expires (EventKey L4Proto (EncryptionHandshake L4Proto)) where
+--   expiresIn _ = Just 600
+
 -- 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
+instance Asymm HBS2Basic where
-
+  type AsymmKeypair HBS2Basic = Encrypt.Keypair
-instance Signatures HBS2Basic where
+  type AsymmPrivKey HBS2Basic = Encrypt.SecretKey
-  type Signature HBS2Basic = Sign.Signature
+  type AsymmPubKey HBS2Basic = Encrypt.PublicKey
-  makeSign = Sign.signDetached
+  type CommonSecret HBS2Basic = Encrypt.CombinedKey
-  verifySign = Sign.signVerifyDetached
+  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/EncryptionHandshake.hs

@@ -0,0 +1,190 @@
+{-# Language TemplateHaskell #-}
+{-# Language UndecidableInstances #-}
+
+module HBS2.Net.Proto.EncryptionHandshake where
+
+import HBS2.Actors.Peer
+import HBS2.Clock
+import HBS2.Data.Types
+import HBS2.Net.Auth.Credentials
+import HBS2.Net.Proto
+import HBS2.Net.Proto.Peer
+import HBS2.Net.Proto.Sessions
+import HBS2.Prelude.Plated
+import HBS2.System.Logger.Simple
+
+import Crypto.Saltine.Core.Box qualified as Encrypt
+import Data.ByteString qualified as BS
+import Data.String.Conversions (cs)
+import Lens.Micro.Platform
+
+instance
+    ( Show (PubKey 'Encrypt (Encryption e))
+    , Show (PubKey 'Sign (Encryption e))
+    , Show (Nonce ())
+    )
+    => Pretty (PeerData e) where
+  pretty = viaShow
+
+data EncryptionHandshake e =
+    BeginEncryptionExchange (Signature (Encryption e)) (PubKey 'Encrypt (Encryption e))
+  | AckEncryptionExchange (Signature (Encryption e)) (PubKey 'Encrypt (Encryption e))
+  | ResetEncryptionKeys
+  deriving stock (Generic)
+
+sendResetEncryptionKeys :: forall e s m .
+    ( MonadIO m
+    , Request e (EncryptionHandshake e) m
+    , e ~ L4Proto
+    , s ~ Encryption e
+    )
+  => Peer e
+  -> m ()
+
+sendResetEncryptionKeys peer = do
+    request peer (ResetEncryptionKeys @e)
+
+sendBeginEncryptionExchange :: forall e s m .
+    ( MonadIO m
+    , Request e (EncryptionHandshake e) m
+    , Sessions e (EncryptionHandshake e) m
+    -- , HasCredentials s m
+    , Asymm s
+    , Signatures s
+    , Serialise (PubKey 'Encrypt s)
+    , Pretty (Peer e)
+    , HasProtocol e (EncryptionHandshake e)
+    , e ~ L4Proto
+    , s ~ Encryption e
+    )
+  => PeerCredentials s
+  -> PubKey 'Encrypt (Encryption e)
+  -> Peer e
+  -> m ()
+
+sendBeginEncryptionExchange creds ourpubkey peer = do
+    let sign = makeSign @s (view peerSignSk creds) ((cs . serialise) ourpubkey)
+    request peer (BeginEncryptionExchange @e sign ourpubkey)
+
+data EncryptionHandshakeAdapter e m s = EncryptionHandshakeAdapter
+  { encHandshake_considerPeerAsymmKey :: Peer e -> Maybe Encrypt.PublicKey -> m ()
+  }
+
+
+encryptionHandshakeProto :: forall e s m .
+    ( MonadIO m
+    , Response e (EncryptionHandshake e) m
+    , Request e (EncryptionHandshake e) m
+    , Sessions e (KnownPeer e) m
+    , HasCredentials s m
+    , Asymm s
+    , Signatures s
+    , Sessions e (EncryptionHandshake e) m
+    , Serialise (PubKey 'Encrypt (Encryption e))
+    , s ~ Encryption e
+    , e ~ L4Proto
+    , PubKey Encrypt s ~ Encrypt.PublicKey
+    , Show (PubKey 'Sign s)
+    , Show (Nonce ())
+    )
+  => EncryptionHandshakeAdapter e m s
+  -> PeerEnv e
+  -> EncryptionHandshake e
+  -> m ()
+
+encryptionHandshakeProto EncryptionHandshakeAdapter{..} penv = \case
+
+  ResetEncryptionKeys -> do
+      peer <- thatPeer proto
+      mpeerData <- find (KnownPeerKey peer) id
+      -- TODO: check theirsign
+      trace $ "ENCRYPTION EHSP ResetEncryptionKeys from" <+> viaShow (peer, mpeerData)
+
+      -- сначала удалим у себя его прошлый ключ
+      encHandshake_considerPeerAsymmKey peer Nothing
+
+      creds <- getCredentials @s
+      let ourpubkey = pubKeyFromKeypair @s $ view envAsymmetricKeyPair penv
+      sendBeginEncryptionExchange @e creds ourpubkey peer
+
+  BeginEncryptionExchange theirsign theirpubkey -> do
+      peer <- thatPeer proto
+      mpeerData <- find (KnownPeerKey peer) id
+      -- TODO: check theirsign
+
+      trace $ "ENCRYPTION EHSP BeginEncryptionExchange from" <+> viaShow (peer, mpeerData)
+
+      -- взять свои ключи
+      creds <- getCredentials @s
+
+      let ourpubkey = pubKeyFromKeypair @s $ view envAsymmetricKeyPair penv
+
+      -- подписать нонс
+      let sign = makeSign @s (view peerSignSk creds) ((cs . serialise) ourpubkey)
+
+      -- сначала удалим у себя его прошлый ключ
+      encHandshake_considerPeerAsymmKey peer Nothing
+
+      -- отправить обратно свой публичный ключ
+      -- отправится пока ещё в плоском виде
+      response (AckEncryptionExchange @e sign ourpubkey)
+
+      -- Только после этого прописываем его ключ у себя
+      encHandshake_considerPeerAsymmKey peer (Just theirpubkey)
+
+  AckEncryptionExchange theirsign theirpubkey -> do
+      peer <- thatPeer proto
+      mpeerData <- find (KnownPeerKey peer) id
+      -- TODO: check theirsign
+
+      trace $ "ENCRYPTION EHSP AckEncryptionExchange from" <+> viaShow (peer, mpeerData)
+
+      -- Он уже прописал у себя наш публичный ключ и готов общаться шифрованными сообщениями
+      -- Прописываем его ключ у себя
+      encHandshake_considerPeerAsymmKey peer (Just theirpubkey)
+
+  where
+    proto = Proxy @(EncryptionHandshake e)
+
+-----
+
+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)
+
+instance Expires (EventKey e (PeerAsymmInfo e)) where
+  expiresIn _ = Nothing
+
+instance
+  ( Serialise (PubKey 'Sign (Encryption e))
+  , Serialise (PubKey 'Encrypt (Encryption e))
+  , Serialise (Signature (Encryption e))
+  )
+  => Serialise (EncryptionHandshake e)
+
+deriving instance
+  ( Show (PubKey 'Encrypt (Encryption e))
+  , Show (Signature (Encryption e))
+  )
+  => Show (EncryptionHandshake e)
+
+type instance SessionData e (EncryptionHandshake e) = ()
+
+newtype instance SessionKey e (EncryptionHandshake e) =
+  KnownPeerAsymmInfoKey (Peer e)
+  deriving stock (Generic, Typeable)
+
+deriving instance Eq (Peer e) => Eq (SessionKey e (EncryptionHandshake e))
+instance Hashable (Peer e) => Hashable (SessionKey e (EncryptionHandshake e))
+
+data instance EventKey e (EncryptionHandshake e) =
+  AnyKnownPeerEncryptionHandshakeEventKey
+  deriving stock (Typeable, Eq,Generic)

hbs2-core/lib/HBS2/Net/Proto/Event/PeerExpired.hs

@@ -0,0 +1,35 @@
+module HBS2.Net.Proto.Event.PeerExpired where
+
+import HBS2.Clock
+import HBS2.Data.Types.Peer
+import HBS2.Events
+import HBS2.Net.Proto
+import HBS2.Net.Proto.Peer
+import HBS2.Prelude.Plated
+
+data PeerExpires = PeerExpires
+
+data instance EventKey e PeerExpires =
+  PeerExpiredEventKey
+  deriving stock (Typeable, Eq, Generic)
+
+data instance Event e PeerExpires =
+  PeerExpiredEvent (Peer e) -- (Maybe (PeerData e))
+  deriving stock (Typeable)
+
+instance EventType (Event e PeerExpires) where
+  isPersistent = True
+
+instance Expires (EventKey e PeerExpires) where
+  expiresIn _ = Nothing
+
+instance Hashable (EventKey e PeerExpires)
+
+--instance ( Serialise (PubKey 'Sign (Encryption e))
+--         , Serialise (PubKey 'Encrypt (Encryption e))
+--         , Serialise (Signature (Encryption e))
+--         , Serialise PeerNonce
+--         )
+
+--  => Serialise PeerExpires
+

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,33 +11,30 @@ 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)
 
-type PingSign e = Signature (Encryption e)
-type PingNonce = BS.ByteString
-
-data PeerData e =
-  PeerData
-  { _peerSignKey  :: PubKey 'Sign (Encryption e)
-  , _peerOwnNonce :: PeerNonce -- TODO: to use this field to detect if it's own peer to avoid loops
-  }
-  deriving stock (Typeable,Generic)
-
-makeLenses 'PeerData
-
 data PeerHandshake e =
     PeerPing  PingNonce
   | PeerPong  PingNonce (Signature (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)
 
@@ -104,14 +102,18 @@ peerHandShakeProto :: forall e s m . ( MonadIO m
                                      , EventEmitter e (PeerHandshake e) m
                                      , EventEmitter e (ConcretePeer 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
@@ -176,6 +178,8 @@ data instance Event e (ConcretePeer e) =
   ConcretePeerData (Peer e) (PeerData e)
   deriving stock (Typeable)
 
+---
+
 data instance EventKey e (PeerHandshake e) =
   AnyKnownPeerEventKey
   deriving stock (Typeable, Eq,Generic)
@@ -209,6 +213,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 +221,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,7 +115,23 @@ peerExchangeProto pexFilt  msg = do
 
       case pex of
         PEX1 -> do
+          pa <- take defPexMaxPeers <$> getAllPex1Peers
+          response (PeerExchangePeers @e n pa)
 
+        PEX2 -> do
+          pa <- take defPexMaxPeers <$> getAllPex2Peers
+          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
@@ -118,22 +139,23 @@ peerExchangeProto pexFilt  msg = do
                 case pa of
                     (L4Address UDP x) | auth -> pure [x]
                     _ -> pure mempty
+    pure $ mconcat pa'
 
-          let pa = take defPexMaxPeers $ mconcat pa'
+getAllPex2Peers :: forall e m .
-
+  ( MonadIO m
-          response (PeerExchangePeers @e n pa)
+  , Sessions e (KnownPeer e) m
-
+  , HasPeerLocator L4Proto m
-        PEX2 -> do
+  , 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
-          let pa = take defPexMaxPeers $ mconcat pa'
+    pure $ mconcat pa'
-
-          response (PeerExchangePeers2 @e n 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

@@ -111,7 +111,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/lib/HBS2/Prelude.hs

@@ -1,6 +1,7 @@
 module HBS2.Prelude
   ( module Data.String
   , module Safe
+  , module X
   , MonadIO(..)
   , void, guard, when, unless
   , maybe1
@@ -17,6 +18,9 @@ module HBS2.Prelude
   , Text.Text
   ) where
 
+import Data.Typeable as X
+import GHC.Generics as X (Generic)
+
 import Data.ByteString (ByteString)
 import Data.String (IsString(..))
 import Safe

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/Bootstrap.hs

@@ -1,6 +1,7 @@
 {-# Language AllowAmbiguousTypes #-}
 module Bootstrap where
 
+import HBS2.Data.Types.Peer
 import HBS2.Prelude
 import HBS2.Net.Proto.Types
 import HBS2.Net.Proto.Peer

hbs2-peer/app/Brains.hs

@@ -17,9 +17,11 @@ import HBS2.System.Logger.Simple
 
 import PeerConfig
 
-import Control.Concurrent.STM
+import Crypto.Saltine.Core.Box qualified as Encrypt
-import Control.Exception
+import Data.Maybe
 import Control.Monad
+import Control.Exception
+import Control.Concurrent.STM
 import Database.SQLite.Simple
 import Database.SQLite.Simple.FromField
 import Data.Cache (Cache)
@@ -633,6 +635,56 @@ transactional brains action = do
       err $ "BRAINS: " <+> viaShow e
       execute_ conn [qc|ROLLBACK TO SAVEPOINT {sp}|]
 
+---
+
+insertPeerAsymmKey :: forall e m . (e ~ L4Proto, MonadIO m)
+    => BasicBrains e
+    -> Peer e
+    -> Encrypt.PublicKey
+    -> Encrypt.CombinedKey
+    -> m ()
+
+insertPeerAsymmKey br peer hAsymmKey hSymmKey = do
+    insertPeerAsymmKey br peer hAsymmKey hSymmKey
+    insertPeerAsymmKey' br (show $ pretty peer) hAsymmKey hSymmKey
+
+insertPeerAsymmKey' :: forall e m . (e ~ L4Proto, MonadIO m)
+    => BasicBrains e
+    -> String
+    -> Encrypt.PublicKey
+    -> Encrypt.CombinedKey
+    -> m ()
+
+insertPeerAsymmKey' br key hAsymmKey hSymmKey = do
+  let conn = view brainsDb br
+  void $ liftIO $ execute conn [qc|
+        INSERT INTO peer_asymmkey (peer,asymmkey,symmkey)
+        VALUES (?,?,?)
+        ON CONFLICT (peer)
+        DO UPDATE SET
+          asymmkey = excluded.asymmkey
+        , symmkey = excluded.symmkey
+    |] (key, show hAsymmKey, show hSymmKey)
+
+---
+
+deletePeerAsymmKey :: forall e m . (e ~ L4Proto, MonadIO m)
+    => BasicBrains e -> Peer e -> m ()
+
+deletePeerAsymmKey br peer =
+    deletePeerAsymmKey' br (show $ pretty peer)
+
+deletePeerAsymmKey' :: forall e m . (e ~ L4Proto, MonadIO m)
+    => BasicBrains e -> String -> m ()
+
+deletePeerAsymmKey' br key =
+    void $ liftIO $ execute (view brainsDb br) [qc|
+        DELETE FROM peer_asymmkey
+        WHERE peer = ?
+    |] (Only key)
+
+---
+
 -- FIXME: eventually-close-db
 newBasicBrains :: forall e m . (Hashable (Peer e), MonadIO m)
                => PeerConfig
@@ -731,6 +783,16 @@ newBasicBrains cfg = liftIO do
   |]
 
 
+  execute_ conn [qc|
+    create table if not exists peer_asymmkey
+    ( peer text not null
+    , asymmkey text not null
+    , symmkey text not null
+    , ts DATE DEFAULT (datetime('now','localtime'))
+    , primary key (peer)
+    )
+  |]
+
   BasicBrains <$> newTVarIO mempty
               <*> newTVarIO mempty
               <*> Cache.newCache (Just (toTimeSpec (30 :: Timeout 'Seconds)))

hbs2-peer/app/EncryptionKeys.hs

@@ -0,0 +1,82 @@
+module EncryptionKeys where
+
+import HBS2.Actors.Peer
+import HBS2.Base58
+import HBS2.Clock
+import HBS2.Data.Detect
+import HBS2.Data.Types.Refs
+import HBS2.Events
+import HBS2.Hash
+import HBS2.Merkle
+import HBS2.Net.Auth.Credentials
+import HBS2.Net.PeerLocator
+import HBS2.Net.Proto
+import HBS2.Net.Proto.EncryptionHandshake
+import HBS2.Net.Proto.Peer
+import HBS2.Net.Proto.Sessions
+import HBS2.Prelude.Plated
+import HBS2.Storage
+import HBS2.System.Logger.Simple
+
+import PeerConfig
+import PeerTypes
+
+import Codec.Serialise
+import Control.Concurrent.Async
+import Control.Concurrent.STM
+import Control.Monad
+import Control.Monad.Reader
+import Control.Monad.Trans.Maybe
+import Data.ByteString qualified as BS
+import Data.ByteString.Lazy qualified as LBS
+import Data.Foldable(for_)
+import Data.Function(fix)
+import Data.Functor
+import Data.HashMap.Strict qualified as HashMap
+import Data.HashSet (HashSet)
+import Data.HashSet qualified as HashSet
+import Data.Maybe
+import Data.Text qualified as Text
+
+
+encryptionHandshakeWorker :: forall e m s .
+    ( MonadIO m
+    , m ~ PeerM e IO
+    , s ~ Encryption e
+    , e ~ L4Proto
+    , HasPeerLocator e m
+    -- , HasPeer e
+    -- , HasNonces (EncryptionHandshake e) m
+    -- , Request e (EncryptionHandshake e) m
+    -- , Sessions e (EncryptionHandshake e) m
+    -- , Sessions e (PeerInfo e) m
+    -- , Sessions e (KnownPeer e) m
+    -- , Pretty (Peer e)
+    -- , HasCredentials s m
+    )
+  => PeerConfig
+  -> PeerEnv e
+  -> PeerCredentials s
+  -> EncryptionHandshakeAdapter e m s
+  -> m ()
+
+encryptionHandshakeWorker pconf penv creds EncryptionHandshakeAdapter{..} = do
+
+    -- e :: PeerEnv e <- ask
+    let ourpubkey = pubKeyFromKeypair @s $ _envAsymmetricKeyPair penv
+
+    pl <- getPeerLocator @e
+
+    forever do
+        liftIO $ pause @'Seconds 30
+
+        peers <- knownPeers @e pl
+
+        forM_ peers \peer -> do
+            -- Только если ещё не знаем ключ ноды
+            mpeerData <- find (KnownPeerKey peer) id
+            mkey <- liftIO do
+                join <$> forM mpeerData \peerData -> getEncryptionKey penv peerData
+            case mkey of
+                Just _ -> pure ()
+                Nothing -> sendBeginEncryptionExchange @e creds ourpubkey peer

hbs2-peer/app/HttpWorker.hs

@@ -4,6 +4,7 @@ import HBS2.Prelude
 import HBS2.Actors.Peer
 import HBS2.Storage
 import HBS2.Data.Types.Refs
+import HBS2.Merkle (AnnMetaData)
 import HBS2.Net.Proto.Types
 import HBS2.Net.Proto.RefLog
 import HBS2.Events
@@ -33,9 +34,9 @@ httpWorker :: forall e s m . ( MyPeer e
                              , s ~ Encryption e
                              , m ~ PeerM e IO
                              , e ~ L4Proto
-                             ) => 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
@@ -90,7 +91,7 @@ httpWorker conf e = do
             status status200
 
       get "/metadata" do
-          raw $ serialise $ mkPeerMeta conf
+          raw $ serialise $ pmeta
 
       put "/" do
         -- FIXME: optional-header-based-authorization

hbs2-peer/app/PeerInfo.hs

@@ -4,8 +4,11 @@ module PeerInfo where
 
 import HBS2.Actors.Peer
 import HBS2.Clock
+import HBS2.Data.Types
 import HBS2.Events
+import HBS2.Net.Auth.Credentials
 import HBS2.Net.PeerLocator
+import HBS2.Net.Proto.Event.PeerExpired
 import HBS2.Net.Proto.Peer
 import HBS2.Net.Proto.PeerExchange
 import HBS2.Net.Proto.Sessions
@@ -145,8 +148,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
 
@@ -217,9 +220,11 @@ peerPingLoop cfg = do
                 let l = realToFrac (toNanoSecs $ now - seen) / 1e9
                 -- FIXME: time-hardcode
                 when ( l > 300 ) do
+                  mpeerData <- find (KnownPeerKey p) id
                   delPeers pl [p]
                   expire (PeerInfoKey p)
                   expire (KnownPeerKey p)
+                  emit PeerExpiredEventKey (PeerExpiredEvent @e p {-mpeerData-})
 
   liftIO $ mapM_ link [watch, infoLoop]
 
@@ -240,7 +245,6 @@ 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
-

hbs2-peer/app/PeerMain.hs

@@ -14,13 +14,17 @@ import HBS2.Defaults
 import HBS2.Events
 import HBS2.Hash
 import HBS2.Data.Types.Refs
+import HBS2.Data.Types
 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.EncryptionHandshake
+import HBS2.Net.Proto.Event.PeerExpired
 import HBS2.Net.Proto.Peer
 import HBS2.Net.Proto.PeerAnnounce
 import HBS2.Net.Proto.PeerExchange
@@ -45,6 +49,7 @@ import PeerInfo
 import PeerConfig
 import Bootstrap
 import CheckMetrics
+import EncryptionKeys
 import RefLog qualified
 import RefLog (reflogWorker)
 import HttpWorker
@@ -53,7 +58,7 @@ import PeerMeta
 import CLI.RefChan
 import RefChan
 
-import Codec.Serialise
+import Codec.Serialise as Serialise
 -- import Control.Concurrent.Async
 import Control.Concurrent.STM
 import Control.Exception as Exception
@@ -67,6 +72,7 @@ import Data.ByteString qualified as BS
 import Data.Cache qualified as Cache
 import Data.Function
 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
@@ -77,7 +83,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
@@ -87,6 +93,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
@@ -228,6 +235,7 @@ runCLI = join . customExecParser (prefs showHelpOnError) $
                         <> command "reflog"    (info pRefLog (progDesc "reflog commands"))
                         <> command "refchan"   (info pRefChan (progDesc "refchan commands"))
                         <> command "peers"     (info pPeers (progDesc "show known peers"))
+                        <> command "pexinfo"   (info pPexInfo (progDesc "show pex"))
                         <> command "log"       (info pLog   (progDesc "set logging level"))
                         )
 
@@ -289,6 +297,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")  ) )
@@ -479,16 +491,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
 
@@ -548,11 +560,42 @@ runPeer opts = U.handle (\e -> myException e
            void $ async $ runMessagingTCP tcpEnv
            pure $ Just tcpEnv
 
-  proxy <- newProxyMessaging mess tcp
+  (proxy, penv) <- mdo
+      proxy <- newProxyMessaging mess tcp >>= \peer -> pure peer
+            { _proxy_getEncryptionKey = \peer -> do
+                  mpeerData <- withPeerM penv $ find (KnownPeerKey peer) id
+                  mkey <- join <$> forM mpeerData \peerData -> getEncryptionKey penv peerData
+                  case mkey of
+                      Nothing ->
+                          trace $ "ENCRYPTION empty getEncryptionKey"
+                              <+> pretty peer <+> viaShow mpeerData
+                      Just k ->
+                          trace $ "ENCRYPTION success getEncryptionKey"
+                              <+> pretty peer <+> viaShow mpeerData <+> viaShow k
+                  pure mkey
+
+            , _proxy_clearEncryptionKey = \peer -> do
+                  mpeerData <- withPeerM penv $ find (KnownPeerKey peer) id
+                  forM_ mpeerData \peerData -> setEncryptionKey penv peer peerData Nothing
+                  -- deletePeerAsymmKey brains peer
+                  forM_ mpeerData \peerData ->
+                      deletePeerAsymmKey' brains (show peerData)
+
+            , _proxy_sendResetEncryptionKeys = \peer -> withPeerM penv do
+                  sendResetEncryptionKeys peer
+
+            , _proxy_sendBeginEncryptionExchange = \peer -> withPeerM penv do
+                  sendBeginEncryptionExchange pc
+                      ((pubKeyFromKeypair @s . view envAsymmetricKeyPair) penv)
+                      peer
+
+          }
+      penv <- newPeerEnv (AnyStorage s) (Fabriq proxy) (getOwnPeer mess)
+      pure (proxy, penv)
 
   proxyThread <- async $ runProxyMessaging proxy
 
-  penv <- newPeerEnv (AnyStorage s) (Fabriq proxy) (getOwnPeer mess)
+  let peerMeta = mkPeerMeta conf penv
 
   nbcache <- liftIO $ Cache.newCache (Just $ toTimeSpec ( 600 :: Timeout 'Seconds))
 
@@ -581,8 +624,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 $ \pd -> do
             let pk = view peerSignKey pd
             when (Set.member pk helpFetchKeys) do
               liftIO $ Cache.insert nbcache (p,h) ()
@@ -624,6 +667,36 @@ runPeer opts = U.handle (\e -> myException e
 
               let hshakeAdapter = PeerHandshakeAdapter addNewRtt
 
+              let encryptionHshakeAdapter ::
+                      ( MonadIO m
+                      , EventEmitter e (PeerAsymmInfo e) m
+                      ) => EncryptionHandshakeAdapter L4Proto m s
+                  encryptionHshakeAdapter = EncryptionHandshakeAdapter
+                    { encHandshake_considerPeerAsymmKey = \peer mpubkey -> withPeerM penv do
+                          mpeerData <- withPeerM penv $ find (KnownPeerKey peer) id
+                          case mpubkey of
+                              Nothing -> do
+                                  -- trace $ "ENCRYPTION delete key" <+> pretty peer <+> viaShow mpeerData
+                                  -- deletePeerAsymmKey brains peer
+                                  forM_ mpeerData \peerData ->
+                                      deletePeerAsymmKey' brains (show peerData)
+                              Just pk -> do
+                                  -- emit PeerAsymmInfoKey (PeerAsymmPubKey peer pk)
+                                  let symmk = genCommonSecret @s
+                                          (privKeyFromKeypair @s (view envAsymmetricKeyPair penv))
+                                          pk
+                                  case mpeerData of
+                                      Nothing -> do
+                                          -- insertPeerAsymmKey brains peer pk symmk
+                                          -- insertPeerAsymmKey' brains (show peer) pk symmk
+                                          trace $ "ENCRYPTION can not store key. No peerData"
+                                              <+> pretty peer <+> viaShow mpeerData
+                                      Just peerData -> do
+                                          liftIO $ setEncryptionKey penv peer peerData (Just symmk)
+                                          insertPeerAsymmKey' brains (show peerData) pk symmk
+
+                    }
+
               env <- ask
 
               pnonce <- peerNonce @e
@@ -632,29 +705,39 @@ runPeer opts = U.handle (\e -> myException e
 
               addPeers @e pl ps
 
+              subscribe @e PeerExpiredEventKey \(PeerExpiredEvent peer {-mpeerData-}) -> liftIO do
+                  mpeerData <- withPeerM penv $ find (KnownPeerKey peer) id
+                  forM_ mpeerData \peerData -> setEncryptionKey penv peer peerData Nothing
+                  -- deletePeerAsymmKey brains peer
+                  forM_ mpeerData \peerData ->
+                      deletePeerAsymmKey' brains (show peerData)
+
               subscribe @e PeerAnnounceEventKey $ \(PeerAnnounceEvent pip nonce) -> do
                unless (nonce == pnonce) $ do
                  debug $ "Got peer announce!" <+> pretty pip
-                 pd <- find (KnownPeerKey pip) id -- <&> isJust
+                 mpd :: Maybe (PeerData e) <- find (KnownPeerKey pip) id
-                 banned <- maybe (pure False) (peerBanned pip) pd
+                 banned <- maybe (pure False) (peerBanned pip) mpd
-                 let known = isJust pd && not banned
+                 let known = isJust mpd && 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 AnyKnownPeerEventKey $ \(KnownPeerEvent p pd) -> do
 
-                let thatNonce = view peerOwnNonce d
+                let thatNonce = view peerOwnNonce pd
 
                 now <- liftIO getTimeCoarse
-                pinfo' <- find (PeerInfoKey p) id -- (view peerPingFailed)
+
-                maybe1 pinfo' none $ \pinfo -> do
+                -- defPeerInfo <- newPeerInfo
+                -- fetch True defPeerInfo (PeerInfoKey p) id >>= \pinfo -> do
+
+                find (PeerInfoKey p) id >>= mapM_ \pinfo -> do
                       liftIO $ atomically $ writeTVar (view peerPingFailed pinfo) 0
                       liftIO $ atomically $ writeTVar (view peerLastWatched pinfo) now
 
-                banned <- peerBanned p d
+                banned <- peerBanned p pd
 
                 let doAddPeer p = do
                       addPeers pl [p]
@@ -666,7 +749,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)
 
 
@@ -682,18 +765,15 @@ runPeer opts = U.handle (\e -> myException e
 
                    | otherwise -> do
 
-                    update d (KnownPeerKey p) id
+                    update pd (KnownPeerKey p) id
 
-                    pd' <- knownPeers @e pl >>=
+                    pdkv :: 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 peerOwnNonce)
-                                          pure $ (,pip) <$> pd
-
-                    let pd = Map.fromList $ catMaybes pd'
 
                     let proto1 = view sockType p
 
-                    case Map.lookup thatNonce pd of
+                    case Map.lookup thatNonce pdkv of
 
                       -- TODO: prefer-local-peer-with-same-nonce-over-remote-peer
                       --   remove remote peer
@@ -758,11 +838,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)
 
@@ -772,6 +852,9 @@ runPeer opts = U.handle (\e -> myException e
 
                 peerThread "blockDownloadLoop" (blockDownloadLoop denv)
 
+                peerThread "encryptionHandshakeWorker"
+                    (EncryptionKeys.encryptionHandshakeWorker @e conf penv pc encryptionHshakeAdapter)
+
                 let tcpProbeWait :: Timeout 'Seconds
                     tcpProbeWait = (fromInteger . fromMaybe 300) (cfgValue @PeerTcpProbeWaitKey conf)
 
@@ -798,11 +881,14 @@ 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
 
@@ -832,13 +918,13 @@ 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?
@@ -886,11 +972,12 @@ 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 (withCredentials @e pc . encryptionHandshakeProto encryptionHshakeAdapter penv)
                     , makeResponse (peerExchangeProto pexFilt)
                     , makeResponse (refLogUpdateProto reflogAdapter)
                     , makeResponse (refLogRequestProto reflogReqAdapter)
-                    , makeResponse (peerMetaProto (mkPeerMeta conf))
+                    , makeResponse (peerMetaProto peerMeta)
                     , makeResponse (refChanHeadProto False refChanAdapter)
                     , makeResponse (refChanUpdateProto False pc refChanAdapter)
                     , makeResponse (refChanRequestProto False refChanAdapter)
@@ -937,11 +1024,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 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

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'
+      for_ ps' $ \p -> do
         npi <- newPeerInfo
-    for_ ps $ \p -> do
 
         pinfo <- fetch True npi (PeerInfoKey p) id
         mmApiAddr <- liftIO $ readTVarIO (_peerHttpApiAddress pinfo)

hbs2-peer/app/PeerTypes.hs

@@ -8,9 +8,12 @@ module PeerTypes where
 import HBS2.Actors.Peer
 import HBS2.Actors.Peer.Types
 import HBS2.Clock
+import HBS2.Data.Types.Peer
 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
@@ -31,12 +34,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
@@ -47,8 +53,9 @@ import Data.Text qualified as Text
 import Data.Text.Encoding qualified as TE
 import Data.Time.Clock (NominalDiffTime)
 import Data.Heap qualified as Heap
-import Data.Heap (Entry(..))
+import Data.Heap (Heap,Entry(..))
--- import Data.Time.Clock
+import Data.Time.Clock
+import Data.Word
 
 data PeerInfo e =
   PeerInfo
@@ -77,23 +84,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
 
@@ -376,8 +385,8 @@ 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
@@ -394,18 +403,29 @@ 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 ,)
 
 
 data Polling =

hbs2-peer/app/ProxyMessaging.hs

@@ -1,26 +1,43 @@
 {-# Language TemplateHaskell #-}
 module ProxyMessaging
-  ( ProxyMessaging
+  ( ProxyMessaging(..)
   , newProxyMessaging
   , runProxyMessaging
+  , 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 Lens.Micro.Platform
+import Data.Map (Map)
+import Data.Map qualified as Map
+import Lens.Micro.Platform as Lens
 import Control.Monad
 
 -- TODO: protocol-encryption-goes-here
@@ -29,9 +46,19 @@ data ProxyMessaging  =
   ProxyMessaging
   { _proxyUDP :: MessagingUDP
   , _proxyTCP  :: Maybe MessagingTCP
-  , _proxyAnswers :: TQueue (From L4Proto, ByteString)
+  , _proxyAnswers :: TQueue (From L4Proto, LBS.ByteString)
+
+  , _proxy_getEncryptionKey :: Peer L4Proto -> IO (Maybe (CommonSecret (Encryption L4Proto)))
+  , _proxy_clearEncryptionKey :: Peer L4Proto -> IO ()
+  , _proxy_sendResetEncryptionKeys :: Peer L4Proto -> IO ()
+  , _proxy_sendBeginEncryptionExchange :: Peer L4Proto -> IO ()
   }
 
+-- 1 нода X создаёт себе Encrypt.Keypair
+-- 2 подписывает из него публичный ключ ключом подписи ноды X и отправляет ноде Y
+-- 3 нода Y получила Публичный ключ ноды X, создала симметричный Key,
+--   зашифровала его для полученного Публичного ключа ноды X и отравила ей
+
 makeLenses 'ProxyMessaging
 
 newProxyMessaging :: forall m . MonadIO m
@@ -40,8 +67,16 @@ newProxyMessaging :: forall m . MonadIO m
                   -> m ProxyMessaging
 
 newProxyMessaging u t = liftIO do
-  ProxyMessaging u t
+    let _proxyUDP = u
-    <$> newTQueueIO
+    let _proxyTCP = t
+    _proxyAnswers <- newTQueueIO
+
+    let _proxy_getEncryptionKey = const (pure Nothing)
+    let _proxy_clearEncryptionKey = const (pure ())
+    let _proxy_sendResetEncryptionKeys = const (pure ())
+    let _proxy_sendBeginEncryptionExchange = const (pure ())
+
+    pure ProxyMessaging {..}
 
 runProxyMessaging :: forall m . MonadIO  m
                   => ProxyMessaging
@@ -66,23 +101,120 @@ runProxyMessaging env = liftIO do
 
   liftIO $ mapM_ waitCatch [u,t]
 
-instance Messaging ProxyMessaging L4Proto ByteString where
 
-  sendTo bus t@(To whom) f m = do
+instance Messaging ProxyMessaging L4Proto LBS.ByteString where
-    -- sendTo (view proxyUDP bus)  t f m
+
-    -- trace $ "PROXY: SEND" <+> pretty whom
+  sendTo = sendToProxyMessaging
+
+  receive = receiveFromProxyMessaging
+
+  -- receive bus _ = liftIO do
+  --   -- trace "PROXY: RECEIVE"
+  --   -- receive (view proxyUDP bus) w
+  --   let answ = view proxyAnswers bus
+  --   atomically $ do
+  --     r <- readTQueue answ
+  --     rs <- flushTQueue answ
+  --     pure (r:rs)
+
+sendToPlainProxyMessaging :: (MonadIO m)
+  => ProxyMessaging
+  -> To L4Proto
+  -> From L4Proto
+  -> LBS.ByteString
+  -> m ()
+sendToPlainProxyMessaging 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
+sendToProxyMessaging :: (MonadIO m)
+  => ProxyMessaging
+  -> To L4Proto
+  -> From L4Proto
+  -> LBS.ByteString
+  -> m ()
+sendToProxyMessaging bus t@(To whom) proto msg = do
+    -- sendTo (view proxyUDP bus)  t proto msg
+    -- trace $ "PROXY: SEND" <+> pretty whom
+    mencKey <- liftIO $ _proxy_getEncryptionKey bus whom
+    cf <- case mencKey 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
+    sendToPlainProxyMessaging 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
+        fmap (w, ) <$> dfm whom msg
-      pure (r:rs)
 
+    -- Здесь:
+    -- 1. У нас есть ключ сессии и мы не смогли расшифровать -> do
+    --     удаляем у себя ключ
+    --     отправляем sendBeginEncryptionExchange
+    -- 2. У нас (до сих пор, даже если мы давно стартовали) нет ключа сессии -> do
+    --     sendResetEncryptionKeys
+    --     просто передаём сообщение как есть
+
+    -- В протоколе пингов:
+    -- 1. Если слишком долго нет ответа на ping, то удаляем у себя ключ, отправляем sendResetEncryptionKeys
+    --       Выполняется в PeerInfo:
+    --       emit PeerExpiredEventKey (PeerExpiredEvent @e p mpeerData)
+
+    where
+      dfm :: Peer L4Proto -> LBS.ByteString -> IO (Maybe LBS.ByteString)
+      dfm = \whom msg -> liftIO $ _proxy_getEncryptionKey bus whom >>= \case
+
+          Nothing -> do
+              trace $ "ENCRYPTION RECEIVE: we do not have a key to decode" <+> pretty whom
+              liftIO $ _proxy_sendBeginEncryptionExchange bus whom
+              pure (Just msg)
+
+          Just k -> runMaybeT $
+            -- А будем-ка мы просто передавать сообщение дальше как есть, если не смогли расшифровать
+            (<|> (do
+
+                liftIO $ _proxy_clearEncryptionKey bus whom
+
+                liftIO $ _proxy_sendResetEncryptionKeys bus whom
+
+                trace $ "ENCRYPTION RECEIVE: got plain message. clearing key of" <+> pretty whom
+                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
+                      fail ""
+
+                  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)
+                          fail ""
+
+                          -- -- Попытаться десериализовать сообщение как PeerPing или PeerPingCrypted
+                          -- case deserialiseOrFail msg of
+                          --   Right (_ :: PeerHandshake L4Proto) -> do
+                          --       trace $ "ENCRYPTION RECEIVE: plain message decoded as PeerHandshake" <+> pretty whom
+                          --       fail ""
+                          --   Left _ -> do
+                          --       trace $ "ENCRYPTION RECEIVE: failed" <+> pretty whom
+                          --       mzero
+
+                      )

hbs2-peer/app/RPC.hs

@@ -57,6 +57,7 @@ data RPCCommand =
   | CHECK PeerNonce (PeerAddr L4Proto) (Hash HbSync)
   | FETCH (Hash HbSync)
   | PEERS
+  | PEXINFO
   | SETLOG SetLogging
   | REFLOGUPDATE ByteString
   | REFLOGFETCH (PubKey 'Sign (Encryption L4Proto))
@@ -79,6 +80,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))
@@ -98,6 +101,11 @@ data RPC e =
 
   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
@@ -127,6 +135,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 ()
@@ -194,6 +204,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

@@ -49,6 +49,7 @@ common common-deps
         , stm
         , streaming
         , sqlite-simple
+        , time
         , temporary
         , text
         , time
@@ -61,6 +62,7 @@ common common-deps
         , filelock
         , ekg-core
         , scotty
+        , string-conversions
         , warp
         , http-conduit
         , http-types
@@ -107,6 +109,8 @@ common shared-properties
                      , MultiParamTypeClasses
                      , OverloadedStrings
                      , QuasiQuotes
+                     , RecordWildCards
+                     , RecursiveDo
                      , ScopedTypeVariables
                      , StandaloneDeriving
                      , TupleSections
@@ -123,6 +127,7 @@ executable hbs2-peer
     other-modules:    BlockDownload
                     , BlockHttpDownload
                     , DownloadQ
+                    , EncryptionKeys
                     , Bootstrap
                     , PeerInfo
                     , PeerMeta

hbs2/Main.hs

@@ -548,6 +548,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