From 01982d37c10050c6b529ccfcf2600928e3ffbc39 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Tue, 4 Jul 2023 15:29:54 +0300 Subject: [PATCH 01/31] Squashed commit of the following: commit cc3d5a357eee5c0e01f530808f8122f83b5103a2 Author: Dmitry Zuikov Date: Tue Jul 4 15:29:09 2023 +0300 fixme commit abae50a7895fdfc70e3a9204288a1af1a00f1c77 Author: Sergey Ivanov Date: Mon Jul 3 20:05:08 2023 +0400 encryption debug -> traces commit e8cab85da295ad81896726bf41f118bc2eb6e79e Author: Sergey Ivanov Date: Mon Jul 3 00:21:34 2023 +0400 bus encryption fixed commit cbb3e796b0d919d6d425a5d8c669cfce2ed02182 Merge: a740db8 55cdf97 Author: Sergey Ivanov Date: Sat Jul 1 23:17:52 2023 +0400 Merge branch 'master' into iv/bus-crypt commit a740db82351dcbc40604413df9af210212e1cbc1 Author: Sergey Ivanov Date: Wed Jun 21 16:08:05 2023 +0400 drop one traceShowId uasge commit 82de8d8c675cf21e732dc8db9b64139c7c2407ad Author: Sergey Ivanov Date: Wed Jun 21 13:33:34 2023 +0400 Edit README.md fix typo commit ec4dc7733215f19009da9334b82fd568e16eb143 Author: Sergey Ivanov Date: Wed Jun 21 13:32:54 2023 +0400 Rename deserialiseTrace -> deserialiseCustom commit 863394449798d8c534c58dc2d69add3e5a807e56 Author: Sergey Ivanov Date: Thu Jun 15 05:37:52 2023 +0400 PR bus-crypt commit 78dd65959906944935f99371ee973fc6c2c659b9 Author: Sergey Ivanov Date: Thu Jun 15 05:33:13 2023 +0400 Drop unused lines commit 9736077a96061c62e928b657e7c7558f9172636c Author: Sergey Ivanov Date: Thu Jun 15 05:24:33 2023 +0400 Encryption works commit c69aede965242281b525c088e1f27708a6741651 Author: Sergey Ivanov Date: Wed Jun 14 20:52:48 2023 +0400 wip commit 88fc2aac5b4fc1d452e74bf99213a57dad09b1c3 Author: Sergey Ivanov Date: Wed Jun 14 15:52:32 2023 +0400 Test roundtrip combineNonceBS/extractNonce commit 2d2f6945f4c917347c8f30e195764e2b0837fb25 Author: Sergey Ivanov Date: Tue Jun 13 14:08:56 2023 +0400 wip commit 31466fd036d74d8c4b769c7ffb0fa9dfda03eb26 Author: Sergey Ivanov Date: Tue Jun 13 10:03:15 2023 +0400 trace locked requests commit 85eb68a6747fb307c07fb0fcf681118250b37fab Author: Sergey Ivanov Date: Mon Jun 12 20:02:32 2023 +0400 added Show instances commit 74383bd7db9dd6838b4d026a3997c5c5b4799fa4 Author: Sergey Ivanov Date: Mon Jun 12 09:56:14 2023 +0400 DEBUG commit d62b30dbcdae6584f78cc2b6d8a801ff46cfdfa8 Author: Sergey Ivanov Date: Sun Jun 11 18:28:49 2023 +0400 wip commit 78b3f24ae1c4b632756f3a28873f4d03bbaa1330 Author: Sergey Ivanov Date: Sun Jun 11 08:45:58 2023 +0400 trace encrypted receiveing commit 93e2b9f7a7c2b579e5e46b6329a6509b8e5119de Author: Sergey Ivanov Date: Sat Jun 10 16:57:59 2023 +0400 wip commit 4686274d0fb401b722fca10ec0c2dbee00a4c68a Author: Sergey Ivanov Date: Fri Jun 9 23:38:56 2023 +0400 Use PeerDataExt commit 0c24c2702b47db262fa086efb6cff108b8ce28e8 Author: Sergey Ivanov Date: Thu Jun 8 03:04:39 2023 +0400 Encrypted Handshake commit 789536f20bc4f95320d2a4779a4a5b06d52b98f2 Author: Sergey Ivanov Date: Wed Jun 7 00:56:34 2023 +0400 Fixed fillPeerMeta timeout algorithm commit d52ac19777ba1c47f1123c5452309da4391ca21f Author: Sergey Ivanov Date: Fri Jun 2 01:50:17 2023 +0400 wip commit ea6833f812f9f137880229547622a3cf1ae55222 Author: Sergey Ivanov Date: Tue May 30 22:14:25 2023 +0400 wip commit 4ffdfc60ccc5c053da2d81ea16847f25f14c6220 Author: Sergey Ivanov Date: Sat May 27 21:42:01 2023 +0400 Symmetrical encryption in ProxyMessaging commit 7cd1214e9e00901fcd3d9e2966348dd800ab4119 Author: Sergey Ivanov Date: Fri May 26 15:03:43 2023 +0400 pex monitor --- README.md | 2 +- docs/devlog.md | 8 + hbs2-core/hbs2-core.cabal | 8 + hbs2-core/lib/HBS2/Actors/Peer.hs | 57 +++-- hbs2-core/lib/HBS2/Clock.hs | 4 + hbs2-core/lib/HBS2/Crypto.hs | 28 +++ hbs2-core/lib/HBS2/Net/Auth/Credentials.hs | 9 + hbs2-core/lib/HBS2/Net/Proto/BlockAnnounce.hs | 2 + hbs2-core/lib/HBS2/Net/Proto/BlockChunks.hs | 4 +- hbs2-core/lib/HBS2/Net/Proto/Definition.hs | 45 ++-- hbs2-core/lib/HBS2/Net/Proto/Peer.hs | 166 +++++++++++- hbs2-core/lib/HBS2/Net/Proto/PeerAnnounce.hs | 2 + hbs2-core/lib/HBS2/Net/Proto/PeerExchange.hs | 60 +++-- hbs2-core/lib/HBS2/Net/Proto/RefLog.hs | 10 + hbs2-core/lib/HBS2/Net/Proto/Types.hs | 3 +- hbs2-core/test/Main.hs | 2 + hbs2-core/test/TestCrypto.hs | 53 ++++ hbs2-peer/app/HttpWorker.hs | 8 +- hbs2-peer/app/PeerInfo.hs | 18 +- hbs2-peer/app/PeerMain.hs | 237 ++++++++++++------ hbs2-peer/app/PeerMeta.hs | 26 +- hbs2-peer/app/PeerTypes.hs | 73 ++++-- hbs2-peer/app/ProxyMessaging.hs | 115 +++++++-- hbs2-peer/app/RPC.hs | 11 + hbs2-peer/hbs2-peer.cabal | 3 + hbs2/Main.hs | 1 + 26 files changed, 758 insertions(+), 197 deletions(-) create mode 100644 hbs2-core/lib/HBS2/Crypto.hs create mode 100644 hbs2-core/test/TestCrypto.hs diff --git a/README.md b/README.md index 85229ca2..08e1cc10 100644 --- a/README.md +++ b/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 ``` diff --git a/docs/devlog.md b/docs/devlog.md index f82f71d2..5d8cdd85 100644 --- a/docs/devlog.md +++ b/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. diff --git a/hbs2-core/hbs2-core.cabal b/hbs2-core/hbs2-core.cabal index 51601614..5c88b796 100644 --- a/hbs2-core/hbs2-core.cabal +++ b/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 diff --git a/hbs2-core/lib/HBS2/Actors/Peer.hs b/hbs2-core/lib/HBS2/Actors/Peer.hs index e0b0e475..1c958aab 100644 --- a/hbs2-core/lib/HBS2/Actors/Peer.hs +++ b/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 - ) => Request e p m where - request p msg = do - let proto = protoId @e @p (Proxy @p) + , HasTimeLimits e msg m + , Show (Peer e) + , Show msg + ) => 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 - - pl <- AnyPeerLocator <$> newStaticPeerLocator @e mempty - - nonce <- newNonce @() - - PeerEnv p nonce bus s pl <$> newPipeline defProtoPipelineSize - <*> liftIO (Cache.newCache (Just defCookieTimeout)) - <*> liftIO (newTVarIO mempty) - <*> liftIO (Cache.newCache (Just defCookieTimeout)) - <*> liftIO (newTVarIO mempty) - <*> liftIO (Cache.newCache (Just defRequestLimit)) - <*> liftIO (Cache.newCache (Just defRequestLimit)) + let _envSelf = p + _envPeerNonce <- newNonce @() + let _envFab = bus + let _envStorage = s + _envPeerLocator <- AnyPeerLocator <$> newStaticPeerLocator @e mempty + _envDeferred <- newPipeline defProtoPipelineSize + _envSessions <- liftIO (Cache.newCache (Just defCookieTimeout)) + _envEvents <- liftIO (newTVarIO mempty) + _envExpireTimes <- liftIO (Cache.newCache (Just defCookieTimeout)) + _envSweepers <- liftIO (newTVarIO mempty) + _envReqMsgLimit <- 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 diff --git a/hbs2-core/lib/HBS2/Clock.hs b/hbs2-core/lib/HBS2/Clock.hs index 3c124ff5..3f705913 100644 --- a/hbs2-core/lib/HBS2/Clock.hs +++ b/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 () diff --git a/hbs2-core/lib/HBS2/Crypto.hs b/hbs2-core/lib/HBS2/Crypto.hs new file mode 100644 index 00000000..6bf35fa1 --- /dev/null +++ b/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 diff --git a/hbs2-core/lib/HBS2/Net/Auth/Credentials.hs b/hbs2-core/lib/HBS2/Net/Auth/Credentials.hs index cb4502e1..0ae23baf 100644 --- a/hbs2-core/lib/HBS2/Net/Auth/Credentials.hs +++ b/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) diff --git a/hbs2-core/lib/HBS2/Net/Proto/BlockAnnounce.hs b/hbs2-core/lib/HBS2/Net/Proto/BlockAnnounce.hs index cfa58566..0f5f7e4c 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/BlockAnnounce.hs +++ b/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) diff --git a/hbs2-core/lib/HBS2/Net/Proto/BlockChunks.hs b/hbs2-core/lib/HBS2/Net/Proto/BlockChunks.hs index 52c613a3..7ee24bdc 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/BlockChunks.hs +++ b/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 diff --git a/hbs2-core/lib/HBS2/Net/Proto/Definition.hs b/hbs2-core/lib/HBS2/Net/Proto/Definition.hs index 230a649f..1f0276df 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/Definition.hs +++ b/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) diff --git a/hbs2-core/lib/HBS2/Net/Proto/Peer.hs b/hbs2-core/lib/HBS2/Net/Proto/Peer.hs index 1de440a6..c1658c98 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/Peer.hs +++ b/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 (ConcretePeerKey pip) (ConcretePeerData pip d) + emit AnyKnownPeerEventKey (KnownPeerEvent pip pde) + 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 ) diff --git a/hbs2-core/lib/HBS2/Net/Proto/PeerAnnounce.hs b/hbs2-core/lib/HBS2/Net/Proto/PeerAnnounce.hs index 95067372..a2d2ad55 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/PeerAnnounce.hs +++ b/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 diff --git a/hbs2-core/lib/HBS2/Net/Proto/PeerExchange.hs b/hbs2-core/lib/HBS2/Net/Proto/PeerExchange.hs index 98635d4a..370e1a7d 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/PeerExchange.hs +++ b/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 - - -- 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' - + pa <- take defPexMaxPeers <$> getAllPex1Peers response (PeerExchangePeers @e n pa) PEX2 -> do - - 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' - + 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 + 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)) diff --git a/hbs2-core/lib/HBS2/Net/Proto/RefLog.hs b/hbs2-core/lib/HBS2/Net/Proto/RefLog.hs index d5a817c6..618c227f 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/RefLog.hs +++ b/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 = diff --git a/hbs2-core/lib/HBS2/Net/Proto/Types.hs b/hbs2-core/lib/HBS2/Net/Proto/Types.hs index 83a10916..0c445c2c 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/Types.hs +++ b/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 diff --git a/hbs2-core/test/Main.hs b/hbs2-core/test/Main.hs index 0e0a3fc1..a5eb12fc 100644 --- a/hbs2-core/test/Main.hs +++ b/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 ] diff --git a/hbs2-core/test/TestCrypto.hs b/hbs2-core/test/TestCrypto.hs new file mode 100644 index 00000000..f3e84906 --- /dev/null +++ b/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) diff --git a/hbs2-peer/app/HttpWorker.hs b/hbs2-peer/app/HttpWorker.hs index 90be311f..f6006b00 100644 --- a/hbs2-peer/app/HttpWorker.hs +++ 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 diff --git a/hbs2-peer/app/PeerInfo.hs b/hbs2-peer/app/PeerInfo.hs index 0743060b..bb6278fd 100644 --- a/hbs2-peer/app/PeerInfo.hs +++ b/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 () -peerPingLoop cfg = do + => PeerConfig -> PeerEnv e -> m () +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 diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index 142c37d9..ebd6efe3 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/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 k = view peerSignKey d + let peerBanned p pd = do + 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 - maybe1 pd' none $ \pd -> do + mpde <- find (KnownPeerKey p) id + 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 - banned <- maybe (pure False) (peerBanned pip) pd - let known = isJust pd && not banned + mpde :: Maybe (PeerDataExt e) <- find (KnownPeerKey pip) id + banned <- maybe (pure False) (peerBanned pip . view peerData) mpde + 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 >>= - \peers -> forM peers $ \pip -> do - pd <- find (KnownPeerKey pip) (view peerOwnNonce) - pure $ (,pip) <$> pd - - let pd = Map.fromList $ catMaybes pd' + pd :: Map BS.ByteString (Peer L4Proto) <- fmap (Map.fromList . catMaybes) + $ knownPeers @e pl >>= mapM \pip -> + fmap (, pip) <$> find (KnownPeerKey pip) (view (peerData . peerOwnNonce)) 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 - dieAction - dontHandle - dontHandle - annAction - pingAction - dontHandle - fetchAction - peersAction - dontHandle - logLevelAction - reflogUpdateAction - reflogFetchAction - reflogGetAction - dontHandle + let arpc = RpcAdapter + { rpcOnPoke = pokeAction + , rpcOnDie = dieAction + , rpcOnPokeAnswer = dontHandle + , rpcOnPokeAnswerFull = dontHandle + , rpcOnAnnounce = annAction + , rpcOnPing = pingAction + , rpcOnPong = dontHandle + , rpcOnFetch = fetchAction + , rpcOnPeers = peersAction + , rpcOnPeersAnswer = dontHandle + , rpcOnPexInfo = pexInfoAction + , rpcOnPexInfoAnswer = dontHandle + , rpcOnLogLevel = logLevelAction + , 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 = - RpcAdapter dontHandle - dontHandle - (liftIO . atomically . writeTQueue pokeQ) - (liftIO . atomically . writeTQueue pokeFQ) - (const $ liftIO exitSuccess) - (const $ notice "ping?") - (liftIO . atomically . writeTQueue pingQ) - dontHandle - dontHandle - - (\(pa, k) -> Log.info $ pretty (AsBase58 k) <+> pretty pa - ) - - dontHandle - dontHandle - dontHandle - dontHandle - - ( liftIO . atomically . writeTQueue refQ ) + let adapter = RpcAdapter + { rpcOnPoke = dontHandle + , rpcOnDie = dontHandle + , rpcOnPokeAnswer = (liftIO . atomically . writeTQueue pokeQ) + , rpcOnPokeAnswerFull = (liftIO . atomically . writeTQueue pokeFQ) + , rpcOnAnnounce = (const $ liftIO exitSuccess) + , rpcOnPing = (const $ notice "ping?") + , rpcOnPong = (liftIO . atomically . writeTQueue pingQ) + , rpcOnFetch = dontHandle + , rpcOnPeers = dontHandle + , rpcOnPeersAnswer = (\(pa, k) -> Log.info $ pretty (AsBase58 k) <+> pretty pa) + , rpcOnPexInfo = dontHandle + , rpcOnPexInfoAnswer = (\ps -> mapM_ (Log.info . pretty) ps) + , rpcOnLogLevel = dontHandle + , rpcOnRefLogUpdate = dontHandle + , rpcOnRefLogFetch = dontHandle + , rpcOnRefLogGet = dontHandle + , rpcOnRefLogGetAnsw = ( 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) diff --git a/hbs2-peer/app/PeerMeta.hs b/hbs2-peer/app/PeerMeta.hs index 6ed2d17e..b596afeb 100644 --- a/hbs2-peer/app/PeerMeta.hs +++ b/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 - debug $ "fillPeerMeta peers:" <+> pretty ps - npi <- newPeerInfo - for_ ps $ \p -> do + when ((not . null) ps') $ lift do + debug $ "fillPeerMeta peers:" <+> pretty ps' + for_ ps' $ \p -> do + npi <- newPeerInfo pinfo <- fetch True npi (PeerInfoKey p) id mmApiAddr <- liftIO $ readTVarIO (_peerHttpApiAddress pinfo) diff --git a/hbs2-peer/app/PeerTypes.hs b/hbs2-peer/app/PeerTypes.hs index 9aa36b5a..4bd57255 100644 --- a/hbs2-peer/app/PeerTypes.hs +++ b/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 - <*> newTVarIO Nothing - <*> newTVarIO mempty - <*> newTVarIO 0 - <*> newTVarIO 0 - <*> newTVarIO 0 - <*> newTVarIO 0 - <*> newTVarIO 0 - <*> newTVarIO 0 - <*> newTVarIO 0 - <*> newTVarIO 0 - <*> newTVarIO 0 - <*> newTVarIO 0 - <*> newTVarIO [] - <*> newTVarIO (Left 0) - <*> newTVarIO 0 - <*> newTVarIO Nothing + _peerBurst <- newTVarIO defBurst + _peerBurstMax <- newTVarIO Nothing + _peerBurstSet <- newTVarIO mempty + _peerErrors <- newTVarIO 0 + _peerErrorsLast <- newTVarIO 0 + _peerErrorsPerSec <- newTVarIO 0 + _peerLastWatched <- newTVarIO 0 + _peerDownloaded <- newTVarIO 0 + _peerDownloadedLast <- newTVarIO 0 + _peerPingFailed <- newTVarIO 0 + _peerDownloadedBlk <- newTVarIO 0 + _peerDownloadFail <- newTVarIO 0 + _peerDownloadMiss <- newTVarIO 0 + _peerRTTBuffer <- newTVarIO [] + -- Acts like a circular buffer. + _peerHttpApiAddress <- newTVarIO (Left 0) + _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 - maybe1 pd' (pure ()) (m p) + mpde <- find (KnownPeerKey p) id + 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 - let mHttpPort = cfgValue @PeerHttpPortKey conf <&> fromIntegral - let mTcpPort = +mkPeerMeta :: PeerConfig -> PeerEnv e -> AnnMetaData +mkPeerMeta conf penv = do + 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 $ - [ mHttpPort <&> \p -> ("http-port", TE.encodeUtf8 . Text.pack . show $ p) - , mTcpPort <&> \p -> ("listen-tcp", TE.encodeUtf8 . Text.pack . show $ p) - ] + -- let useEncryption = True -- move to config + annMetaFromPeerMeta . PeerMeta $ W.execWriter do + mHttpPort `forM` \p -> elem "http-port" (TE.encodeUtf8 . Text.pack . show $ p) + mTcpPort `forM` \p -> elem "listen-tcp" (TE.encodeUtf8 . Text.pack . show $ p) + -- when useEncryption do + -- elem "ekey" (TE.encodeUtf8 . Text.pack . show $ + -- (Encrypt.publicKey . _envAsymmetricKeyPair) penv + -- -- mayby sign this pubkey by node key ? + -- ) + + where + elem k = W.tell . L.singleton . (k ,) diff --git a/hbs2-peer/app/ProxyMessaging.hs b/hbs2-peer/app/ProxyMessaging.hs index e70d093a..0863abe0 100644 --- a/hbs2-peer/app/ProxyMessaging.hs +++ b/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 - -- sendTo (view proxyUDP bus) t f m - -- trace $ "PROXY: SEND" <+> pretty whom +sendToPlainProxyMessaging :: (MonadIO m) + => PlainProxyMessaging + -> 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 - r <- readTQueue answ - rs <- flushTQueue answ - pure (r:rs) + rs <- atomically $ liftM2 (:) (readTQueue answ) (flushTQueue answ) + fmap catMaybes $ forM rs \(w@(From whom), msg) -> do + encKeys <- (liftIO . readTVarIO) (view proxyEncryptionKeys bus) + 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 + + ) diff --git a/hbs2-peer/app/RPC.hs b/hbs2-peer/app/RPC.hs index 2cbbf0ad..9deff86a 100644 --- a/hbs2-peer/app/RPC.hs +++ b/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 diff --git a/hbs2-peer/hbs2-peer.cabal b/hbs2-peer/hbs2-peer.cabal index 0e2aceb8..9bbea4dc 100644 --- a/hbs2-peer/hbs2-peer.cabal +++ b/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 diff --git a/hbs2/Main.hs b/hbs2/Main.hs index d81eb2f4..091a5349 100644 --- a/hbs2/Main.hs +++ b/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 From 5ecbd9359485685fe1355ad1c8110e1be40e0bb3 Mon Sep 17 00:00:00 2001 From: Sergey Ivanov Date: Tue, 4 Jul 2023 19:24:35 +0400 Subject: [PATCH 02/31] Experiment with clearing symmetric key --- hbs2-peer/app/PeerMain.hs | 37 ++++++++++++++++++--------------- hbs2-peer/app/ProxyMessaging.hs | 21 ++++++++++++------- 2 files changed, 34 insertions(+), 24 deletions(-) diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index ebd6efe3..9ba7defd 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -858,33 +858,36 @@ runPeer opts = U.handle (\e -> myException e -- when allowed do -- sendTo proxy (To peer_e) (From me) (AnyMessage @(Encoded e) @e protoN (encode msg)) - when allowed do + -- when allowed do + 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 + -- 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) + -- 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)) + -- sendPingCrypted' pip (pubKeyFromKeypair @s (view envAsymmetricKeyPair penv)) + sendPing pip pause $ case (requestPeriodLim @e @(PeerHandshake e)) of NoLimit -> 0 ReqLimPerProto t -> t + 0.1 ReqLimPerMessage t -> t + 0.1 - sendPing' pip + -- sendPing' pip + sendPingCrypted pip (pubKeyFromKeypair @s (view envAsymmetricKeyPair penv)) ANNOUNCE h -> do debug $ "got announce rpc" <+> pretty h diff --git a/hbs2-peer/app/ProxyMessaging.hs b/hbs2-peer/app/ProxyMessaging.hs index 0863abe0..87af9b7f 100644 --- a/hbs2-peer/app/ProxyMessaging.hs +++ b/hbs2-peer/app/ProxyMessaging.hs @@ -39,7 +39,7 @@ 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 Lens.Micro.Platform as Lens import Control.Monad -- TODO: protocol-encryption-goes-here @@ -146,12 +146,21 @@ receiveFromProxyMessaging bus _ = liftIO do Nothing -> do trace $ "ENCRYPTION RECEIVE: we do not have a key to decode" <+> pretty whom pure (Just msg) - Just k -> runMaybeT $ (<|> pure msg) $ do + Just k -> runMaybeT $ + -- А будем-ка мы просто передавать сообщение дальше как есть, если не смогли расшифровать + (<|> (do + -- И сотрём ключ из памяти + liftIO $ atomically $ modifyTVar' (view proxyEncryptionKeys bus) $ Lens.at whom .~ Nothing + 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 - pure msg + fail "" + Just (nonce, msg') -> ((MaybeT . pure) (boxOpenAfterNMLazy k nonce msg') <* (trace $ "ENCRYPTION RECEIVE: message successfully decoded from" <+> pretty whom) @@ -159,15 +168,13 @@ receiveFromProxyMessaging bus _ = liftIO do <|> (do (trace $ "ENCRYPTION RECEIVE: can not decode message from" <+> pretty whom) - - -- А будем-ка мы просто передавать сообщение дальше как есть, если не смогли расшифровать - pure msg + fail "" -- -- Попытаться десериализовать сообщение как PeerPing или PeerPingCrypted -- case deserialiseOrFail msg of -- Right (_ :: PeerHandshake L4Proto) -> do -- trace $ "ENCRYPTION RECEIVE: plain message decoded as PeerHandshake" <+> pretty whom - -- pure msg + -- fail "" -- Left _ -> do -- trace $ "ENCRYPTION RECEIVE: failed" <+> pretty whom -- mzero From c403b77556d5379d22e95cc706a57a2478e44194 Mon Sep 17 00:00:00 2001 From: Sergey Ivanov Date: Tue, 4 Jul 2023 21:39:35 +0400 Subject: [PATCH 03/31] wip --- hbs2-peer/app/PeerInfo.hs | 12 --- hbs2-peer/app/PeerMain.hs | 51 ------------ hbs2-peer/app/ProxyMessaging.hs | 137 ++++++++++++++++---------------- 3 files changed, 69 insertions(+), 131 deletions(-) diff --git a/hbs2-peer/app/PeerInfo.hs b/hbs2-peer/app/PeerInfo.hs index bb6278fd..cf2ed433 100644 --- a/hbs2-peer/app/PeerInfo.hs +++ b/hbs2-peer/app/PeerInfo.hs @@ -244,15 +244,3 @@ peerPingLoop cfg penv = do -- 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 - - diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index 9ba7defd..62345501 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -836,58 +836,7 @@ runPeer opts = U.handle (\e -> myException e -- Nothing -> unencrypted ping -- Just pubkey -> encryptengd - 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 - 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)) sendPing pip - pause $ case (requestPeriodLim @e @(PeerHandshake e)) of - NoLimit -> 0 - ReqLimPerProto t -> t + 0.1 - ReqLimPerMessage t -> t + 0.1 - -- sendPing' pip - sendPingCrypted pip (pubKeyFromKeypair @s (view envAsymmetricKeyPair penv)) ANNOUNCE h -> do debug $ "got announce rpc" <+> pretty h diff --git a/hbs2-peer/app/ProxyMessaging.hs b/hbs2-peer/app/ProxyMessaging.hs index 87af9b7f..0d13b56f 100644 --- a/hbs2-peer/app/ProxyMessaging.hs +++ b/hbs2-peer/app/ProxyMessaging.hs @@ -94,89 +94,90 @@ runProxyMessaging env = liftIO do liftIO $ mapM_ waitCatch [u,t] -instance Messaging PlainProxyMessaging L4Proto LBS.ByteString where +instance Messaging ProxyMessaging L4Proto LBS.ByteString where sendTo = sendToPlainProxyMessaging - receive (PlainProxyMessaging bus) = receive bus + receive = receiveFromProxyMessaging sendToPlainProxyMessaging :: (MonadIO m) - => PlainProxyMessaging + => ProxyMessaging -> To L4Proto -> From L4Proto -> LBS.ByteString - -- -> AnyMessage LBS.ByteString L4Proto -> m () -sendToPlainProxyMessaging (PlainProxyMessaging bus) t@(To whom) proto msg = do +sendToPlainProxyMessaging bus t@(To whom) proto msg = do let udp = view proxyUDP bus case view sockType whom of UDP -> sendTo udp t proto msg TCP -> maybe1 (view proxyTCP bus) none $ \tcp -> do sendTo tcp t proto msg -instance Messaging ProxyMessaging L4Proto LBS.ByteString where - sendTo = sendToProxyMessaging - receive = receiveFromProxyMessaging +-- 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 +-- 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) -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 +-- rs <- atomically $ liftM2 (:) (readTQueue answ) (flushTQueue answ) +-- fmap catMaybes $ forM rs \(w@(From whom), msg) -> do +-- encKeys <- (liftIO . readTVarIO) (view proxyEncryptionKeys bus) +-- fmap (w, ) <$> dfm whom (Map.lookup whom encKeys) 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 - rs <- atomically $ liftM2 (:) (readTQueue answ) (flushTQueue answ) - fmap catMaybes $ forM rs \(w@(From whom), msg) -> do - encKeys <- (liftIO . readTVarIO) (view proxyEncryptionKeys bus) - 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 $ +-- -- А будем-ка мы просто передавать сообщение дальше как есть, если не смогли расшифровать +-- (<|> (do +-- -- И сотрём ключ из памяти +-- -- liftIO $ atomically $ modifyTVar' (view proxyEncryptionKeys bus) $ Lens.at whom .~ Nothing +-- 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 "" - 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 $ - -- А будем-ка мы просто передавать сообщение дальше как есть, если не смогли расшифровать - (<|> (do - -- И сотрём ключ из памяти - liftIO $ atomically $ modifyTVar' (view proxyEncryptionKeys bus) $ Lens.at whom .~ Nothing - 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 "" - 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 - -- -- Попытаться десериализовать сообщение как 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 - - ) +-- ) From 9c408bcb0396c97c618410bbdfb30972de8ab4a7 Mon Sep 17 00:00:00 2001 From: Sergey Ivanov Date: Tue, 4 Jul 2023 21:55:03 +0400 Subject: [PATCH 04/31] Disable bus encryption --- hbs2-peer/app/ProxyMessaging.hs | 142 +++++++++++++++++--------------- 1 file changed, 76 insertions(+), 66 deletions(-) diff --git a/hbs2-peer/app/ProxyMessaging.hs b/hbs2-peer/app/ProxyMessaging.hs index 0d13b56f..cea156e1 100644 --- a/hbs2-peer/app/ProxyMessaging.hs +++ b/hbs2-peer/app/ProxyMessaging.hs @@ -94,9 +94,19 @@ runProxyMessaging env = liftIO do liftIO $ mapM_ waitCatch [u,t] + instance Messaging ProxyMessaging L4Proto LBS.ByteString where + sendTo = sendToPlainProxyMessaging - 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 @@ -111,73 +121,73 @@ sendToPlainProxyMessaging bus t@(To whom) proto msg = do TCP -> maybe1 (view proxyTCP bus) none $ \tcp -> do sendTo tcp t proto msg --- 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 --- 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) +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 + 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 + 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 --- rs <- atomically $ liftM2 (:) (readTQueue answ) (flushTQueue answ) --- fmap catMaybes $ forM rs \(w@(From whom), msg) -> do --- encKeys <- (liftIO . readTVarIO) (view proxyEncryptionKeys bus) --- fmap (w, ) <$> dfm whom (Map.lookup whom encKeys) 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 + rs <- atomically $ liftM2 (:) (readTQueue answ) (flushTQueue answ) + fmap catMaybes $ forM rs \(w@(From whom), msg) -> do + encKeys <- (liftIO . readTVarIO) (view proxyEncryptionKeys bus) + 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 $ --- -- А будем-ка мы просто передавать сообщение дальше как есть, если не смогли расшифровать --- (<|> (do --- -- И сотрём ключ из памяти --- -- liftIO $ atomically $ modifyTVar' (view proxyEncryptionKeys bus) $ Lens.at whom .~ Nothing --- 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 "" + 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 $ + -- А будем-ка мы просто передавать сообщение дальше как есть, если не смогли расшифровать + (<|> (do + -- И сотрём ключ из памяти + -- liftIO $ atomically $ modifyTVar' (view proxyEncryptionKeys bus) $ Lens.at whom .~ Nothing + 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 "" + 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 + -- -- Попытаться десериализовать сообщение как 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 --- ) + ) From 75232557f3c6b4547e8e8ba7a92a5b3e970a039b Mon Sep 17 00:00:00 2001 From: Sergey Ivanov Date: Tue, 4 Jul 2023 22:47:26 +0400 Subject: [PATCH 05/31] Extracted EncryptionHandshake from PeerHandshake --- hbs2-core/hbs2-core.cabal | 1 + .../lib/HBS2/Net/Proto/EncryptionHandshake.hs | 122 ++++++++++++++++ hbs2-core/lib/HBS2/Net/Proto/Peer.hs | 134 ++---------------- hbs2-peer/app/PeerMain.hs | 41 ++---- hbs2-peer/app/PeerTypes.hs | 2 +- 5 files changed, 147 insertions(+), 153 deletions(-) create mode 100644 hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs diff --git a/hbs2-core/hbs2-core.cabal b/hbs2-core/hbs2-core.cabal index 5c88b796..5d71be67 100644 --- a/hbs2-core/hbs2-core.cabal +++ b/hbs2-core/hbs2-core.cabal @@ -94,6 +94,7 @@ library , HBS2.Net.Proto.BlockChunks , HBS2.Net.Proto.BlockInfo , HBS2.Net.Proto.Definition + , HBS2.Net.Proto.EncryptionHandshake , HBS2.Net.Proto.Peer , HBS2.Net.Proto.PeerAnnounce , HBS2.Net.Proto.PeerExchange diff --git a/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs b/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs new file mode 100644 index 00000000..309bfa9e --- /dev/null +++ b/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs @@ -0,0 +1,122 @@ +{-# Language TemplateHaskell #-} +{-# Language UndecidableInstances #-} +module HBS2.Net.Proto.EncryptionHandshake where + +-- import HBS2.Base58 +import HBS2.Actors.Peer +import HBS2.Data.Types +import HBS2.Events +import HBS2.Net.Proto +import HBS2.Clock +import HBS2.Net.Proto.Sessions +import HBS2.Prelude.Plated +import HBS2.Net.Auth.Credentials +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) + +newtype EENonce = EENonce { unEENonce :: BS.ByteString } + +data EncryptionHandshake e = + BeginEncryptionExchange EENonce (PubKey 'Encrypt (Encryption e)) + | AckEncryptionExchange EENonce (Signature (Encryption e)) (PubKey 'Encrypt (Encryption e)) + deriving stock (Generic) + +sendEncryptionPubKey :: forall e m . ( MonadIO m + , Request e (EncryptionHandshake e) m + , Sessions e (EncryptionHandshake e) m + , HasNonces (EncryptionHandshake e) m + , Nonce (EncryptionHandshake e) ~ EENonce + , Pretty (Peer e) + , HasProtocol e (EncryptionHandshake e) + , e ~ L4Proto + ) + => Peer e -> PubKey 'Encrypt (Encryption e) -> m () + +sendEncryptionPubKey pip pubkey = do + nonce <- newNonce @(EncryptionHandshake e) + tt <- liftIO $ getTimeCoarse + request pip (BeginEncryptionExchange @e nonce pubkey) + +encryptionHandshakeProto :: forall e s m . ( MonadIO m + , Response e (EncryptionHandshake e) m + , Request e (EncryptionHandshake e) m + , Sessions e (EncryptionHandshake e) m + , HasNonces (EncryptionHandshake e) m + , HasPeerNonce e m + , Nonce (EncryptionHandshake e) ~ EENonce + , Pretty (Peer e) + , EventEmitter e (EncryptionHandshake e) m + , EventEmitter e (PeerAsymmInfo e) m + , HasCredentials s m + , Asymm s + , Signatures s + , Serialise (PubKey 'Encrypt (Encryption e)) + , s ~ Encryption e + , e ~ L4Proto + ) + => PeerEnv e + -> EncryptionHandshake e + -> m () + +encryptionHandshakeProto penv = + \case + + BeginEncryptionExchange nonce theirpubkey -> do + pip <- thatPeer proto + trace $ "GOT BeginEncryptionExchange from" <+> pretty pip + + -- взять свои ключи + creds <- getCredentials @s + + let ourpubkey = pubKeyFromKeypair @s $ view envAsymmetricKeyPair penv + + -- подписать нонс + let sign = makeSign @s (view peerSignSk creds) (unEENonce nonce <> (cs . serialise) ourpubkey) + + -- отправить обратно вместе с публичным ключом + -- response (AckEncryptionExchange @e nonce sign ourpubkey (PeerData (view peerSignPk creds))) + + -- Нужно ли запомнить его theirpubkey или достаточно того, что будет + -- получено в обратном AckEncryptionExchange? + -- Нужно! + emit PeerAsymmInfoKey (PeerAsymmPubKey pip theirpubkey) + + -- se <- find (KnownPeerKey pip) id <&> isJust + -- unless se $ do + -- sendEncryptionPubKey pip ourpubkey + + AckEncryptionExchange nonce0 sign theirpubkey -> do + pip <- thatPeer proto + -- trace $ "AckEncryptionExchange" <+> pretty pip + + emit PeerAsymmInfoKey (PeerAsymmPubKey pip 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 diff --git a/hbs2-core/lib/HBS2/Net/Proto/Peer.hs b/hbs2-core/lib/HBS2/Net/Proto/Peer.hs index c1658c98..1328900a 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/Peer.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/Peer.hs @@ -41,19 +41,9 @@ deriving instance 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 @@ -74,13 +64,12 @@ 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) = PeerDataExt e +type instance SessionData e (KnownPeer e) = PeerData e newtype instance SessionKey e (PeerHandshake e) = PeerHandshakeKey (PingNonce, Peer e) @@ -109,28 +98,10 @@ sendPing :: forall e m . ( MonadIO m sendPing pip = do nonce <- newNonce @(PeerHandshake e) tt <- liftIO $ getTimeCoarse - let pdd = PeerPingData nonce tt Nothing + let pdd = PeerPingData nonce tt 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 () @@ -148,7 +119,6 @@ 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 @@ -188,11 +158,7 @@ peerHandShakeProto adapter penv = se' <- find @e (PeerHandshakeKey (nonce0,pip)) id - maybe1 se' (pure ()) $ \(PeerPingData nonce t0 mpubkey) -> do - - -- Мы отправляли ключ шифрования, но собеседник отказался - -- от шифрованной сессии - -- when (isJust mpubkey) do + maybe1 se' (pure ()) $ \(PeerPingData nonce t0) -> do let pk = view peerSignKey d @@ -209,76 +175,10 @@ peerHandShakeProto adapter penv = -- FIXME: check if peer is blacklisted -- right here - let pde = PeerDataExt d Nothing - update pde (KnownPeerKey pip) id + update d (KnownPeerKey pip) id - emit AnyKnownPeerEventKey (KnownPeerEvent pip pde) - 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 + emit AnyKnownPeerEventKey (KnownPeerEvent pip d) + emit (ConcretePeerKey pip) (ConcretePeerData pip d) where proto = Proxy @(PeerHandshake e) @@ -293,22 +193,7 @@ 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) (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)) + ConcretePeerData (Peer e) (PeerData e) deriving stock (Typeable) --- @@ -318,7 +203,7 @@ data instance EventKey e (PeerHandshake e) = deriving stock (Typeable, Eq,Generic) data instance Event e (PeerHandshake e) = - KnownPeerEvent (Peer e) (PeerDataExt e) + KnownPeerEvent (Peer e) (PeerData e) deriving stock (Typeable) instance ( Typeable (KnownPeer e) @@ -334,9 +219,6 @@ 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 diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index 62345501..f060e00c 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -602,7 +602,7 @@ runPeer opts = U.handle (\e -> myException e already <- liftIO $ Cache.lookup nbcache (p,h) <&> isJust unless already do mpde <- find (KnownPeerKey p) id - maybe1 mpde none $ \pde@(PeerDataExt {_peerData = pd}) -> do + maybe1 mpde none $ \pd -> do let pk = view peerSignKey pd when (Set.member pk helpFetchKeys) do liftIO $ Cache.insert nbcache (p,h) () @@ -655,38 +655,27 @@ runPeer opts = U.handle (\e -> myException e subscribe @e PeerAnnounceEventKey $ \(PeerAnnounceEvent pip nonce) -> do unless (nonce == pnonce) $ do debug $ "Got peer announce!" <+> pretty pip - mpde :: Maybe (PeerDataExt e) <- find (KnownPeerKey pip) id - banned <- maybe (pure False) (peerBanned pip . view peerData) mpde - let known = isJust mpde && not banned + mpd :: Maybe (PeerData e) <- find (KnownPeerKey pip) id + banned <- maybe (pure False) (peerBanned pip) mpd + 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 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} |] - - subscribe @e AnyKnownPeerEventKey $ \(KnownPeerEvent p pde@(PeerDataExt{_peerData = pd})) -> do + subscribe @e AnyKnownPeerEventKey $ \(KnownPeerEvent p pd) -> do let thatNonce = view peerOwnNonce pd now <- liftIO getTimeCoarse - defPeerInfo <- newPeerInfo - fetch True defPeerInfo (PeerInfoKey p) id >>= \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 - 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 @@ -716,15 +705,15 @@ runPeer opts = U.handle (\e -> myException e | otherwise -> do - update pde (KnownPeerKey p) id + update pd (KnownPeerKey p) id - pd :: Map BS.ByteString (Peer L4Proto) <- fmap (Map.fromList . catMaybes) + pdkv :: Map BS.ByteString (Peer L4Proto) <- fmap (Map.fromList . catMaybes) $ knownPeers @e pl >>= mapM \pip -> - fmap (, pip) <$> find (KnownPeerKey pip) (view (peerData . peerOwnNonce)) + fmap (, pip) <$> find (KnownPeerKey pip) (view peerOwnNonce) 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 @@ -875,7 +864,7 @@ runPeer opts = U.handle (\e -> myException e sendPing @e pip -- TODO: enqueue-announce-from-unknown-peer? - Just (pde@(PeerDataExt {_peerData = pd})) -> do + Just pd -> do banned <- peerBanned pip pd @@ -968,7 +957,7 @@ runPeer opts = U.handle (\e -> myException e void $ liftIO $ async $ withPeerM penv $ do forKnownPeers @e $ \p pde -> do pa <- toPeerAddr p - let k = view (peerData . peerSignKey) pde + let k = view peerSignKey pde request who (RPCPeersAnswer @e pa k) let pexInfoAction :: RPC L4Proto -> ResponseM L4Proto (RpcM (ResourceT IO)) () diff --git a/hbs2-peer/app/PeerTypes.hs b/hbs2-peer/app/PeerTypes.hs index 4bd57255..2d85344b 100644 --- a/hbs2-peer/app/PeerTypes.hs +++ b/hbs2-peer/app/PeerTypes.hs @@ -359,7 +359,7 @@ forKnownPeers :: forall e m . ( MonadIO m , Sessions e (KnownPeer e) m , HasPeer e ) - => ( Peer e -> PeerDataExt e -> m () ) -> m () + => ( Peer e -> PeerData e -> m () ) -> m () forKnownPeers m = do pl <- getPeerLocator @e pips <- knownPeers @e pl From d1318c6fd143dd358e3ed4b3884b6d154e3137b4 Mon Sep 17 00:00:00 2001 From: Sergey Ivanov Date: Tue, 4 Jul 2023 23:46:52 +0400 Subject: [PATCH 06/31] Added encryptionHandshakeProto to PeerMain "all protos" thread --- hbs2-core/lib/HBS2/Base58.hs | 3 ++ hbs2-core/lib/HBS2/Net/Proto/Definition.hs | 15 ++++++ .../lib/HBS2/Net/Proto/EncryptionHandshake.hs | 54 +++++++++++++++---- hbs2-peer/app/PeerMain.hs | 2 + 4 files changed, 64 insertions(+), 10 deletions(-) diff --git a/hbs2-core/lib/HBS2/Base58.hs b/hbs2-core/lib/HBS2/Base58.hs index 060ea813..0251965f 100644 --- a/hbs2-core/lib/HBS2/Base58.hs +++ b/hbs2-core/lib/HBS2/Base58.hs @@ -25,3 +25,6 @@ fromBase58 = decodeBase58 bitcoinAlphabet instance Pretty (AsBase58 ByteString) where pretty (AsBase58 bs) = pretty $ BS8.unpack $ toBase58 bs +instance Show (AsBase58 ByteString) where + show (AsBase58 bs) = BS8.unpack $ toBase58 bs + diff --git a/hbs2-core/lib/HBS2/Net/Proto/Definition.hs b/hbs2-core/lib/HBS2/Net/Proto/Definition.hs index 1f0276df..7d6f8451 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/Definition.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/Definition.hs @@ -14,6 +14,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 @@ -125,6 +126,14 @@ instance HasProtocol L4Proto (PeerMetaProto L4Proto) where -- FIXME: real-period requestPeriodLim = ReqLimPerMessage 0.25 +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 @@ -143,12 +152,18 @@ 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 diff --git a/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs b/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs index 309bfa9e..49d3f6f0 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs @@ -2,28 +2,32 @@ {-# Language UndecidableInstances #-} module HBS2.Net.Proto.EncryptionHandshake where --- import HBS2.Base58 import HBS2.Actors.Peer +import HBS2.Base58 +import HBS2.Clock import HBS2.Data.Types import HBS2.Events +import HBS2.Net.Auth.Credentials import HBS2.Net.Proto -import HBS2.Clock import HBS2.Net.Proto.Sessions import HBS2.Prelude.Plated -import HBS2.Net.Auth.Credentials import HBS2.System.Logger.Simple -import Control.Monad -import Crypto.Saltine.Core.Box qualified as Encrypt -import Data.Maybe import Codec.Serialise() +import Control.Monad +import Crypto.Saltine.Class qualified as Crypto +import Crypto.Saltine.Core.Box qualified as Encrypt import Data.ByteString qualified as BS import Data.Hashable +import Data.Maybe import Data.String.Conversions (cs) import Lens.Micro.Platform import Type.Reflection (someTypeRep) newtype EENonce = EENonce { unEENonce :: BS.ByteString } + deriving stock (Generic) + deriving newtype (Eq, Serialise, Hashable) + deriving (Pretty, Show) via AsBase58 BS.ByteString data EncryptionHandshake e = BeginEncryptionExchange EENonce (PubKey 'Encrypt (Encryption e)) @@ -67,8 +71,7 @@ encryptionHandshakeProto :: forall e s m . ( MonadIO m -> EncryptionHandshake e -> m () -encryptionHandshakeProto penv = - \case +encryptionHandshakeProto penv = \case BeginEncryptionExchange nonce theirpubkey -> do pip <- thatPeer proto @@ -107,8 +110,7 @@ encryptionHandshakeProto penv = data PeerAsymmInfo e = PeerAsymmInfo -data instance EventKey e (PeerAsymmInfo e) = - PeerAsymmInfoKey +data instance EventKey e (PeerAsymmInfo e) = PeerAsymmInfoKey deriving stock (Generic) deriving stock instance (Eq (Peer e)) => Eq (EventKey e (PeerAsymmInfo e)) @@ -120,3 +122,35 @@ data instance Event e (PeerAsymmInfo e) = instance Expires (EventKey e (PeerAsymmInfo e)) where expiresIn _ = Nothing + +instance MonadIO m => HasNonces (EncryptionHandshake L4Proto) m where + type instance Nonce (EncryptionHandshake L4Proto) = EENonce + newNonce = EENonce . BS.take 32 . Crypto.encode <$> liftIO Encrypt.newNonce + +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 (EENonce, 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) + +instance Hashable (EventKey e (EncryptionHandshake e)) diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index f060e00c..8f340ab2 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -21,6 +21,7 @@ import HBS2.Net.Messaging.TCP import HBS2.Net.PeerLocator import HBS2.Net.Proto as Proto import HBS2.Net.Proto.Definition +import HBS2.Net.Proto.EncryptionHandshake import HBS2.Net.Proto.Peer import HBS2.Net.Proto.PeerAnnounce import HBS2.Net.Proto.PeerExchange @@ -908,6 +909,7 @@ runPeer opts = U.handle (\e -> myException e , makeResponse (blockChunksProto adapter) , makeResponse blockAnnounceProto , makeResponse (withCredentials @e pc . peerHandShakeProto hshakeAdapter penv) + , makeResponse (withCredentials @e pc . encryptionHandshakeProto penv) , makeResponse (peerExchangeProto pexFilt) , makeResponse (refLogUpdateProto reflogAdapter) , makeResponse (refLogRequestProto reflogReqAdapter) From fdf5a72765f4c848f2247622687f9a4babd5fc2a Mon Sep 17 00:00:00 2001 From: Sergey Ivanov Date: Wed, 5 Jul 2023 18:14:18 +0400 Subject: [PATCH 07/31] wip --- .../lib/HBS2/Net/Proto/EncryptionHandshake.hs | 20 ++++- hbs2-peer/app/Brains.hs | 57 ++++++++++++++ hbs2-peer/app/EncryptionKeys.hs | 74 +++++++++++++++++++ hbs2-peer/app/PeerMain.hs | 18 ++++- hbs2-peer/hbs2-peer.cabal | 1 + 5 files changed, 166 insertions(+), 4 deletions(-) create mode 100644 hbs2-peer/app/EncryptionKeys.hs diff --git a/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs b/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs index 49d3f6f0..bd9d1d91 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs @@ -1,5 +1,6 @@ {-# Language TemplateHaskell #-} {-# Language UndecidableInstances #-} + module HBS2.Net.Proto.EncryptionHandshake where import HBS2.Actors.Peer @@ -50,6 +51,11 @@ sendEncryptionPubKey pip pubkey = do tt <- liftIO $ getTimeCoarse request pip (BeginEncryptionExchange @e nonce pubkey) +data EncryptionHandshakeAdapter e m s = EncryptionHandshakeAdapter + { encHandshake_considerPeerAsymmKey :: PeerAddr e -> Encrypt.PublicKey -> m () + } + + encryptionHandshakeProto :: forall e s m . ( MonadIO m , Response e (EncryptionHandshake e) m , Request e (EncryptionHandshake e) m @@ -66,17 +72,22 @@ encryptionHandshakeProto :: forall e s m . ( MonadIO m , Serialise (PubKey 'Encrypt (Encryption e)) , s ~ Encryption e , e ~ L4Proto + , PubKey Encrypt s ~ Encrypt.PublicKey ) - => PeerEnv e + => EncryptionHandshakeAdapter e m s + -> PeerEnv e -> EncryptionHandshake e -> m () -encryptionHandshakeProto penv = \case +encryptionHandshakeProto EncryptionHandshakeAdapter{..} penv = \case BeginEncryptionExchange nonce theirpubkey -> do pip <- thatPeer proto trace $ "GOT BeginEncryptionExchange from" <+> pretty pip + paddr <- toPeerAddr pip + encHandshake_considerPeerAsymmKey paddr theirpubkey + -- взять свои ключи creds <- getCredentials @s @@ -86,7 +97,7 @@ encryptionHandshakeProto penv = \case let sign = makeSign @s (view peerSignSk creds) (unEENonce nonce <> (cs . serialise) ourpubkey) -- отправить обратно вместе с публичным ключом - -- response (AckEncryptionExchange @e nonce sign ourpubkey (PeerData (view peerSignPk creds))) + response (AckEncryptionExchange @e nonce sign ourpubkey) -- Нужно ли запомнить его theirpubkey или достаточно того, что будет -- получено в обратном AckEncryptionExchange? @@ -101,6 +112,9 @@ encryptionHandshakeProto penv = \case pip <- thatPeer proto -- trace $ "AckEncryptionExchange" <+> pretty pip + paddr <- toPeerAddr pip + encHandshake_considerPeerAsymmKey paddr theirpubkey + emit PeerAsymmInfoKey (PeerAsymmPubKey pip theirpubkey) where diff --git a/hbs2-peer/app/Brains.hs b/hbs2-peer/app/Brains.hs index 9f880c28..fd312d62 100644 --- a/hbs2-peer/app/Brains.hs +++ b/hbs2-peer/app/Brains.hs @@ -13,6 +13,7 @@ import HBS2.System.Logger.Simple import PeerConfig +import Crypto.Saltine.Core.Box qualified as Encrypt import Data.Maybe import Control.Monad import Control.Exception @@ -602,6 +603,46 @@ 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 + -> PeerAddr e + -> Encrypt.PublicKey + -> m () + +insertPeerAsymmKey br peer hAsymmKey = do + let conn = view brainsDb br + void $ liftIO $ execute conn [qc| + INSERT INTO peer_asymmkey (peer,asymmkey) + VALUES (?,?) + ON CONFLICT (peer) + DO UPDATE SET + asymmkey = excluded.asymmkey + + |] (show $ pretty peer, show hAsymmKey) + +insertPeerSymmKey :: forall e m . + ( e ~ L4Proto + , MonadIO m + ) + => BasicBrains e + -> PeerAddr e + -> Encrypt.CombinedKey + -> m () + +insertPeerSymmKey br peer hSymmKey = do + let conn = view brainsDb br + void $ liftIO $ execute conn [qc| + INSERT INTO peer_symmkey (peer,symmkey) + VALUES (?,?) + ON CONFLICT (peer) + DO UPDATE SET + symmkey = excluded.symmkey + + |] (show $ pretty peer, show hSymmKey) + -- FIXME: eventually-close-db newBasicBrains :: forall e m . (Hashable (Peer e), MonadIO m) => PeerConfig @@ -690,6 +731,22 @@ newBasicBrains cfg = liftIO do ) |] + execute_ conn [qc| + create table if not exists peer_asymmkey + ( peer text not null + , asymmkey text not null + , primary key (peer) + ) + |] + + execute_ conn [qc| + create table if not exists peer_symmkey + ( peer text not null + , symmkey text not null + , primary key (peer) + ) + |] + BasicBrains <$> newTVarIO mempty <*> newTVarIO mempty <*> Cache.newCache (Just (toTimeSpec (30 :: Timeout 'Seconds))) diff --git a/hbs2-peer/app/EncryptionKeys.hs b/hbs2-peer/app/EncryptionKeys.hs new file mode 100644 index 00000000..32820c79 --- /dev/null +++ b/hbs2-peer/app/EncryptionKeys.hs @@ -0,0 +1,74 @@ +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) + ) + => PeerConfig + -> PeerEnv e + -> EncryptionHandshakeAdapter e m s + -> m () + +encryptionHandshakeWorker pconf penv EncryptionHandshakeAdapter{..} = do + + -- e <- ask + let ourpubkey = pubKeyFromKeypair @s $ _envAsymmetricKeyPair penv + + pl <- getPeerLocator @e + + forever do + liftIO $ pause @'Seconds 10 + + pips <- knownPeers @e pl + + forM_ pips \p -> do + sendEncryptionPubKey @e p ourpubkey diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index 8f340ab2..51e4cf43 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -45,6 +45,7 @@ import PeerInfo import PeerConfig import Bootstrap import CheckMetrics +import EncryptionKeys import RefLog qualified import RefLog (reflogWorker) import HttpWorker @@ -645,6 +646,18 @@ runPeer opts = U.handle (\e -> myException e let hshakeAdapter = PeerHandshakeAdapter addNewRtt + let encryptionHshakeAdapter :: + ( MonadIO m + ) => EncryptionHandshakeAdapter L4Proto m s + encryptionHshakeAdapter = EncryptionHandshakeAdapter + { encHandshake_considerPeerAsymmKey = \addr pk -> do + insertPeerAsymmKey brains addr pk + insertPeerSymmKey brains addr $ + genCommonSecret @s + (privKeyFromKeypair @s (view envAsymmetricKeyPair penv)) + pk + } + env <- ask pnonce <- peerNonce @e @@ -793,6 +806,9 @@ runPeer opts = U.handle (\e -> myException e peerThread "blockDownloadLoop" (blockDownloadLoop denv) + peerThread "encryptionHandshakeWorker" + (EncryptionKeys.encryptionHandshakeWorker @e conf penv encryptionHshakeAdapter) + let tcpProbeWait :: Timeout 'Seconds tcpProbeWait = (fromInteger . fromMaybe 300) (cfgValue @PeerTcpProbeWaitKey conf) @@ -909,7 +925,7 @@ runPeer opts = U.handle (\e -> myException e , makeResponse (blockChunksProto adapter) , makeResponse blockAnnounceProto , makeResponse (withCredentials @e pc . peerHandShakeProto hshakeAdapter penv) - , makeResponse (withCredentials @e pc . encryptionHandshakeProto penv) + , makeResponse (withCredentials @e pc . encryptionHandshakeProto encryptionHshakeAdapter penv) , makeResponse (peerExchangeProto pexFilt) , makeResponse (refLogUpdateProto reflogAdapter) , makeResponse (refLogRequestProto reflogReqAdapter) diff --git a/hbs2-peer/hbs2-peer.cabal b/hbs2-peer/hbs2-peer.cabal index 9bbea4dc..0710bdef 100644 --- a/hbs2-peer/hbs2-peer.cabal +++ b/hbs2-peer/hbs2-peer.cabal @@ -122,6 +122,7 @@ executable hbs2-peer other-modules: BlockDownload , BlockHttpDownload , DownloadQ + , EncryptionKeys , Bootstrap , PeerInfo , PeerMeta From 9eed3a6d3f54e6bc945b806fafd9b719cdb94245 Mon Sep 17 00:00:00 2001 From: Sergey Ivanov Date: Wed, 12 Jul 2023 22:34:21 +0400 Subject: [PATCH 08/31] wip --- .../lib/HBS2/Net/Proto/EncryptionHandshake.hs | 165 ++++++++++++------ hbs2-peer/app/Brains.hs | 24 +++ hbs2-peer/app/EncryptionKeys.hs | 20 ++- hbs2-peer/app/PeerMain.hs | 18 +- hbs2-peer/app/ProxyMessaging.hs | 7 + 5 files changed, 160 insertions(+), 74 deletions(-) diff --git a/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs b/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs index bd9d1d91..dc373cb3 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs @@ -10,6 +10,7 @@ import HBS2.Data.Types import HBS2.Events import HBS2.Net.Auth.Credentials import HBS2.Net.Proto +import HBS2.Net.Proto.Peer import HBS2.Net.Proto.Sessions import HBS2.Prelude.Plated import HBS2.System.Logger.Simple @@ -30,63 +31,115 @@ newtype EENonce = EENonce { unEENonce :: BS.ByteString } deriving newtype (Eq, Serialise, Hashable) deriving (Pretty, Show) via AsBase58 BS.ByteString +instance + ( Show (PubKey 'Encrypt (Encryption e)) + , Show (PubKey 'Sign (Encryption e)) + , Show (Nonce ()) + ) + => Pretty (PeerData e) where + pretty = viaShow + data EncryptionHandshake e = - BeginEncryptionExchange EENonce (PubKey 'Encrypt (Encryption e)) + BeginEncryptionExchange EENonce (Signature (Encryption e)) (PubKey 'Encrypt (Encryption e)) | AckEncryptionExchange EENonce (Signature (Encryption e)) (PubKey 'Encrypt (Encryption e)) + | ResetEncryptionKeys deriving stock (Generic) -sendEncryptionPubKey :: forall e m . ( MonadIO m - , Request e (EncryptionHandshake e) m - , Sessions e (EncryptionHandshake e) m - , HasNonces (EncryptionHandshake e) m - , Nonce (EncryptionHandshake e) ~ EENonce - , Pretty (Peer e) - , HasProtocol e (EncryptionHandshake e) - , e ~ L4Proto - ) - => Peer e -> PubKey 'Encrypt (Encryption e) -> m () +sendResetEncryptionKeys :: forall e s m . + ( MonadIO m + , Request e (EncryptionHandshake e) m + , e ~ L4Proto + , s ~ Encryption e + ) + => Peer e + -> m () -sendEncryptionPubKey pip pubkey = do - nonce <- newNonce @(EncryptionHandshake e) - tt <- liftIO $ getTimeCoarse - request pip (BeginEncryptionExchange @e nonce pubkey) +sendResetEncryptionKeys peer = do + request peer (ResetEncryptionKeys @e) + +sendBeginEncryptionExchange :: forall e s m . + ( MonadIO m + , Request e (EncryptionHandshake e) m + , Sessions e (EncryptionHandshake e) m + , HasNonces (EncryptionHandshake e) m + -- , HasCredentials s m + , Asymm s + , Signatures s + , Serialise (PubKey 'Encrypt s) + , Nonce (EncryptionHandshake e) ~ EENonce + , Pretty (Peer e) + , HasProtocol e (EncryptionHandshake e) + , e ~ L4Proto + , s ~ Encryption e + ) + => PeerEnv e + -> PeerCredentials s + -> Peer e + -> PubKey 'Encrypt (Encryption e) + -> m () + +sendBeginEncryptionExchange penv creds peer pubkey = do + nonce0 <- newNonce @(EncryptionHandshake e) + let ourpubkey = pubKeyFromKeypair @s $ view envAsymmetricKeyPair penv + let sign = makeSign @s (view peerSignSk creds) (unEENonce nonce0 <> (cs . serialise) ourpubkey) + request peer (BeginEncryptionExchange @e nonce0 sign pubkey) data EncryptionHandshakeAdapter e m s = EncryptionHandshakeAdapter - { encHandshake_considerPeerAsymmKey :: PeerAddr e -> Encrypt.PublicKey -> m () + { encHandshake_considerPeerAsymmKey :: PeerAddr e -> Maybe (PeerData e) -> Maybe Encrypt.PublicKey -> m () } -encryptionHandshakeProto :: forall e s m . ( MonadIO m - , Response e (EncryptionHandshake e) m - , Request e (EncryptionHandshake e) m - , Sessions e (EncryptionHandshake e) m - , HasNonces (EncryptionHandshake e) m - , HasPeerNonce e m - , Nonce (EncryptionHandshake e) ~ EENonce - , Pretty (Peer e) - , EventEmitter e (EncryptionHandshake e) m - , EventEmitter e (PeerAsymmInfo e) m - , HasCredentials s m - , Asymm s - , Signatures s - , Serialise (PubKey 'Encrypt (Encryption e)) - , s ~ Encryption e - , e ~ L4Proto - , PubKey Encrypt s ~ Encrypt.PublicKey - ) - => EncryptionHandshakeAdapter e m s - -> PeerEnv e - -> EncryptionHandshake e - -> m () +encryptionHandshakeProto :: forall e s m . + ( MonadIO m + , Response e (EncryptionHandshake e) m + , Request e (EncryptionHandshake e) m + , Sessions e (KnownPeer e) m + -- , Sessions e (EncryptionHandshake e) m + -- , HasNonces (EncryptionHandshake e) m + -- , HasPeerNonce e m + -- , Nonce (EncryptionHandshake e) ~ EENonce + -- , Pretty (Peer e) + -- , EventEmitter e (EncryptionHandshake e) m + , EventEmitter e (PeerAsymmInfo e) m + , HasCredentials s m + , Asymm s + , Signatures s + , Sessions e (EncryptionHandshake e) m + , Serialise (PubKey 'Encrypt (Encryption e)) + , s ~ Encryption e + , e ~ L4Proto + , PubKey Encrypt s ~ Encrypt.PublicKey + , Show (PubKey 'Sign s) + , Show (Nonce ()) + ) + => EncryptionHandshakeAdapter e m s + -> PeerEnv e + -> EncryptionHandshake e + -> m () encryptionHandshakeProto EncryptionHandshakeAdapter{..} penv = \case - BeginEncryptionExchange nonce theirpubkey -> do - pip <- thatPeer proto - trace $ "GOT BeginEncryptionExchange from" <+> pretty pip + ResetEncryptionKeys -> do + peer <- thatPeer proto + paddr <- toPeerAddr peer + mpeerData <- find (KnownPeerKey peer) id + -- TODO: check theirsign + trace $ "EHSP ResetEncryptionKeys from" <+> viaShow (peer, paddr, mpeerData) + encHandshake_considerPeerAsymmKey paddr mpeerData Nothing - paddr <- toPeerAddr pip - encHandshake_considerPeerAsymmKey paddr theirpubkey + creds <- getCredentials @s + let ourpubkey = pubKeyFromKeypair @s $ view envAsymmetricKeyPair penv + sendBeginEncryptionExchange @e penv creds peer ourpubkey + + BeginEncryptionExchange nonce0 theirsign theirpubkey -> do + peer <- thatPeer proto + paddr <- toPeerAddr peer + mpeerData <- find (KnownPeerKey peer) id + -- TODO: check theirsign + + trace $ "EHSP BeginEncryptionExchange from" <+> viaShow (peer, paddr, mpeerData) + + encHandshake_considerPeerAsymmKey paddr mpeerData (Just theirpubkey) -- взять свои ключи creds <- getCredentials @s @@ -94,28 +147,24 @@ encryptionHandshakeProto EncryptionHandshakeAdapter{..} penv = \case let ourpubkey = pubKeyFromKeypair @s $ view envAsymmetricKeyPair penv -- подписать нонс - let sign = makeSign @s (view peerSignSk creds) (unEENonce nonce <> (cs . serialise) ourpubkey) + let sign = makeSign @s (view peerSignSk creds) (unEENonce nonce0 <> (cs . serialise) ourpubkey) -- отправить обратно вместе с публичным ключом - response (AckEncryptionExchange @e nonce sign ourpubkey) + response (AckEncryptionExchange @e nonce0 sign ourpubkey) - -- Нужно ли запомнить его theirpubkey или достаточно того, что будет - -- получено в обратном AckEncryptionExchange? - -- Нужно! - emit PeerAsymmInfoKey (PeerAsymmPubKey pip theirpubkey) + emit PeerAsymmInfoKey (PeerAsymmPubKey peer theirpubkey) - -- se <- find (KnownPeerKey pip) id <&> isJust - -- unless se $ do - -- sendEncryptionPubKey pip ourpubkey + AckEncryptionExchange nonce0 theirsign theirpubkey -> do + peer <- thatPeer proto + paddr <- toPeerAddr peer + mpeerData <- find (KnownPeerKey peer) id + -- TODO: check theirsign - AckEncryptionExchange nonce0 sign theirpubkey -> do - pip <- thatPeer proto - -- trace $ "AckEncryptionExchange" <+> pretty pip + trace $ "EHSP AckEncryptionExchange from" <+> viaShow (peer, paddr, mpeerData) - paddr <- toPeerAddr pip - encHandshake_considerPeerAsymmKey paddr theirpubkey + encHandshake_considerPeerAsymmKey paddr mpeerData (Just theirpubkey) - emit PeerAsymmInfoKey (PeerAsymmPubKey pip theirpubkey) + emit PeerAsymmInfoKey (PeerAsymmPubKey peer theirpubkey) where proto = Proxy @(EncryptionHandshake e) diff --git a/hbs2-peer/app/Brains.hs b/hbs2-peer/app/Brains.hs index fd312d62..87045fcd 100644 --- a/hbs2-peer/app/Brains.hs +++ b/hbs2-peer/app/Brains.hs @@ -603,6 +603,8 @@ transactional brains action = do err $ "BRAINS: " <+> viaShow e execute_ conn [qc|ROLLBACK TO SAVEPOINT {sp}|] +--- + insertPeerAsymmKey :: forall e m . ( e ~ L4Proto , MonadIO m @@ -643,6 +645,26 @@ insertPeerSymmKey br peer hSymmKey = do |] (show $ pretty peer, show hSymmKey) +deletePeerAsymmKey :: forall e m . (e ~ L4Proto, MonadIO m) + => BasicBrains e -> PeerAddr e -> m () + +deletePeerAsymmKey br peer = + void $ liftIO $ execute (view brainsDb br) [qc| + DELETE FROM peer_symmkey + WHERE peer = ? + |] (Only (show $ pretty peer)) + +deletePeerSymmKey :: forall e m . (e ~ L4Proto, MonadIO m) + => BasicBrains e -> PeerAddr e -> m () + +deletePeerSymmKey br peer = + void $ liftIO $ execute (view brainsDb br) [qc| + DELETE FROM peer_symmkey + WHERE peer = ? + |] (Only (show $ pretty peer)) + +--- + -- FIXME: eventually-close-db newBasicBrains :: forall e m . (Hashable (Peer e), MonadIO m) => PeerConfig @@ -735,6 +757,7 @@ newBasicBrains cfg = liftIO do create table if not exists peer_asymmkey ( peer text not null , asymmkey text not null + , ts DATE DEFAULT (datetime('now','localtime')) , primary key (peer) ) |] @@ -743,6 +766,7 @@ newBasicBrains cfg = liftIO do create table if not exists peer_symmkey ( peer text not null , symmkey text not null + , ts DATE DEFAULT (datetime('now','localtime')) , primary key (peer) ) |] diff --git a/hbs2-peer/app/EncryptionKeys.hs b/hbs2-peer/app/EncryptionKeys.hs index 32820c79..18e069bb 100644 --- a/hbs2-peer/app/EncryptionKeys.hs +++ b/hbs2-peer/app/EncryptionKeys.hs @@ -52,15 +52,17 @@ encryptionHandshakeWorker :: forall e m s . -- , Sessions e (PeerInfo e) m -- , Sessions e (KnownPeer e) m -- , Pretty (Peer e) + -- , HasCredentials s m ) - => PeerConfig - -> PeerEnv e - -> EncryptionHandshakeAdapter e m s - -> m () + => PeerConfig + -> PeerEnv e + -> PeerCredentials s + -> EncryptionHandshakeAdapter e m s + -> m () -encryptionHandshakeWorker pconf penv EncryptionHandshakeAdapter{..} = do +encryptionHandshakeWorker pconf penv creds EncryptionHandshakeAdapter{..} = do - -- e <- ask + -- e :: PeerEnv e <- ask let ourpubkey = pubKeyFromKeypair @s $ _envAsymmetricKeyPair penv pl <- getPeerLocator @e @@ -68,7 +70,7 @@ encryptionHandshakeWorker pconf penv EncryptionHandshakeAdapter{..} = do forever do liftIO $ pause @'Seconds 10 - pips <- knownPeers @e pl + peers <- knownPeers @e pl - forM_ pips \p -> do - sendEncryptionPubKey @e p ourpubkey + forM_ peers \peer -> do + sendBeginEncryptionExchange @e penv creds peer ourpubkey diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index 51e4cf43..16ff1bcb 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -650,12 +650,16 @@ runPeer opts = U.handle (\e -> myException e ( MonadIO m ) => EncryptionHandshakeAdapter L4Proto m s encryptionHshakeAdapter = EncryptionHandshakeAdapter - { encHandshake_considerPeerAsymmKey = \addr pk -> do - insertPeerAsymmKey brains addr pk - insertPeerSymmKey brains addr $ - genCommonSecret @s - (privKeyFromKeypair @s (view envAsymmetricKeyPair penv)) - pk + { encHandshake_considerPeerAsymmKey = \addr mpeerData -> \case + Nothing -> do + deletePeerAsymmKey brains addr + deletePeerSymmKey brains addr + Just pk -> do + insertPeerAsymmKey brains addr pk + insertPeerSymmKey brains addr $ + genCommonSecret @s + (privKeyFromKeypair @s (view envAsymmetricKeyPair penv)) + pk } env <- ask @@ -807,7 +811,7 @@ runPeer opts = U.handle (\e -> myException e peerThread "blockDownloadLoop" (blockDownloadLoop denv) peerThread "encryptionHandshakeWorker" - (EncryptionKeys.encryptionHandshakeWorker @e conf penv encryptionHshakeAdapter) + (EncryptionKeys.encryptionHandshakeWorker @e conf penv pc encryptionHshakeAdapter) let tcpProbeWait :: Timeout 'Seconds tcpProbeWait = (fromInteger . fromMaybe 300) (cfgValue @PeerTcpProbeWaitKey conf) diff --git a/hbs2-peer/app/ProxyMessaging.hs b/hbs2-peer/app/ProxyMessaging.hs index cea156e1..88c15441 100644 --- a/hbs2-peer/app/ProxyMessaging.hs +++ b/hbs2-peer/app/ProxyMessaging.hs @@ -151,6 +151,13 @@ receiveFromProxyMessaging bus _ = liftIO do encKeys <- (liftIO . readTVarIO) (view proxyEncryptionKeys bus) fmap (w, ) <$> dfm whom (Map.lookup whom encKeys) msg + -- TODO: + -- Если мы не смогли, по любой причине, расшифровать сообщение, + -- то нужно стереть у себя ключ + -- Если мы не смогли, по любой причине, расшифровать сообщение, + -- но уверены что оно зашифровано, то нужно отправить + -- sendResetEncryptionKeys + where dfm :: Peer L4Proto -> Maybe Encrypt.CombinedKey -> LBS.ByteString -> IO (Maybe LBS.ByteString) dfm = \whom mk msg -> case mk of From e43f2c439d04b367d199ae98616e76f453e872a6 Mon Sep 17 00:00:00 2001 From: Sergey Ivanov Date: Wed, 12 Jul 2023 23:24:37 +0400 Subject: [PATCH 09/31] wip --- .../lib/HBS2/Net/Proto/EncryptionHandshake.hs | 26 +++++++++---------- hbs2-peer/app/Brains.hs | 8 +++--- hbs2-peer/app/PeerMain.hs | 10 +++---- hbs2-peer/app/ProxyMessaging.hs | 10 +++++++ 4 files changed, 31 insertions(+), 23 deletions(-) diff --git a/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs b/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs index dc373cb3..4ab3c59b 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs @@ -85,7 +85,7 @@ sendBeginEncryptionExchange penv creds peer pubkey = do request peer (BeginEncryptionExchange @e nonce0 sign pubkey) data EncryptionHandshakeAdapter e m s = EncryptionHandshakeAdapter - { encHandshake_considerPeerAsymmKey :: PeerAddr e -> Maybe (PeerData e) -> Maybe Encrypt.PublicKey -> m () + { encHandshake_considerPeerAsymmKey :: Peer e -> Maybe (PeerData e) -> Maybe Encrypt.PublicKey -> m () } @@ -121,11 +121,10 @@ encryptionHandshakeProto EncryptionHandshakeAdapter{..} penv = \case ResetEncryptionKeys -> do peer <- thatPeer proto - paddr <- toPeerAddr peer mpeerData <- find (KnownPeerKey peer) id -- TODO: check theirsign - trace $ "EHSP ResetEncryptionKeys from" <+> viaShow (peer, paddr, mpeerData) - encHandshake_considerPeerAsymmKey paddr mpeerData Nothing + trace $ "EHSP ResetEncryptionKeys from" <+> viaShow (peer, mpeerData) + encHandshake_considerPeerAsymmKey peer mpeerData Nothing creds <- getCredentials @s let ourpubkey = pubKeyFromKeypair @s $ view envAsymmetricKeyPair penv @@ -133,13 +132,10 @@ encryptionHandshakeProto EncryptionHandshakeAdapter{..} penv = \case BeginEncryptionExchange nonce0 theirsign theirpubkey -> do peer <- thatPeer proto - paddr <- toPeerAddr peer mpeerData <- find (KnownPeerKey peer) id -- TODO: check theirsign - trace $ "EHSP BeginEncryptionExchange from" <+> viaShow (peer, paddr, mpeerData) - - encHandshake_considerPeerAsymmKey paddr mpeerData (Just theirpubkey) + trace $ "EHSP BeginEncryptionExchange from" <+> viaShow (peer, mpeerData) -- взять свои ключи creds <- getCredentials @s @@ -150,21 +146,23 @@ encryptionHandshakeProto EncryptionHandshakeAdapter{..} penv = \case let sign = makeSign @s (view peerSignSk creds) (unEENonce nonce0 <> (cs . serialise) ourpubkey) -- отправить обратно вместе с публичным ключом + -- отправится пока ещё в плоском виде response (AckEncryptionExchange @e nonce0 sign ourpubkey) - emit PeerAsymmInfoKey (PeerAsymmPubKey peer theirpubkey) + -- Только после этого прописываем его ключ у себя + encHandshake_considerPeerAsymmKey peer mpeerData (Just theirpubkey) + -- emit PeerAsymmInfoKey (PeerAsymmPubKey peer theirpubkey) AckEncryptionExchange nonce0 theirsign theirpubkey -> do peer <- thatPeer proto - paddr <- toPeerAddr peer mpeerData <- find (KnownPeerKey peer) id -- TODO: check theirsign - trace $ "EHSP AckEncryptionExchange from" <+> viaShow (peer, paddr, mpeerData) + trace $ "EHSP AckEncryptionExchange from" <+> viaShow (peer, mpeerData) - encHandshake_considerPeerAsymmKey paddr mpeerData (Just theirpubkey) - - emit PeerAsymmInfoKey (PeerAsymmPubKey peer theirpubkey) + -- Прописываем его ключ у себя + encHandshake_considerPeerAsymmKey peer mpeerData (Just theirpubkey) + -- emit PeerAsymmInfoKey (PeerAsymmPubKey peer theirpubkey) where proto = Proxy @(EncryptionHandshake e) diff --git a/hbs2-peer/app/Brains.hs b/hbs2-peer/app/Brains.hs index 87045fcd..6df0c074 100644 --- a/hbs2-peer/app/Brains.hs +++ b/hbs2-peer/app/Brains.hs @@ -610,7 +610,7 @@ insertPeerAsymmKey :: forall e m . , MonadIO m ) => BasicBrains e - -> PeerAddr e + -> Peer e -> Encrypt.PublicKey -> m () @@ -630,7 +630,7 @@ insertPeerSymmKey :: forall e m . , MonadIO m ) => BasicBrains e - -> PeerAddr e + -> Peer e -> Encrypt.CombinedKey -> m () @@ -646,7 +646,7 @@ insertPeerSymmKey br peer hSymmKey = do |] (show $ pretty peer, show hSymmKey) deletePeerAsymmKey :: forall e m . (e ~ L4Proto, MonadIO m) - => BasicBrains e -> PeerAddr e -> m () + => BasicBrains e -> Peer e -> m () deletePeerAsymmKey br peer = void $ liftIO $ execute (view brainsDb br) [qc| @@ -655,7 +655,7 @@ deletePeerAsymmKey br peer = |] (Only (show $ pretty peer)) deletePeerSymmKey :: forall e m . (e ~ L4Proto, MonadIO m) - => BasicBrains e -> PeerAddr e -> m () + => BasicBrains e -> Peer e -> m () deletePeerSymmKey br peer = void $ liftIO $ execute (view brainsDb br) [qc| diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index 16ff1bcb..6150bdcf 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -650,13 +650,13 @@ runPeer opts = U.handle (\e -> myException e ( MonadIO m ) => EncryptionHandshakeAdapter L4Proto m s encryptionHshakeAdapter = EncryptionHandshakeAdapter - { encHandshake_considerPeerAsymmKey = \addr mpeerData -> \case + { encHandshake_considerPeerAsymmKey = \peer mpeerData -> \case Nothing -> do - deletePeerAsymmKey brains addr - deletePeerSymmKey brains addr + deletePeerAsymmKey brains peer + deletePeerSymmKey brains peer Just pk -> do - insertPeerAsymmKey brains addr pk - insertPeerSymmKey brains addr $ + insertPeerAsymmKey brains peer pk + insertPeerSymmKey brains peer $ genCommonSecret @s (privKeyFromKeypair @s (view envAsymmetricKeyPair penv)) pk diff --git a/hbs2-peer/app/ProxyMessaging.hs b/hbs2-peer/app/ProxyMessaging.hs index 88c15441..3e4c403e 100644 --- a/hbs2-peer/app/ProxyMessaging.hs +++ b/hbs2-peer/app/ProxyMessaging.hs @@ -151,6 +151,16 @@ receiveFromProxyMessaging bus _ = liftIO do encKeys <- (liftIO . readTVarIO) (view proxyEncryptionKeys bus) fmap (w, ) <$> dfm whom (Map.lookup whom encKeys) msg + -- Здесь: + -- 1. У нас есть ключ сессии и мы не смогли расшифровать -> do + -- удаляем у себя ключ + -- отправляем sendResetEncryptionKeys + -- 2. У нас нет ключа сессии -> do + -- просто передаём сообщение как есть + + -- В протоколе пингов: + -- 1. Если слишком долго нет ответа на ping, то удаляем у себя ключ, отправляем sendResetEncryptionKeys + -- TODO: -- Если мы не смогли, по любой причине, расшифровать сообщение, -- то нужно стереть у себя ключ From e53c6e84fca4437db719e6ab557c92386ab220f4 Mon Sep 17 00:00:00 2001 From: Sergey Ivanov Date: Wed, 12 Jul 2023 23:27:51 +0400 Subject: [PATCH 10/31] move emit PeerAsymmInfoKey to PeerMain --- hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs | 9 --------- hbs2-peer/app/PeerMain.hs | 2 ++ 2 files changed, 2 insertions(+), 9 deletions(-) diff --git a/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs b/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs index 4ab3c59b..05763e23 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs @@ -94,13 +94,6 @@ encryptionHandshakeProto :: forall e s m . , Response e (EncryptionHandshake e) m , Request e (EncryptionHandshake e) m , Sessions e (KnownPeer e) m - -- , Sessions e (EncryptionHandshake e) m - -- , HasNonces (EncryptionHandshake e) m - -- , HasPeerNonce e m - -- , Nonce (EncryptionHandshake e) ~ EENonce - -- , Pretty (Peer e) - -- , EventEmitter e (EncryptionHandshake e) m - , EventEmitter e (PeerAsymmInfo e) m , HasCredentials s m , Asymm s , Signatures s @@ -151,7 +144,6 @@ encryptionHandshakeProto EncryptionHandshakeAdapter{..} penv = \case -- Только после этого прописываем его ключ у себя encHandshake_considerPeerAsymmKey peer mpeerData (Just theirpubkey) - -- emit PeerAsymmInfoKey (PeerAsymmPubKey peer theirpubkey) AckEncryptionExchange nonce0 theirsign theirpubkey -> do peer <- thatPeer proto @@ -162,7 +154,6 @@ encryptionHandshakeProto EncryptionHandshakeAdapter{..} penv = \case -- Прописываем его ключ у себя encHandshake_considerPeerAsymmKey peer mpeerData (Just theirpubkey) - -- emit PeerAsymmInfoKey (PeerAsymmPubKey peer theirpubkey) where proto = Proxy @(EncryptionHandshake e) diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index 6150bdcf..d9293c93 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -648,6 +648,7 @@ runPeer opts = U.handle (\e -> myException e let encryptionHshakeAdapter :: ( MonadIO m + , EventEmitter e (PeerAsymmInfo e) m ) => EncryptionHandshakeAdapter L4Proto m s encryptionHshakeAdapter = EncryptionHandshakeAdapter { encHandshake_considerPeerAsymmKey = \peer mpeerData -> \case @@ -655,6 +656,7 @@ runPeer opts = U.handle (\e -> myException e deletePeerAsymmKey brains peer deletePeerSymmKey brains peer Just pk -> do + emit PeerAsymmInfoKey (PeerAsymmPubKey peer pk) insertPeerAsymmKey brains peer pk insertPeerSymmKey brains peer $ genCommonSecret @s From 686ac2523dd1041cc89e29e8ddee0a128c5c3365 Mon Sep 17 00:00:00 2001 From: Sergey Ivanov Date: Wed, 12 Jul 2023 23:41:08 +0400 Subject: [PATCH 11/31] wip --- hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs | 8 +++++++- hbs2-peer/app/PeerMain.hs | 2 +- 2 files changed, 8 insertions(+), 2 deletions(-) diff --git a/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs b/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs index 05763e23..f6060e60 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs @@ -117,6 +117,8 @@ encryptionHandshakeProto EncryptionHandshakeAdapter{..} penv = \case mpeerData <- find (KnownPeerKey peer) id -- TODO: check theirsign trace $ "EHSP ResetEncryptionKeys from" <+> viaShow (peer, mpeerData) + + -- сначала удалим у себя его прошлый ключ encHandshake_considerPeerAsymmKey peer mpeerData Nothing creds <- getCredentials @s @@ -138,7 +140,10 @@ encryptionHandshakeProto EncryptionHandshakeAdapter{..} penv = \case -- подписать нонс let sign = makeSign @s (view peerSignSk creds) (unEENonce nonce0 <> (cs . serialise) ourpubkey) - -- отправить обратно вместе с публичным ключом + -- сначала удалим у себя его прошлый ключ + encHandshake_considerPeerAsymmKey peer mpeerData Nothing + + -- отправить обратно свой публичный ключ -- отправится пока ещё в плоском виде response (AckEncryptionExchange @e nonce0 sign ourpubkey) @@ -152,6 +157,7 @@ encryptionHandshakeProto EncryptionHandshakeAdapter{..} penv = \case trace $ "EHSP AckEncryptionExchange from" <+> viaShow (peer, mpeerData) + -- Он уже прописал у себя наш публичный ключ и готов общаться шифрованными сообщениями -- Прописываем его ключ у себя encHandshake_considerPeerAsymmKey peer mpeerData (Just theirpubkey) diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index d9293c93..0aca3331 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -656,7 +656,7 @@ runPeer opts = U.handle (\e -> myException e deletePeerAsymmKey brains peer deletePeerSymmKey brains peer Just pk -> do - emit PeerAsymmInfoKey (PeerAsymmPubKey peer pk) + -- emit PeerAsymmInfoKey (PeerAsymmPubKey peer pk) insertPeerAsymmKey brains peer pk insertPeerSymmKey brains peer $ genCommonSecret @s From 5b5c9bd90905e75526a99a05744071b364178e41 Mon Sep 17 00:00:00 2001 From: Sergey Ivanov Date: Thu, 13 Jul 2023 00:29:18 +0400 Subject: [PATCH 12/31] Drop EENonce from EncryptionHandshake --- .../lib/HBS2/Net/Proto/EncryptionHandshake.hs | 30 ++++++------------- 1 file changed, 9 insertions(+), 21 deletions(-) diff --git a/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs b/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs index f6060e60..79657cb8 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs @@ -26,11 +26,6 @@ import Data.String.Conversions (cs) import Lens.Micro.Platform import Type.Reflection (someTypeRep) -newtype EENonce = EENonce { unEENonce :: BS.ByteString } - deriving stock (Generic) - deriving newtype (Eq, Serialise, Hashable) - deriving (Pretty, Show) via AsBase58 BS.ByteString - instance ( Show (PubKey 'Encrypt (Encryption e)) , Show (PubKey 'Sign (Encryption e)) @@ -40,8 +35,8 @@ instance pretty = viaShow data EncryptionHandshake e = - BeginEncryptionExchange EENonce (Signature (Encryption e)) (PubKey 'Encrypt (Encryption e)) - | AckEncryptionExchange EENonce (Signature (Encryption e)) (PubKey 'Encrypt (Encryption e)) + BeginEncryptionExchange (Signature (Encryption e)) (PubKey 'Encrypt (Encryption e)) + | AckEncryptionExchange (Signature (Encryption e)) (PubKey 'Encrypt (Encryption e)) | ResetEncryptionKeys deriving stock (Generic) @@ -61,12 +56,10 @@ sendBeginEncryptionExchange :: forall e s m . ( MonadIO m , Request e (EncryptionHandshake e) m , Sessions e (EncryptionHandshake e) m - , HasNonces (EncryptionHandshake e) m -- , HasCredentials s m , Asymm s , Signatures s , Serialise (PubKey 'Encrypt s) - , Nonce (EncryptionHandshake e) ~ EENonce , Pretty (Peer e) , HasProtocol e (EncryptionHandshake e) , e ~ L4Proto @@ -79,10 +72,9 @@ sendBeginEncryptionExchange :: forall e s m . -> m () sendBeginEncryptionExchange penv creds peer pubkey = do - nonce0 <- newNonce @(EncryptionHandshake e) let ourpubkey = pubKeyFromKeypair @s $ view envAsymmetricKeyPair penv - let sign = makeSign @s (view peerSignSk creds) (unEENonce nonce0 <> (cs . serialise) ourpubkey) - request peer (BeginEncryptionExchange @e nonce0 sign pubkey) + let sign = makeSign @s (view peerSignSk creds) ((cs . serialise) ourpubkey) + request peer (BeginEncryptionExchange @e sign pubkey) data EncryptionHandshakeAdapter e m s = EncryptionHandshakeAdapter { encHandshake_considerPeerAsymmKey :: Peer e -> Maybe (PeerData e) -> Maybe Encrypt.PublicKey -> m () @@ -125,7 +117,7 @@ encryptionHandshakeProto EncryptionHandshakeAdapter{..} penv = \case let ourpubkey = pubKeyFromKeypair @s $ view envAsymmetricKeyPair penv sendBeginEncryptionExchange @e penv creds peer ourpubkey - BeginEncryptionExchange nonce0 theirsign theirpubkey -> do + BeginEncryptionExchange theirsign theirpubkey -> do peer <- thatPeer proto mpeerData <- find (KnownPeerKey peer) id -- TODO: check theirsign @@ -138,19 +130,19 @@ encryptionHandshakeProto EncryptionHandshakeAdapter{..} penv = \case let ourpubkey = pubKeyFromKeypair @s $ view envAsymmetricKeyPair penv -- подписать нонс - let sign = makeSign @s (view peerSignSk creds) (unEENonce nonce0 <> (cs . serialise) ourpubkey) + let sign = makeSign @s (view peerSignSk creds) ((cs . serialise) ourpubkey) -- сначала удалим у себя его прошлый ключ encHandshake_considerPeerAsymmKey peer mpeerData Nothing -- отправить обратно свой публичный ключ -- отправится пока ещё в плоском виде - response (AckEncryptionExchange @e nonce0 sign ourpubkey) + response (AckEncryptionExchange @e sign ourpubkey) -- Только после этого прописываем его ключ у себя encHandshake_considerPeerAsymmKey peer mpeerData (Just theirpubkey) - AckEncryptionExchange nonce0 theirsign theirpubkey -> do + AckEncryptionExchange theirsign theirpubkey -> do peer <- thatPeer proto mpeerData <- find (KnownPeerKey peer) id -- TODO: check theirsign @@ -181,10 +173,6 @@ data instance Event e (PeerAsymmInfo e) = instance Expires (EventKey e (PeerAsymmInfo e)) where expiresIn _ = Nothing -instance MonadIO m => HasNonces (EncryptionHandshake L4Proto) m where - type instance Nonce (EncryptionHandshake L4Proto) = EENonce - newNonce = EENonce . BS.take 32 . Crypto.encode <$> liftIO Encrypt.newNonce - instance ( Serialise (PubKey 'Sign (Encryption e)) , Serialise (PubKey 'Encrypt (Encryption e)) @@ -201,7 +189,7 @@ deriving instance type instance SessionData e (EncryptionHandshake e) = () newtype instance SessionKey e (EncryptionHandshake e) = - KnownPeerAsymmInfoKey (EENonce, Peer e) + KnownPeerAsymmInfoKey (Peer e) deriving stock (Generic, Typeable) deriving instance Eq (Peer e) => Eq (SessionKey e (EncryptionHandshake e)) From 792d627870f631292bee140b83428d8820d18f9a Mon Sep 17 00:00:00 2001 From: Sergey Ivanov Date: Thu, 13 Jul 2023 00:36:50 +0400 Subject: [PATCH 13/31] drop: instance Hashable (EventKey e (EncryptionHandshake e)) --- hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs b/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs index 79657cb8..d5e46075 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs @@ -198,5 +198,3 @@ instance Hashable (Peer e) => Hashable (SessionKey e (EncryptionHandshake e)) data instance EventKey e (EncryptionHandshake e) = AnyKnownPeerEncryptionHandshakeEventKey deriving stock (Typeable, Eq,Generic) - -instance Hashable (EventKey e (EncryptionHandshake e)) From dd9cbcd284aec3184cf84eb171f1f66cdde616c6 Mon Sep 17 00:00:00 2001 From: Sergey Ivanov Date: Thu, 13 Jul 2023 00:57:38 +0400 Subject: [PATCH 14/31] Change encryption handshake brains methods --- hbs2-peer/app/Brains.hs | 70 ++++++++++++++------------------------- hbs2-peer/app/PeerMain.hs | 11 +++--- 2 files changed, 32 insertions(+), 49 deletions(-) diff --git a/hbs2-peer/app/Brains.hs b/hbs2-peer/app/Brains.hs index 6df0c074..6a710dfc 100644 --- a/hbs2-peer/app/Brains.hs +++ b/hbs2-peer/app/Brains.hs @@ -605,63 +605,51 @@ transactional brains action = do --- -insertPeerAsymmKey :: forall e m . - ( e ~ L4Proto - , MonadIO m - ) +insertPeerAsymmKey :: forall e m . (e ~ L4Proto, MonadIO m) => BasicBrains e -> Peer e -> Encrypt.PublicKey - -> m () - -insertPeerAsymmKey br peer hAsymmKey = do - let conn = view brainsDb br - void $ liftIO $ execute conn [qc| - INSERT INTO peer_asymmkey (peer,asymmkey) - VALUES (?,?) - ON CONFLICT (peer) - DO UPDATE SET - asymmkey = excluded.asymmkey - - |] (show $ pretty peer, show hAsymmKey) - -insertPeerSymmKey :: forall e m . - ( e ~ L4Proto - , MonadIO m - ) - => BasicBrains e - -> Peer e -> Encrypt.CombinedKey -> m () -insertPeerSymmKey br peer hSymmKey = do +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_symmkey (peer,symmkey) - VALUES (?,?) + INSERT INTO peer_asymmkey (peer,asymmkey,symmkey) + VALUES (?,?,?) ON CONFLICT (peer) DO UPDATE SET - symmkey = excluded.symmkey + asymmkey = excluded.asymmkey + , symmkey = excluded.symmkey + |] (key, show hAsymmKey, show hSymmKey) - |] (show $ pretty peer, show hSymmKey) +--- deletePeerAsymmKey :: forall e m . (e ~ L4Proto, MonadIO m) => BasicBrains e -> Peer e -> m () deletePeerAsymmKey br peer = - void $ liftIO $ execute (view brainsDb br) [qc| - DELETE FROM peer_symmkey - WHERE peer = ? - |] (Only (show $ pretty peer)) + deletePeerAsymmKey' br (show $ pretty peer) -deletePeerSymmKey :: forall e m . (e ~ L4Proto, MonadIO m) - => BasicBrains e -> Peer e -> m () +deletePeerAsymmKey' :: forall e m . (e ~ L4Proto, MonadIO m) + => BasicBrains e -> String -> m () -deletePeerSymmKey br peer = +deletePeerAsymmKey' br key = void $ liftIO $ execute (view brainsDb br) [qc| - DELETE FROM peer_symmkey + DELETE FROM peer_asymmkey WHERE peer = ? - |] (Only (show $ pretty peer)) + |] (Only key) --- @@ -757,14 +745,6 @@ newBasicBrains cfg = liftIO do create table if not exists peer_asymmkey ( peer text not null , asymmkey text not null - , ts DATE DEFAULT (datetime('now','localtime')) - , primary key (peer) - ) - |] - - execute_ conn [qc| - create table if not exists peer_symmkey - ( peer text not null , symmkey text not null , ts DATE DEFAULT (datetime('now','localtime')) , primary key (peer) diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index 0aca3331..fcb46d06 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -654,14 +654,17 @@ runPeer opts = U.handle (\e -> myException e { encHandshake_considerPeerAsymmKey = \peer mpeerData -> \case Nothing -> do deletePeerAsymmKey brains peer - deletePeerSymmKey brains peer + forM_ mpeerData \peerData -> + deletePeerAsymmKey' brains (show peerData) Just pk -> do -- emit PeerAsymmInfoKey (PeerAsymmPubKey peer pk) - insertPeerAsymmKey brains peer pk - insertPeerSymmKey brains peer $ - genCommonSecret @s + let symmk = genCommonSecret @s (privKeyFromKeypair @s (view envAsymmetricKeyPair penv)) pk + case mpeerData of + Nothing -> insertPeerAsymmKey brains peer pk symmk + Just peerData -> + insertPeerAsymmKey' brains (show peerData) pk symmk } env <- ask From 43652343ab844c4aa355f3db722b0dec80184c06 Mon Sep 17 00:00:00 2001 From: Sergey Ivanov Date: Thu, 13 Jul 2023 01:10:51 +0400 Subject: [PATCH 15/31] pause 10 -> 30 in encryptionHandshakeWorker --- hbs2-peer/app/EncryptionKeys.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hbs2-peer/app/EncryptionKeys.hs b/hbs2-peer/app/EncryptionKeys.hs index 18e069bb..81f2d827 100644 --- a/hbs2-peer/app/EncryptionKeys.hs +++ b/hbs2-peer/app/EncryptionKeys.hs @@ -68,7 +68,7 @@ encryptionHandshakeWorker pconf penv creds EncryptionHandshakeAdapter{..} = do pl <- getPeerLocator @e forever do - liftIO $ pause @'Seconds 10 + liftIO $ pause @'Seconds 30 peers <- knownPeers @e pl From 8944b5a1c04b7a06a41e690e1cc64c431976381f Mon Sep 17 00:00:00 2001 From: Sergey Ivanov Date: Thu, 13 Jul 2023 01:39:27 +0400 Subject: [PATCH 16/31] what to do when unable to decrypt messages --- hbs2-peer/app/ProxyMessaging.hs | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/hbs2-peer/app/ProxyMessaging.hs b/hbs2-peer/app/ProxyMessaging.hs index 3e4c403e..30e18bbf 100644 --- a/hbs2-peer/app/ProxyMessaging.hs +++ b/hbs2-peer/app/ProxyMessaging.hs @@ -154,31 +154,31 @@ receiveFromProxyMessaging bus _ = liftIO do -- Здесь: -- 1. У нас есть ключ сессии и мы не смогли расшифровать -> do -- удаляем у себя ключ - -- отправляем sendResetEncryptionKeys - -- 2. У нас нет ключа сессии -> do + -- отправляем sendBeginEncryptionExchange + -- 2. У нас (до сих пор, даже если мы давно стартовали) нет ключа сессии -> do + -- sendResetEncryptionKeys -- просто передаём сообщение как есть -- В протоколе пингов: -- 1. Если слишком долго нет ответа на ping, то удаляем у себя ключ, отправляем sendResetEncryptionKeys - -- TODO: - -- Если мы не смогли, по любой причине, расшифровать сообщение, - -- то нужно стереть у себя ключ - -- Если мы не смогли, по любой причине, расшифровать сообщение, - -- но уверены что оно зашифровано, то нужно отправить - -- sendResetEncryptionKeys - 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 + -- TODO: run sendResetEncryptionKeys pure (Just msg) Just k -> runMaybeT $ -- А будем-ка мы просто передавать сообщение дальше как есть, если не смогли расшифровать (<|> (do - -- И сотрём ключ из памяти + + -- сотрём ключ из памяти -- liftIO $ atomically $ modifyTVar' (view proxyEncryptionKeys bus) $ Lens.at whom .~ Nothing + + -- TODO: удаляем у себя ключ + -- TODO: run sendBeginEncryptionExchange + trace $ "ENCRYPTION RECEIVE: got plain message. clearing key of" <+> pretty whom pure msg )) $ From 563377c855556f9e199208145e1561f47a9b5ba6 Mon Sep 17 00:00:00 2001 From: Sergey Ivanov Date: Tue, 18 Jul 2023 19:37:02 +0400 Subject: [PATCH 17/31] emit PeerExpiredEventKey (PeerExpiredEvent @e p) --- hbs2-core/hbs2-core.cabal | 1 + .../lib/HBS2/Net/Proto/Event/PeerExpired.hs | 33 +++++++++++++++++++ hbs2-peer/app/PeerInfo.hs | 2 ++ 3 files changed, 36 insertions(+) create mode 100644 hbs2-core/lib/HBS2/Net/Proto/Event/PeerExpired.hs diff --git a/hbs2-core/hbs2-core.cabal b/hbs2-core/hbs2-core.cabal index 5d71be67..62036cb6 100644 --- a/hbs2-core/hbs2-core.cabal +++ b/hbs2-core/hbs2-core.cabal @@ -95,6 +95,7 @@ library , 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 diff --git a/hbs2-core/lib/HBS2/Net/Proto/Event/PeerExpired.hs b/hbs2-core/lib/HBS2/Net/Proto/Event/PeerExpired.hs new file mode 100644 index 00000000..55d7d641 --- /dev/null +++ b/hbs2-core/lib/HBS2/Net/Proto/Event/PeerExpired.hs @@ -0,0 +1,33 @@ +module HBS2.Net.Proto.Event.PeerExpired where + +import HBS2.Clock +import HBS2.Events +import HBS2.Net.Proto +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) + 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 + diff --git a/hbs2-peer/app/PeerInfo.hs b/hbs2-peer/app/PeerInfo.hs index cf2ed433..813bb5d0 100644 --- a/hbs2-peer/app/PeerInfo.hs +++ b/hbs2-peer/app/PeerInfo.hs @@ -7,6 +7,7 @@ import HBS2.Clock 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 @@ -221,6 +222,7 @@ peerPingLoop cfg penv = do delPeers pl [p] expire (PeerInfoKey p) expire (KnownPeerKey p) + emit PeerExpiredEventKey (PeerExpiredEvent @e p) liftIO $ mapM_ link [watch, infoLoop] From 5a8f1cef8bf4c1d4aa788bc4a9641bd24fe2deca Mon Sep 17 00:00:00 2001 From: Sergey Ivanov Date: Tue, 18 Jul 2023 19:56:39 +0400 Subject: [PATCH 18/31] emit PeerExpiredEventKey (PeerExpiredEvent @e p mpeerData) --- hbs2-core/lib/HBS2/Net/Proto/Event/PeerExpired.hs | 3 ++- hbs2-peer/app/PeerInfo.hs | 3 ++- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/hbs2-core/lib/HBS2/Net/Proto/Event/PeerExpired.hs b/hbs2-core/lib/HBS2/Net/Proto/Event/PeerExpired.hs index 55d7d641..8206f346 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/Event/PeerExpired.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/Event/PeerExpired.hs @@ -3,6 +3,7 @@ module HBS2.Net.Proto.Event.PeerExpired where import HBS2.Clock import HBS2.Events import HBS2.Net.Proto +import HBS2.Net.Proto.Peer import HBS2.Prelude.Plated data PeerExpires = PeerExpires @@ -12,7 +13,7 @@ data instance EventKey e PeerExpires = deriving stock (Typeable, Eq, Generic) data instance Event e PeerExpires = - PeerExpiredEvent (Peer e) + PeerExpiredEvent (Peer e) (Maybe (PeerData e)) deriving stock (Typeable) instance EventType (Event e PeerExpires) where diff --git a/hbs2-peer/app/PeerInfo.hs b/hbs2-peer/app/PeerInfo.hs index 813bb5d0..0c7d7fae 100644 --- a/hbs2-peer/app/PeerInfo.hs +++ b/hbs2-peer/app/PeerInfo.hs @@ -219,10 +219,11 @@ peerPingLoop cfg penv = 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) + emit PeerExpiredEventKey (PeerExpiredEvent @e p mpeerData) liftIO $ mapM_ link [watch, infoLoop] From fec0c23a7f7504ee5812e769de9eeba18a21a562 Mon Sep 17 00:00:00 2001 From: Sergey Ivanov Date: Tue, 18 Jul 2023 20:38:01 +0400 Subject: [PATCH 19/31] wip --- hbs2-peer/app/EncryptionKeys.hs | 1 + hbs2-peer/app/ProxyMessaging.hs | 48 +++++++++++++++++++-------------- 2 files changed, 29 insertions(+), 20 deletions(-) diff --git a/hbs2-peer/app/EncryptionKeys.hs b/hbs2-peer/app/EncryptionKeys.hs index 81f2d827..69a702b3 100644 --- a/hbs2-peer/app/EncryptionKeys.hs +++ b/hbs2-peer/app/EncryptionKeys.hs @@ -73,4 +73,5 @@ encryptionHandshakeWorker pconf penv creds EncryptionHandshakeAdapter{..} = do peers <- knownPeers @e pl forM_ peers \peer -> do + -- TODO: Только если ещё не знаем ключ ноды sendBeginEncryptionExchange @e penv creds peer ourpubkey diff --git a/hbs2-peer/app/ProxyMessaging.hs b/hbs2-peer/app/ProxyMessaging.hs index 30e18bbf..626d9c22 100644 --- a/hbs2-peer/app/ProxyMessaging.hs +++ b/hbs2-peer/app/ProxyMessaging.hs @@ -1,10 +1,8 @@ {-# Language TemplateHaskell #-} module ProxyMessaging - ( ProxyMessaging - , PlainProxyMessaging(..) + ( ProxyMessaging(..) , newProxyMessaging , runProxyMessaging - , proxyEncryptionKeys , sendToPlainProxyMessaging ) where @@ -49,10 +47,12 @@ data ProxyMessaging = { _proxyUDP :: MessagingUDP , _proxyTCP :: Maybe MessagingTCP , _proxyAnswers :: TQueue (From L4Proto, LBS.ByteString) - , _proxyEncryptionKeys :: TVar (Map (Peer L4Proto) (CommonSecret (Encryption L4Proto))) - } -newtype PlainProxyMessaging = PlainProxyMessaging ProxyMessaging + , _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 @@ -67,9 +67,16 @@ newProxyMessaging :: forall m . MonadIO m -> m ProxyMessaging newProxyMessaging u t = liftIO do - ProxyMessaging u t - <$> newTQueueIO - <*> newTVarIO mempty + let _proxyUDP = u + 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 @@ -130,8 +137,8 @@ sendToProxyMessaging :: (MonadIO m) 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 + mencKey <- liftIO $ _proxy_getEncryptionKey bus whom + cf <- case mencKey of Nothing -> do trace $ "ENCRYPTION SEND: sending plain message to" <+> pretty whom pure id @@ -148,8 +155,7 @@ receiveFromProxyMessaging bus _ = liftIO do let answ = view proxyAnswers bus rs <- atomically $ liftM2 (:) (readTQueue answ) (flushTQueue answ) fmap catMaybes $ forM rs \(w@(From whom), msg) -> do - encKeys <- (liftIO . readTVarIO) (view proxyEncryptionKeys bus) - fmap (w, ) <$> dfm whom (Map.lookup whom encKeys) msg + fmap (w, ) <$> dfm whom msg -- Здесь: -- 1. У нас есть ключ сессии и мы не смогли расшифровать -> do @@ -161,23 +167,25 @@ receiveFromProxyMessaging bus _ = liftIO do -- В протоколе пингов: -- 1. Если слишком долго нет ответа на ping, то удаляем у себя ключ, отправляем sendResetEncryptionKeys + -- Выполняется в PeerInfo: + -- emit PeerExpiredEventKey (PeerExpiredEvent @e p mpeerData) where - dfm :: Peer L4Proto -> Maybe Encrypt.CombinedKey -> LBS.ByteString -> IO (Maybe LBS.ByteString) - dfm = \whom mk msg -> case mk of + 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 - -- TODO: run sendResetEncryptionKeys + liftIO $ _proxy_sendBeginEncryptionExchange bus whom pure (Just msg) + Just k -> runMaybeT $ -- А будем-ка мы просто передавать сообщение дальше как есть, если не смогли расшифровать (<|> (do - -- сотрём ключ из памяти - -- liftIO $ atomically $ modifyTVar' (view proxyEncryptionKeys bus) $ Lens.at whom .~ Nothing + liftIO $ _proxy_clearEncryptionKey bus whom - -- TODO: удаляем у себя ключ - -- TODO: run sendBeginEncryptionExchange + liftIO $ _proxy_sendResetEncryptionKeys bus whom trace $ "ENCRYPTION RECEIVE: got plain message. clearing key of" <+> pretty whom pure msg From 9bad16656668812cb24438fe9daa2ad46aa81c92 Mon Sep 17 00:00:00 2001 From: Sergey Ivanov Date: Tue, 18 Jul 2023 21:37:02 +0400 Subject: [PATCH 20/31] Move types --- hbs2-core/hbs2-core.cabal | 2 ++ hbs2-core/lib/HBS2/Actors/Peer.hs | 3 ++ hbs2-core/lib/HBS2/Data/Types.hs | 8 ++--- hbs2-core/lib/HBS2/Data/Types/Crypto.hs | 25 ++++++++++++++++ hbs2-core/lib/HBS2/Data/Types/Peer.hs | 30 +++++++++++++++++++ hbs2-core/lib/HBS2/Net/Proto/Definition.hs | 19 ++---------- .../lib/HBS2/Net/Proto/Event/PeerExpired.hs | 1 + hbs2-core/lib/HBS2/Net/Proto/Peer.hs | 18 ----------- hbs2-core/lib/HBS2/Prelude.hs | 4 +++ hbs2-peer/app/Bootstrap.hs | 1 + hbs2-peer/app/PeerInfo.hs | 1 + hbs2-peer/app/PeerMain.hs | 14 +++++++-- hbs2-peer/app/PeerTypes.hs | 1 + hbs2-peer/hbs2-peer.cabal | 1 + 14 files changed, 86 insertions(+), 42 deletions(-) create mode 100644 hbs2-core/lib/HBS2/Data/Types/Peer.hs diff --git a/hbs2-core/hbs2-core.cabal b/hbs2-core/hbs2-core.cabal index 62036cb6..b98f106f 100644 --- a/hbs2-core/hbs2-core.cabal +++ b/hbs2-core/hbs2-core.cabal @@ -59,6 +59,7 @@ common shared-properties , TupleSections , TypeApplications , TypeFamilies + , TemplateHaskell @@ -74,6 +75,7 @@ library , HBS2.Data.Detect , HBS2.Data.Types , HBS2.Data.Types.Crypto + , HBS2.Data.Types.Peer , HBS2.Data.Types.Refs , HBS2.Defaults , HBS2.Events diff --git a/hbs2-core/lib/HBS2/Actors/Peer.hs b/hbs2-core/lib/HBS2/Actors/Peer.hs index 1c958aab..a03f3b02 100644 --- a/hbs2-core/lib/HBS2/Actors/Peer.hs +++ b/hbs2-core/lib/HBS2/Actors/Peer.hs @@ -7,6 +7,7 @@ module HBS2.Actors.Peer where import HBS2.Actors import HBS2.Clock +import HBS2.Data.Types.Peer import HBS2.Defaults import HBS2.Events import HBS2.Hash @@ -30,6 +31,7 @@ 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 @@ -155,6 +157,7 @@ data PeerEnv e = , _envReqMsgLimit :: Cache (Peer e, Integer, Encoded e) () , _envReqProtoLimit :: Cache (Peer e, Integer) () , _envAsymmetricKeyPair :: AsymmKeypair (Encryption e) + , _envEncryptionKeys :: TVar (Map (PeerData L4Proto) (CommonSecret (Encryption L4Proto))) } newtype PeerM e m a = PeerM { fromPeerM :: ReaderT (PeerEnv e) m a } diff --git a/hbs2-core/lib/HBS2/Data/Types.hs b/hbs2-core/lib/HBS2/Data/Types.hs index 92206777..bab8c8e4 100644 --- a/hbs2-core/lib/HBS2/Data/Types.hs +++ b/hbs2-core/lib/HBS2/Data/Types.hs @@ -1,13 +1,13 @@ module HBS2.Data.Types - ( module HBS2.Hash - , module HBS2.Data.Types.Refs + ( module X -- , module HBS2.Data.Types.Crypto , AsSyntax(..) ) where -import HBS2.Hash -import HBS2.Data.Types.Refs +import HBS2.Hash as X +import HBS2.Data.Types.Refs as X +import HBS2.Data.Types.Peer as X -- import HBS2.Data.Types.Crypto -- import Data.Config.Suckless diff --git a/hbs2-core/lib/HBS2/Data/Types/Crypto.hs b/hbs2-core/lib/HBS2/Data/Types/Crypto.hs index 6bca1764..f14e406a 100644 --- a/hbs2-core/lib/HBS2/Data/Types/Crypto.hs +++ b/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 diff --git a/hbs2-core/lib/HBS2/Data/Types/Peer.hs b/hbs2-core/lib/HBS2/Data/Types/Peer.hs new file mode 100644 index 00000000..1e12b828 --- /dev/null +++ b/hbs2-core/lib/HBS2/Data/Types/Peer.hs @@ -0,0 +1,30 @@ +{-# Language UndecidableInstances #-} +module HBS2.Data.Types.Peer where + +import Data.ByteString qualified as BS +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 + ( Show (PubKey 'Sign (Encryption e)) + , Show (Nonce ()) + ) + => Show (PeerData e) + +makeLenses 'PeerData + diff --git a/hbs2-core/lib/HBS2/Net/Proto/Definition.hs b/hbs2-core/lib/HBS2/Net/Proto/Definition.hs index 7d6f8451..b2e6d607 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/Definition.hs +++ b/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 @@ -32,15 +33,11 @@ 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,11 +45,6 @@ type instance PrivKey 'Encrypt HBS2Basic = Encrypt.SecretKey -- но возможно, будет работать и так, ведь ключи -- это же всего лишь байтстроки внутри. -instance Serialise Sign.PublicKey -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 @@ -194,13 +186,6 @@ instance MonadIO m => HasNonces () m where n <- liftIO ( Encrypt.newNonce <&> Crypto.encode ) pure $ BS.take 32 n -instance Serialise Sign.Signature - -instance Signatures HBS2Basic where - type Signature HBS2Basic = Sign.Signature - makeSign = Sign.signDetached - verifySign = Sign.signVerifyDetached - instance Asymm HBS2Basic where type AsymmKeypair HBS2Basic = Encrypt.Keypair type AsymmPrivKey HBS2Basic = Encrypt.SecretKey diff --git a/hbs2-core/lib/HBS2/Net/Proto/Event/PeerExpired.hs b/hbs2-core/lib/HBS2/Net/Proto/Event/PeerExpired.hs index 8206f346..5ea4bd93 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/Event/PeerExpired.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/Event/PeerExpired.hs @@ -1,6 +1,7 @@ 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 diff --git a/hbs2-core/lib/HBS2/Net/Proto/Peer.hs b/hbs2-core/lib/HBS2/Net/Proto/Peer.hs index 1328900a..c9b6ac23 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/Peer.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/Peer.hs @@ -23,24 +23,6 @@ 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) - -deriving instance - ( Show (PubKey 'Sign (Encryption e)) - , Show (Nonce ()) - ) - => Show (PeerData e) - -makeLenses 'PeerData - data PeerHandshake e = PeerPing PingNonce | PeerPong PingNonce (Signature (Encryption e)) (PeerData e) diff --git a/hbs2-core/lib/HBS2/Prelude.hs b/hbs2-core/lib/HBS2/Prelude.hs index 9f0e1503..1273cd07 100644 --- a/hbs2-core/lib/HBS2/Prelude.hs +++ b/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 diff --git a/hbs2-peer/app/Bootstrap.hs b/hbs2-peer/app/Bootstrap.hs index 4b0a0ace..a1b17d09 100644 --- a/hbs2-peer/app/Bootstrap.hs +++ 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 diff --git a/hbs2-peer/app/PeerInfo.hs b/hbs2-peer/app/PeerInfo.hs index 0c7d7fae..6fa165c7 100644 --- a/hbs2-peer/app/PeerInfo.hs +++ b/hbs2-peer/app/PeerInfo.hs @@ -4,6 +4,7 @@ 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 diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index fcb46d06..42df97a4 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -11,6 +11,7 @@ import HBS2.Clock import HBS2.Defaults import HBS2.Events import HBS2.Hash +import HBS2.Data.Types import HBS2.Data.Types.Refs (RefLogKey(..)) import HBS2.Merkle import HBS2.Net.Auth.Credentials @@ -576,12 +577,19 @@ 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 >>= \p -> do + pure p + { _proxy_getEncryptionKey = undefined + , _proxy_clearEncryptionKey = undefined + , _proxy_sendResetEncryptionKeys = undefined + , _proxy_sendBeginEncryptionExchange = undefined + } + 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)) diff --git a/hbs2-peer/app/PeerTypes.hs b/hbs2-peer/app/PeerTypes.hs index 2d85344b..3b94fe0a 100644 --- a/hbs2-peer/app/PeerTypes.hs +++ b/hbs2-peer/app/PeerTypes.hs @@ -6,6 +6,7 @@ module PeerTypes where import HBS2.Actors.Peer import HBS2.Clock +import HBS2.Data.Types.Peer import HBS2.Defaults import HBS2.Events import HBS2.Hash diff --git a/hbs2-peer/hbs2-peer.cabal b/hbs2-peer/hbs2-peer.cabal index 73ad9b14..b7f8bec2 100644 --- a/hbs2-peer/hbs2-peer.cabal +++ b/hbs2-peer/hbs2-peer.cabal @@ -107,6 +107,7 @@ common shared-properties , OverloadedStrings , QuasiQuotes , RecordWildCards + , RecursiveDo , ScopedTypeVariables , StandaloneDeriving , TupleSections From c2c1dd84a0c8fb01c9b7d310466f8889f2897d1e Mon Sep 17 00:00:00 2001 From: Sergey Ivanov Date: Tue, 18 Jul 2023 22:11:51 +0400 Subject: [PATCH 21/31] _envEncryptionKeys :: Map -> HashMap --- hbs2-core/lib/HBS2/Actors/Peer.hs | 11 +++++++++-- hbs2-core/lib/HBS2/Data/Types/Peer.hs | 17 ++++++++++++++++- 2 files changed, 25 insertions(+), 3 deletions(-) diff --git a/hbs2-core/lib/HBS2/Actors/Peer.hs b/hbs2-core/lib/HBS2/Actors/Peer.hs index a03f3b02..d548498d 100644 --- a/hbs2-core/lib/HBS2/Actors/Peer.hs +++ b/hbs2-core/lib/HBS2/Actors/Peer.hs @@ -35,7 +35,7 @@ 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 @@ -157,9 +157,16 @@ data PeerEnv e = , _envReqMsgLimit :: Cache (Peer e, Integer, Encoded e) () , _envReqProtoLimit :: Cache (Peer e, Integer) () , _envAsymmetricKeyPair :: AsymmKeypair (Encryption e) - , _envEncryptionKeys :: TVar (Map (PeerData L4Proto) (CommonSecret (Encryption L4Proto))) + , _envEncryptionKeys :: TVar (HashMap (PeerData L4Proto) (CommonSecret (Encryption L4Proto))) } +setEncryptionKey :: + ( Hashable (PubKey 'Sign (Encryption L4Proto)) + , Hashable PeerNonce + ) => PeerEnv L4Proto -> PeerData L4Proto -> Maybe (CommonSecret (Encryption L4Proto)) -> IO () +setEncryptionKey penv pd msecret = + atomically $ modifyTVar' (_envEncryptionKeys penv) $ Lens.at pd .~ msecret + newtype PeerM e m a = PeerM { fromPeerM :: ReaderT (PeerEnv e) m a } deriving newtype ( Functor , Applicative diff --git a/hbs2-core/lib/HBS2/Data/Types/Peer.hs b/hbs2-core/lib/HBS2/Data/Types/Peer.hs index 1e12b828..0c250a00 100644 --- a/hbs2-core/lib/HBS2/Data/Types/Peer.hs +++ b/hbs2-core/lib/HBS2/Data/Types/Peer.hs @@ -1,7 +1,9 @@ {-# 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 @@ -20,9 +22,22 @@ data PeerData e = } 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 (Nonce ()) + , Show PeerNonce ) => Show (PeerData e) From a0334f5deed406dbc19b6d45ad2d791eee2724b9 Mon Sep 17 00:00:00 2001 From: Sergey Ivanov Date: Tue, 18 Jul 2023 23:05:59 +0400 Subject: [PATCH 22/31] Actual handlers for ProxyMessaging --- hbs2-core/lib/HBS2/Actors/Peer.hs | 7 ++++ .../lib/HBS2/Net/Proto/EncryptionHandshake.hs | 12 +++---- hbs2-peer/app/EncryptionKeys.hs | 2 +- hbs2-peer/app/PeerMain.hs | 32 ++++++++++++++----- 4 files changed, 37 insertions(+), 16 deletions(-) diff --git a/hbs2-core/lib/HBS2/Actors/Peer.hs b/hbs2-core/lib/HBS2/Actors/Peer.hs index d548498d..fd61ae4c 100644 --- a/hbs2-core/lib/HBS2/Actors/Peer.hs +++ b/hbs2-core/lib/HBS2/Actors/Peer.hs @@ -167,6 +167,13 @@ setEncryptionKey :: setEncryptionKey penv pd msecret = atomically $ modifyTVar' (_envEncryptionKeys penv) $ Lens.at pd .~ msecret +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 diff --git a/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs b/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs index d5e46075..45edade4 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs @@ -65,16 +65,14 @@ sendBeginEncryptionExchange :: forall e s m . , e ~ L4Proto , s ~ Encryption e ) - => PeerEnv e - -> PeerCredentials s - -> Peer e + => PeerCredentials s -> PubKey 'Encrypt (Encryption e) + -> Peer e -> m () -sendBeginEncryptionExchange penv creds peer pubkey = do - let ourpubkey = pubKeyFromKeypair @s $ view envAsymmetricKeyPair penv +sendBeginEncryptionExchange creds ourpubkey peer = do let sign = makeSign @s (view peerSignSk creds) ((cs . serialise) ourpubkey) - request peer (BeginEncryptionExchange @e sign pubkey) + request peer (BeginEncryptionExchange @e sign ourpubkey) data EncryptionHandshakeAdapter e m s = EncryptionHandshakeAdapter { encHandshake_considerPeerAsymmKey :: Peer e -> Maybe (PeerData e) -> Maybe Encrypt.PublicKey -> m () @@ -115,7 +113,7 @@ encryptionHandshakeProto EncryptionHandshakeAdapter{..} penv = \case creds <- getCredentials @s let ourpubkey = pubKeyFromKeypair @s $ view envAsymmetricKeyPair penv - sendBeginEncryptionExchange @e penv creds peer ourpubkey + sendBeginEncryptionExchange @e creds ourpubkey peer BeginEncryptionExchange theirsign theirpubkey -> do peer <- thatPeer proto diff --git a/hbs2-peer/app/EncryptionKeys.hs b/hbs2-peer/app/EncryptionKeys.hs index 69a702b3..88270923 100644 --- a/hbs2-peer/app/EncryptionKeys.hs +++ b/hbs2-peer/app/EncryptionKeys.hs @@ -74,4 +74,4 @@ encryptionHandshakeWorker pconf penv creds EncryptionHandshakeAdapter{..} = do forM_ peers \peer -> do -- TODO: Только если ещё не знаем ключ ноды - sendBeginEncryptionExchange @e penv creds peer ourpubkey + sendBeginEncryptionExchange @e creds ourpubkey peer diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index 42df97a4..e1d4ef18 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -578,12 +578,26 @@ runPeer opts = U.handle (\e -> myException e pure $ Just tcpEnv (proxy, penv) <- mdo - proxy <- newProxyMessaging mess tcp >>= \p -> do - pure p - { _proxy_getEncryptionKey = undefined - , _proxy_clearEncryptionKey = undefined - , _proxy_sendResetEncryptionKeys = undefined - , _proxy_sendBeginEncryptionExchange = undefined + proxy <- newProxyMessaging mess tcp >>= \peer -> pure peer + { _proxy_getEncryptionKey = \peer -> do + mpeerData <- withPeerM penv $ find (KnownPeerKey peer) id + join <$> forM mpeerData \peerData -> getEncryptionKey penv peerData + + , _proxy_clearEncryptionKey = \peer -> do + mpeerData <- withPeerM penv $ find (KnownPeerKey peer) id + forM_ mpeerData \peerData -> setEncryptionKey penv 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) @@ -661,7 +675,7 @@ runPeer opts = U.handle (\e -> myException e encryptionHshakeAdapter = EncryptionHandshakeAdapter { encHandshake_considerPeerAsymmKey = \peer mpeerData -> \case Nothing -> do - deletePeerAsymmKey brains peer + -- deletePeerAsymmKey brains peer forM_ mpeerData \peerData -> deletePeerAsymmKey' brains (show peerData) Just pk -> do @@ -670,7 +684,9 @@ runPeer opts = U.handle (\e -> myException e (privKeyFromKeypair @s (view envAsymmetricKeyPair penv)) pk case mpeerData of - Nothing -> insertPeerAsymmKey brains peer pk symmk + Nothing -> do + -- insertPeerAsymmKey brains peer pk symmk + pure () Just peerData -> insertPeerAsymmKey' brains (show peerData) pk symmk } From 00bac2047f1d0f6108d51bd53122c2ef1afcca98 Mon Sep 17 00:00:00 2001 From: Sergey Ivanov Date: Tue, 18 Jul 2023 23:14:15 +0400 Subject: [PATCH 23/31] do not pass PeerData to encHandshake_considerPeerAsymmKey --- .../lib/HBS2/Net/Proto/EncryptionHandshake.hs | 10 +++--- hbs2-peer/app/PeerMain.hs | 35 ++++++++++--------- 2 files changed, 24 insertions(+), 21 deletions(-) diff --git a/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs b/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs index 45edade4..3e506d1e 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs @@ -75,7 +75,7 @@ sendBeginEncryptionExchange creds ourpubkey peer = do request peer (BeginEncryptionExchange @e sign ourpubkey) data EncryptionHandshakeAdapter e m s = EncryptionHandshakeAdapter - { encHandshake_considerPeerAsymmKey :: Peer e -> Maybe (PeerData e) -> Maybe Encrypt.PublicKey -> m () + { encHandshake_considerPeerAsymmKey :: Peer e -> Maybe Encrypt.PublicKey -> m () } @@ -109,7 +109,7 @@ encryptionHandshakeProto EncryptionHandshakeAdapter{..} penv = \case trace $ "EHSP ResetEncryptionKeys from" <+> viaShow (peer, mpeerData) -- сначала удалим у себя его прошлый ключ - encHandshake_considerPeerAsymmKey peer mpeerData Nothing + encHandshake_considerPeerAsymmKey peer Nothing creds <- getCredentials @s let ourpubkey = pubKeyFromKeypair @s $ view envAsymmetricKeyPair penv @@ -131,14 +131,14 @@ encryptionHandshakeProto EncryptionHandshakeAdapter{..} penv = \case let sign = makeSign @s (view peerSignSk creds) ((cs . serialise) ourpubkey) -- сначала удалим у себя его прошлый ключ - encHandshake_considerPeerAsymmKey peer mpeerData Nothing + encHandshake_considerPeerAsymmKey peer Nothing -- отправить обратно свой публичный ключ -- отправится пока ещё в плоском виде response (AckEncryptionExchange @e sign ourpubkey) -- Только после этого прописываем его ключ у себя - encHandshake_considerPeerAsymmKey peer mpeerData (Just theirpubkey) + encHandshake_considerPeerAsymmKey peer (Just theirpubkey) AckEncryptionExchange theirsign theirpubkey -> do peer <- thatPeer proto @@ -149,7 +149,7 @@ encryptionHandshakeProto EncryptionHandshakeAdapter{..} penv = \case -- Он уже прописал у себя наш публичный ключ и готов общаться шифрованными сообщениями -- Прописываем его ключ у себя - encHandshake_considerPeerAsymmKey peer mpeerData (Just theirpubkey) + encHandshake_considerPeerAsymmKey peer (Just theirpubkey) where proto = Proxy @(EncryptionHandshake e) diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index e1d4ef18..dd45feb0 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -673,22 +673,25 @@ runPeer opts = U.handle (\e -> myException e , EventEmitter e (PeerAsymmInfo e) m ) => EncryptionHandshakeAdapter L4Proto m s encryptionHshakeAdapter = EncryptionHandshakeAdapter - { encHandshake_considerPeerAsymmKey = \peer mpeerData -> \case - Nothing -> do - -- 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 - pure () - Just peerData -> - insertPeerAsymmKey' brains (show peerData) pk symmk + { encHandshake_considerPeerAsymmKey = \peer mpubkey -> withPeerM penv do + mpeerData <- withPeerM penv $ find (KnownPeerKey peer) id + case mpubkey of + Nothing -> do + -- 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 + pure () + Just peerData -> + insertPeerAsymmKey' brains (show peerData) pk symmk + } env <- ask From 21e5f4ac5922d0e66386b289d65b9a3a4e4ae210 Mon Sep 17 00:00:00 2001 From: Sergey Ivanov Date: Tue, 18 Jul 2023 23:49:47 +0400 Subject: [PATCH 24/31] Implemented encryption key clearing on PeerExpiredEventKey --- hbs2-core/lib/HBS2/Net/Proto/Event/PeerExpired.hs | 2 +- hbs2-peer/app/PeerInfo.hs | 2 +- hbs2-peer/app/PeerMain.hs | 8 ++++++++ 3 files changed, 10 insertions(+), 2 deletions(-) diff --git a/hbs2-core/lib/HBS2/Net/Proto/Event/PeerExpired.hs b/hbs2-core/lib/HBS2/Net/Proto/Event/PeerExpired.hs index 5ea4bd93..347e9877 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/Event/PeerExpired.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/Event/PeerExpired.hs @@ -14,7 +14,7 @@ data instance EventKey e PeerExpires = deriving stock (Typeable, Eq, Generic) data instance Event e PeerExpires = - PeerExpiredEvent (Peer e) (Maybe (PeerData e)) + PeerExpiredEvent (Peer e) -- (Maybe (PeerData e)) deriving stock (Typeable) instance EventType (Event e PeerExpires) where diff --git a/hbs2-peer/app/PeerInfo.hs b/hbs2-peer/app/PeerInfo.hs index 6fa165c7..58598c3a 100644 --- a/hbs2-peer/app/PeerInfo.hs +++ b/hbs2-peer/app/PeerInfo.hs @@ -224,7 +224,7 @@ peerPingLoop cfg penv = do delPeers pl [p] expire (PeerInfoKey p) expire (KnownPeerKey p) - emit PeerExpiredEventKey (PeerExpiredEvent @e p mpeerData) + emit PeerExpiredEventKey (PeerExpiredEvent @e p {-mpeerData-}) liftIO $ mapM_ link [watch, infoLoop] diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index dd45feb0..071cb412 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -23,6 +23,7 @@ import HBS2.Net.PeerLocator 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 @@ -702,6 +703,13 @@ 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 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 From 6d60fa34259ea5f716a87d76adabaed037e5f72c Mon Sep 17 00:00:00 2001 From: Sergey Ivanov Date: Tue, 18 Jul 2023 23:57:40 +0400 Subject: [PATCH 25/31] only send sendBeginEncryptionExchange when key is absent --- hbs2-peer/app/EncryptionKeys.hs | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/hbs2-peer/app/EncryptionKeys.hs b/hbs2-peer/app/EncryptionKeys.hs index 88270923..2a963e40 100644 --- a/hbs2-peer/app/EncryptionKeys.hs +++ b/hbs2-peer/app/EncryptionKeys.hs @@ -73,5 +73,10 @@ encryptionHandshakeWorker pconf penv creds EncryptionHandshakeAdapter{..} = do peers <- knownPeers @e pl forM_ peers \peer -> do - -- TODO: Только если ещё не знаем ключ ноды - sendBeginEncryptionExchange @e creds ourpubkey peer + -- Только если ещё не знаем ключ ноды + 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 From 3abf7cbe1b58633f9e4d5a6f6d9e1da95522a593 Mon Sep 17 00:00:00 2001 From: Sergey Ivanov Date: Wed, 19 Jul 2023 00:05:04 +0400 Subject: [PATCH 26/31] Enable encryption --- hbs2-peer/app/ProxyMessaging.hs | 20 +++++++++++--------- 1 file changed, 11 insertions(+), 9 deletions(-) diff --git a/hbs2-peer/app/ProxyMessaging.hs b/hbs2-peer/app/ProxyMessaging.hs index 626d9c22..0c2be25c 100644 --- a/hbs2-peer/app/ProxyMessaging.hs +++ b/hbs2-peer/app/ProxyMessaging.hs @@ -104,16 +104,18 @@ runProxyMessaging env = liftIO do instance Messaging ProxyMessaging L4Proto LBS.ByteString where - sendTo = sendToPlainProxyMessaging + sendTo = sendToProxyMessaging - 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) + 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 From d8b1937b7899a3459b88da254db7a1637fc77e04 Mon Sep 17 00:00:00 2001 From: Sergey Ivanov Date: Wed, 19 Jul 2023 00:15:12 +0400 Subject: [PATCH 27/31] Fix newPeerEnv: add _envEncryptionKeys --- hbs2-core/lib/HBS2/Actors/Peer.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/hbs2-core/lib/HBS2/Actors/Peer.hs b/hbs2-core/lib/HBS2/Actors/Peer.hs index fd61ae4c..2253e34c 100644 --- a/hbs2-core/lib/HBS2/Actors/Peer.hs +++ b/hbs2-core/lib/HBS2/Actors/Peer.hs @@ -157,7 +157,7 @@ data PeerEnv e = , _envReqMsgLimit :: Cache (Peer e, Integer, Encoded e) () , _envReqProtoLimit :: Cache (Peer e, Integer) () , _envAsymmetricKeyPair :: AsymmKeypair (Encryption e) - , _envEncryptionKeys :: TVar (HashMap (PeerData L4Proto) (CommonSecret (Encryption L4Proto))) + , _envEncryptionKeys :: TVar (HashMap (PeerData e) (CommonSecret (Encryption e))) } setEncryptionKey :: @@ -415,6 +415,8 @@ newPeerEnv :: forall e m . ( MonadIO m , Pretty (Peer e) , HasNonces () m , Asymm (Encryption e) + , Hashable (PubKey 'Sign (Encryption e)) + , Hashable PeerNonce ) => AnyStorage -> Fabriq e @@ -435,6 +437,7 @@ newPeerEnv s bus p = do _envReqMsgLimit <- liftIO (Cache.newCache (Just defRequestLimit)) _envReqProtoLimit <- liftIO (Cache.newCache (Just defRequestLimit)) _envAsymmetricKeyPair <- asymmNewKeypair @(Encryption e) + _envEncryptionKeys <- liftIO (newTVarIO mempty) pure PeerEnv {..} runPeerM :: forall e m . ( MonadIO m From 3316bb3d44040c1941ac4496415fa3f066c8dbfb Mon Sep 17 00:00:00 2001 From: Sergey Ivanov Date: Wed, 19 Jul 2023 00:20:43 +0400 Subject: [PATCH 28/31] traces encryption events --- hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs | 6 +++--- hbs2-peer/app/PeerMain.hs | 12 +++++++++++- 2 files changed, 14 insertions(+), 4 deletions(-) diff --git a/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs b/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs index 3e506d1e..0b974e76 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs @@ -106,7 +106,7 @@ encryptionHandshakeProto EncryptionHandshakeAdapter{..} penv = \case peer <- thatPeer proto mpeerData <- find (KnownPeerKey peer) id -- TODO: check theirsign - trace $ "EHSP ResetEncryptionKeys from" <+> viaShow (peer, mpeerData) + trace $ "ENCRYPTION EHSP ResetEncryptionKeys from" <+> viaShow (peer, mpeerData) -- сначала удалим у себя его прошлый ключ encHandshake_considerPeerAsymmKey peer Nothing @@ -120,7 +120,7 @@ encryptionHandshakeProto EncryptionHandshakeAdapter{..} penv = \case mpeerData <- find (KnownPeerKey peer) id -- TODO: check theirsign - trace $ "EHSP BeginEncryptionExchange from" <+> viaShow (peer, mpeerData) + trace $ "ENCRYPTION EHSP BeginEncryptionExchange from" <+> viaShow (peer, mpeerData) -- взять свои ключи creds <- getCredentials @s @@ -145,7 +145,7 @@ encryptionHandshakeProto EncryptionHandshakeAdapter{..} penv = \case mpeerData <- find (KnownPeerKey peer) id -- TODO: check theirsign - trace $ "EHSP AckEncryptionExchange from" <+> viaShow (peer, mpeerData) + trace $ "ENCRYPTION EHSP AckEncryptionExchange from" <+> viaShow (peer, mpeerData) -- Он уже прописал у себя наш публичный ключ и готов общаться шифрованными сообщениями -- Прописываем его ключ у себя diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index 071cb412..42a997e1 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -582,7 +582,15 @@ runPeer opts = U.handle (\e -> myException e proxy <- newProxyMessaging mess tcp >>= \peer -> pure peer { _proxy_getEncryptionKey = \peer -> do mpeerData <- withPeerM penv $ find (KnownPeerKey peer) id - join <$> forM mpeerData \peerData -> getEncryptionKey penv peerData + 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 @@ -678,6 +686,7 @@ runPeer opts = U.handle (\e -> myException e 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) @@ -686,6 +695,7 @@ runPeer opts = U.handle (\e -> myException e let symmk = genCommonSecret @s (privKeyFromKeypair @s (view envAsymmetricKeyPair penv)) pk + trace $ "ENCRYPTION store key" <+> pretty peer <+> viaShow mpeerData case mpeerData of Nothing -> do -- insertPeerAsymmKey brains peer pk symmk From 15b943840652ac0da39b2cc296f6bb4845bf70fc Mon Sep 17 00:00:00 2001 From: Sergey Ivanov Date: Wed, 19 Jul 2023 00:42:37 +0400 Subject: [PATCH 29/31] pass peer to setEncryptionKey --- hbs2-core/lib/HBS2/Actors/Peer.hs | 10 ++++++++-- hbs2-peer/app/PeerMain.hs | 10 +++++----- 2 files changed, 13 insertions(+), 7 deletions(-) diff --git a/hbs2-core/lib/HBS2/Actors/Peer.hs b/hbs2-core/lib/HBS2/Actors/Peer.hs index 2253e34c..3b7bf16c 100644 --- a/hbs2-core/lib/HBS2/Actors/Peer.hs +++ b/hbs2-core/lib/HBS2/Actors/Peer.hs @@ -163,9 +163,15 @@ data PeerEnv e = setEncryptionKey :: ( Hashable (PubKey 'Sign (Encryption L4Proto)) , Hashable PeerNonce - ) => PeerEnv L4Proto -> PeerData L4Proto -> Maybe (CommonSecret (Encryption L4Proto)) -> IO () -setEncryptionKey penv pd msecret = + , 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)) diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index 42a997e1..c8a38aaf 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -594,7 +594,7 @@ runPeer opts = U.handle (\e -> myException e , _proxy_clearEncryptionKey = \peer -> do mpeerData <- withPeerM penv $ find (KnownPeerKey peer) id - forM_ mpeerData \peerData -> setEncryptionKey penv peerData Nothing + forM_ mpeerData \peerData -> setEncryptionKey penv peer peerData Nothing -- deletePeerAsymmKey brains peer forM_ mpeerData \peerData -> deletePeerAsymmKey' brains (show peerData) @@ -686,7 +686,7 @@ runPeer opts = U.handle (\e -> myException e mpeerData <- withPeerM penv $ find (KnownPeerKey peer) id case mpubkey of Nothing -> do - trace $ "ENCRYPTION delete key" <+> pretty peer <+> viaShow mpeerData + -- trace $ "ENCRYPTION delete key" <+> pretty peer <+> viaShow mpeerData -- deletePeerAsymmKey brains peer forM_ mpeerData \peerData -> deletePeerAsymmKey' brains (show peerData) @@ -695,11 +695,11 @@ runPeer opts = U.handle (\e -> myException e let symmk = genCommonSecret @s (privKeyFromKeypair @s (view envAsymmetricKeyPair penv)) pk - trace $ "ENCRYPTION store key" <+> pretty peer <+> viaShow mpeerData case mpeerData of Nothing -> do -- insertPeerAsymmKey brains peer pk symmk - pure () + trace $ "ENCRYPTION can not store key. No peerData" + <+> pretty peer <+> viaShow mpeerData Just peerData -> insertPeerAsymmKey' brains (show peerData) pk symmk @@ -715,7 +715,7 @@ runPeer opts = U.handle (\e -> myException e subscribe @e PeerExpiredEventKey \(PeerExpiredEvent peer {-mpeerData-}) -> liftIO do mpeerData <- withPeerM penv $ find (KnownPeerKey peer) id - forM_ mpeerData \peerData -> setEncryptionKey penv peerData Nothing + forM_ mpeerData \peerData -> setEncryptionKey penv peer peerData Nothing -- deletePeerAsymmKey brains peer forM_ mpeerData \peerData -> deletePeerAsymmKey' brains (show peerData) From 56537f0b68340ca0380edf4efdf7863ffaa63df0 Mon Sep 17 00:00:00 2001 From: Sergey Ivanov Date: Wed, 19 Jul 2023 01:23:29 +0400 Subject: [PATCH 30/31] call setEncryptionKey .. (Just symmk) in considerPeerAsymmKey --- hbs2-peer/app/PeerMain.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index c8a38aaf..f627d415 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -698,9 +698,11 @@ runPeer opts = U.handle (\e -> myException e 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 -> + Just peerData -> do + liftIO $ setEncryptionKey penv peer peerData (Just symmk) insertPeerAsymmKey' brains (show peerData) pk symmk } From 03ccf9b088806d3e7ec1f74709d189e8d6b00545 Mon Sep 17 00:00:00 2001 From: Sergey Ivanov Date: Wed, 19 Jul 2023 05:39:28 +0400 Subject: [PATCH 31/31] Drop unused imports in EncryptionHandshake --- hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs | 8 -------- 1 file changed, 8 deletions(-) diff --git a/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs b/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs index 0b974e76..c9faecaf 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs @@ -4,10 +4,8 @@ module HBS2.Net.Proto.EncryptionHandshake where import HBS2.Actors.Peer -import HBS2.Base58 import HBS2.Clock import HBS2.Data.Types -import HBS2.Events import HBS2.Net.Auth.Credentials import HBS2.Net.Proto import HBS2.Net.Proto.Peer @@ -15,16 +13,10 @@ import HBS2.Net.Proto.Sessions import HBS2.Prelude.Plated import HBS2.System.Logger.Simple -import Codec.Serialise() -import Control.Monad -import Crypto.Saltine.Class qualified as Crypto import Crypto.Saltine.Core.Box qualified as Encrypt import Data.ByteString qualified as BS -import Data.Hashable -import Data.Maybe import Data.String.Conversions (cs) import Lens.Micro.Platform -import Type.Reflection (someTypeRep) instance ( Show (PubKey 'Encrypt (Encryption e))