From 01982d37c10050c6b529ccfcf2600928e3ffbc39 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Tue, 4 Jul 2023 15:29:54 +0300 Subject: [PATCH] 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