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 8e2794a1..5039caf1 100644 --- a/docs/devlog.md +++ b/docs/devlog.md @@ -1299,3 +1299,11 @@ PR: implement-http-block-download-worker PR: tcp-pex branch: iv/tcp-pex_3 commit: f1de7c58d5dc36dec5c318a3297733791de9a3d8 + +## 2023-06-15 + +PR: bus-crypt + branch: iv/bus-crypt + Шифрование протокола общения нод. + Обмен асимметричными публичными ключами выполняется на стадии хэндшейка в ping/pong. + Для шифрования данных создаётся симметричный ключ по diffie-hellman. diff --git a/hbs2-core/hbs2-core.cabal b/hbs2-core/hbs2-core.cabal index afa2cd07..974c200d 100644 --- a/hbs2-core/hbs2-core.cabal +++ b/hbs2-core/hbs2-core.cabal @@ -53,11 +53,13 @@ common shared-properties , MultiParamTypeClasses , OverloadedStrings , QuasiQuotes + , RecordWildCards , ScopedTypeVariables , StandaloneDeriving , TupleSections , TypeApplications , TypeFamilies + , TemplateHaskell @@ -70,9 +72,11 @@ library , HBS2.Actors.Peer.Types , HBS2.Base58 , HBS2.Clock + , HBS2.Crypto , HBS2.Data.Detect , HBS2.Data.Types , HBS2.Data.Types.Crypto + , HBS2.Data.Types.Peer , HBS2.Data.Types.Refs , HBS2.Defaults , HBS2.Events @@ -92,6 +96,8 @@ library , HBS2.Net.Proto.BlockChunks , HBS2.Net.Proto.BlockInfo , HBS2.Net.Proto.Definition + , HBS2.Net.Proto.EncryptionHandshake + , HBS2.Net.Proto.Event.PeerExpired , HBS2.Net.Proto.Peer , HBS2.Net.Proto.PeerAnnounce , HBS2.Net.Proto.PeerExchange @@ -151,9 +157,11 @@ library , stm , stm-chans , streaming + , string-conversions , suckless-conf , temporary , text + , time , transformers , uniplate , unordered-containers @@ -190,17 +198,21 @@ test-suite test , mtl , prettyprinter , QuickCheck + , quickcheck-instances , random , safe , serialise , stm , streaming , tasty + , tasty-quickcheck , tasty-hunit , transformers , uniplate , vector + , saltine , simple-logger + , string-conversions diff --git a/hbs2-core/lib/HBS2/Actors/Peer.hs b/hbs2-core/lib/HBS2/Actors/Peer.hs index 0b778724..14f66116 100644 --- a/hbs2-core/lib/HBS2/Actors/Peer.hs +++ b/hbs2-core/lib/HBS2/Actors/Peer.hs @@ -11,9 +11,11 @@ module HBS2.Actors.Peer import HBS2.Actors import HBS2.Actors.Peer.Types import HBS2.Clock +import HBS2.Data.Types.Peer import HBS2.Defaults import HBS2.Events import HBS2.Hash +import HBS2.Net.Auth.Credentials import HBS2.Net.Messaging import HBS2.Net.PeerLocator import HBS2.Net.PeerLocator.Static @@ -21,7 +23,9 @@ import HBS2.Net.Proto import HBS2.Net.Proto.Sessions import HBS2.Prelude.Plated import HBS2.Storage +import HBS2.System.Logger.Simple +import Control.Applicative import Control.Monad.Trans.Maybe import Control.Concurrent.Async import Control.Monad.Reader @@ -30,18 +34,24 @@ import Data.Cache (Cache) import Data.Cache qualified as Cache import Data.Dynamic import Data.Foldable hiding (find) +import Data.Map (Map) import Data.Map qualified as Map import Data.Maybe import GHC.TypeLits -import Lens.Micro.Platform +import Lens.Micro.Platform as Lens import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict qualified as HashMap import Control.Concurrent.STM.TVar import Control.Concurrent.STM -import UnliftIO (MonadUnliftIO) +import Data.Hashable (hash) +import UnliftIO (MonadUnliftIO(..)) +import Crypto.Saltine.Core.SecretBox qualified as SBox -- Симметричное шифрование с nonce без подписи +import Crypto.Saltine.Core.Box qualified as Encrypt -- Асимметричное шифрование без подписи import Codec.Serialise (serialise, deserialiseOrFail) +import Prettyprinter hiding (pipe) +-- import Debug.Trace data AnyMessage enc e = AnyMessage !Integer !(Encoded e) @@ -132,8 +142,30 @@ data PeerEnv e = , _envSweepers :: TVar (HashMap SKey [PeerM e IO ()]) , _envReqMsgLimit :: Cache (Peer e, Integer, Encoded e) () , _envReqProtoLimit :: Cache (Peer e, Integer) () + , _envAsymmetricKeyPair :: AsymmKeypair (Encryption e) + , _envEncryptionKeys :: TVar (HashMap (PeerData e) (CommonSecret (Encryption e))) } +setEncryptionKey :: + ( Hashable (PubKey 'Sign (Encryption L4Proto)) + , Hashable PeerNonce + , Show (PubKey 'Sign (Encryption L4Proto)) + , Show PeerNonce + , Show (CommonSecret (Encryption L4Proto)) + ) => PeerEnv L4Proto -> Peer L4Proto -> PeerData L4Proto -> Maybe (CommonSecret (Encryption L4Proto)) -> IO () +setEncryptionKey penv peer pd msecret = do + atomically $ modifyTVar' (_envEncryptionKeys penv) $ Lens.at pd .~ msecret + case msecret of + Nothing -> trace $ "ENCRYPTION delete key" <+> pretty peer <+> viaShow pd + Just k -> trace $ "ENCRYPTION store key" <+> pretty peer <+> viaShow pd <+> viaShow k + +getEncryptionKey :: + ( Hashable (PubKey 'Sign (Encryption L4Proto)) + , Hashable PeerNonce + ) => PeerEnv L4Proto -> PeerData L4Proto -> IO (Maybe (CommonSecret (Encryption L4Proto))) +getEncryptionKey penv pd = + readTVarIO (_envEncryptionKeys penv) <&> preview (Lens.ix pd) + newtype PeerM e m a = PeerM { fromPeerM :: ReaderT (PeerEnv e) m a } deriving newtype ( Functor , Applicative @@ -264,14 +296,16 @@ instance (MonadIO m, HasProtocol e p, Hashable (Encoded e)) pure (not here) instance ( MonadIO m - , HasProtocol e p + , HasProtocol e msg , HasFabriq e m -- (PeerM e m) , HasOwnPeer e m , PeerMessaging e - , HasTimeLimits e p m - ) => 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 @@ -280,12 +314,17 @@ instance ( MonadIO m -- -- TODO: where to store the timeout? -- TODO: where the timeout come from? - -- withTimeLimit @e @p p msg $ do + -- withTimeLimit @e @msg peer_e msg $ do -- liftIO $ print "request!" - allowed <- tryLockForPeriod p msg + allowed <- tryLockForPeriod peer_e msg + + when (not allowed) do + trace $ "REQUEST: not allowed to send" <+> viaShow msg when allowed do - sendTo pipe (To p) (From me) (AnyMessage @(Encoded e) @e proto (encode msg)) + sendTo pipe (To peer_e) (From me) (AnyMessage @(Encoded e) @e proto (encode msg)) + -- trace $ "REQUEST: after sendTo" <+> viaShow peer_e <+> viaShow msg + instance ( Typeable (EventHandler e p (PeerM e IO)) @@ -369,6 +408,9 @@ newPeerEnv :: forall e m . ( MonadIO m , Ord (Peer e) , Pretty (Peer e) , HasNonces () m + , Asymm (Encryption e) + , Hashable (PubKey 'Sign (Encryption e)) + , Hashable PeerNonce ) => AnyStorage -> Fabriq e @@ -376,18 +418,21 @@ newPeerEnv :: forall e m . ( MonadIO m -> m (PeerEnv e) newPeerEnv s bus p = do - - 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) + _envEncryptionKeys <- liftIO (newTVarIO mempty) + pure PeerEnv {..} runPeerM :: forall e m . ( MonadIO m , HasPeer e diff --git a/hbs2-core/lib/HBS2/Base58.hs b/hbs2-core/lib/HBS2/Base58.hs index b9ea7c8e..5ba1e000 100644 --- a/hbs2-core/lib/HBS2/Base58.hs +++ b/hbs2-core/lib/HBS2/Base58.hs @@ -29,3 +29,6 @@ instance Pretty (AsBase58 ByteString) where instance Pretty (AsBase58 LBS.ByteString) where pretty (AsBase58 bs) = pretty $ BS8.unpack $ toBase58 (LBS.toStrict bs) +instance Show (AsBase58 ByteString) where + show (AsBase58 bs) = BS8.unpack $ toBase58 bs + diff --git a/hbs2-core/lib/HBS2/Clock.hs b/hbs2-core/lib/HBS2/Clock.hs index a00c11af..9ab209d9 100644 --- a/hbs2-core/lib/HBS2/Clock.hs +++ b/hbs2-core/lib/HBS2/Clock.hs @@ -9,6 +9,7 @@ import Control.Monad.IO.Class import Data.Fixed import Data.Int (Int64) import Data.Proxy +import Data.Time import Prettyprinter import System.Clock import Data.Time.Clock @@ -34,6 +35,9 @@ class IsTimeout a where toTimeSpec :: Timeout a -> TimeSpec toTimeSpec x = fromNanoSecs (fromIntegral (toNanoSeconds x)) +toNominalDiffTime :: IsTimeout t => Timeout t -> NominalDiffTime +toNominalDiffTime = fromRational . (/ (10^6)) . fromIntegral . toMicroSeconds + class IsTimeout a => MonadPause a m where pause :: Timeout a -> m () 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/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..0c250a00 --- /dev/null +++ b/hbs2-core/lib/HBS2/Data/Types/Peer.hs @@ -0,0 +1,45 @@ +{-# Language UndecidableInstances #-} +module HBS2.Data.Types.Peer where + +import Codec.Serialise +import Data.ByteString qualified as BS +import Data.Hashable +import Lens.Micro.Platform + +import HBS2.Prelude +import HBS2.Data.Types.Crypto +import HBS2.Net.Auth.Credentials +import HBS2.Net.Proto.Types + + +type PingSign e = Signature (Encryption e) +type PingNonce = BS.ByteString + +data PeerData e = + PeerData + { _peerSignKey :: PubKey 'Sign (Encryption e) + , _peerOwnNonce :: PeerNonce -- TODO: to use this field to detect if it's own peer to avoid loops + } + deriving stock (Typeable,Generic) + +deriving instance + ( Eq (PubKey 'Sign (Encryption e)) + , Eq PeerNonce + ) + => Eq (PeerData e) + +instance + ( Hashable (PubKey 'Sign (Encryption e)) + , Hashable PeerNonce + ) + => Hashable (PeerData e) where + hashWithSalt s PeerData{..} = hashWithSalt s (_peerOwnNonce) + +deriving instance + ( Show (PubKey 'Sign (Encryption e)) + , Show PeerNonce + ) + => Show (PeerData e) + +makeLenses 'PeerData + 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 bb313ddf..6fedca39 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 @@ -14,6 +15,7 @@ import HBS2.Net.Proto import HBS2.Net.Proto.BlockAnnounce import HBS2.Net.Proto.BlockChunks import HBS2.Net.Proto.BlockInfo +import HBS2.Net.Proto.EncryptionHandshake import HBS2.Net.Proto.Peer import HBS2.Net.Proto.PeerAnnounce import HBS2.Net.Proto.PeerExchange @@ -22,25 +24,21 @@ import HBS2.Net.Proto.RefLog import HBS2.Net.Proto.RefChan import HBS2.Prelude +import Control.Monad import Data.Functor import Data.ByteString.Lazy (ByteString) import Data.ByteString qualified as BS import Codec.Serialise (deserialiseOrFail,serialise) -import Crypto.Saltine.Core.Box qualified as Crypto import Crypto.Saltine.Class qualified as Crypto import Crypto.Saltine.Core.Sign qualified as Sign import Crypto.Saltine.Core.Box qualified as Encrypt +import HBS2.Data.Types.Crypto type instance Encryption L4Proto = HBS2Basic -type instance PubKey 'Sign HBS2Basic = Sign.PublicKey -type instance PrivKey 'Sign HBS2Basic = Sign.SecretKey -type instance PubKey 'Encrypt HBS2Basic = Encrypt.PublicKey -type instance PrivKey 'Encrypt HBS2Basic = Encrypt.SecretKey - -- FIXME: proper-serialise-for-keys -- Возможно, нужно написать ручные инстансы Serialise -- использовать encode/decode для каждого инстанса ниже $(c:end + 4) @@ -48,15 +46,15 @@ type instance PrivKey 'Encrypt HBS2Basic = Encrypt.SecretKey -- но возможно, будет работать и так, ведь ключи -- это же всего лишь байтстроки внутри. -instance Serialise Sign.PublicKey -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 @@ -66,7 +64,7 @@ instance HasProtocol L4Proto (BlockInfo L4Proto) where instance HasProtocol L4Proto (BlockChunks L4Proto) where type instance ProtocolId (BlockChunks L4Proto) = 2 type instance Encoded L4Proto = ByteString - decode = either (const Nothing) Just . deserialiseOrFail + decode = deserialiseCustom encode = serialise instance Expires (SessionKey L4Proto (BlockChunks L4Proto)) where @@ -75,13 +73,13 @@ instance Expires (SessionKey L4Proto (BlockChunks L4Proto)) where instance HasProtocol L4Proto (BlockAnnounce L4Proto) where type instance ProtocolId (BlockAnnounce L4Proto) = 3 type instance Encoded L4Proto = ByteString - decode = either (const Nothing) Just . deserialiseOrFail + decode = deserialiseCustom encode = serialise instance HasProtocol L4Proto (PeerHandshake L4Proto) where type instance ProtocolId (PeerHandshake L4Proto) = 4 type instance Encoded L4Proto = ByteString - decode = either (const Nothing) Just . deserialiseOrFail + decode = deserialiseCustom encode = serialise requestPeriodLim = ReqLimPerProto 0.5 @@ -89,19 +87,19 @@ instance HasProtocol L4Proto (PeerHandshake L4Proto) where instance HasProtocol L4Proto (PeerAnnounce L4Proto) where type instance ProtocolId (PeerAnnounce L4Proto) = 5 type instance Encoded L4Proto = ByteString - decode = either (const Nothing) Just . deserialiseOrFail + decode = deserialiseCustom encode = serialise instance HasProtocol L4Proto (PeerExchange L4Proto) where type instance ProtocolId (PeerExchange L4Proto) = 6 type instance Encoded L4Proto = ByteString - decode = either (const Nothing) Just . deserialiseOrFail + decode = deserialiseCustom encode = serialise instance HasProtocol L4Proto (RefLogUpdate L4Proto) where type instance ProtocolId (RefLogUpdate L4Proto) = 7 type instance Encoded L4Proto = ByteString - decode = either (const Nothing) Just . deserialiseOrFail + decode = deserialiseCustom encode = serialise -- TODO: find-out-optimal-max-safe-frequency @@ -110,13 +108,13 @@ instance HasProtocol L4Proto (RefLogUpdate L4Proto) where instance HasProtocol L4Proto (RefLogRequest L4Proto) where type instance ProtocolId (RefLogRequest L4Proto) = 8 type instance Encoded L4Proto = ByteString - decode = either (const Nothing) Just . deserialiseOrFail + decode = deserialiseCustom encode = serialise instance HasProtocol L4Proto (PeerMetaProto L4Proto) where type instance ProtocolId (PeerMetaProto L4Proto) = 9 type instance Encoded L4Proto = ByteString - decode = either (const Nothing) Just . deserialiseOrFail + decode = deserialiseCustom encode = serialise -- FIXME: real-period @@ -153,6 +151,14 @@ instance HasProtocol L4Proto (RefChanRequest L4Proto) where -- но poll у нас в минутах, и с минимальным периодом 1 минута requestPeriodLim = ReqLimPerMessage 1 +instance HasProtocol L4Proto (EncryptionHandshake L4Proto) where + type instance ProtocolId (EncryptionHandshake L4Proto) = 10 + type instance Encoded L4Proto = ByteString + decode = deserialiseCustom + encode = serialise + + requestPeriodLim = ReqLimPerProto 0.5 + instance Expires (SessionKey L4Proto (BlockInfo L4Proto)) where expiresIn _ = Just defCookieTimeoutSec @@ -171,48 +177,57 @@ instance Expires (SessionKey L4Proto (KnownPeer L4Proto)) where instance Expires (SessionKey L4Proto (PeerHandshake L4Proto)) where expiresIn _ = Just 60 +instance Expires (SessionKey L4Proto (EncryptionHandshake L4Proto)) where + expiresIn _ = Just 60 + instance Expires (EventKey L4Proto (PeerAnnounce L4Proto)) where expiresIn _ = Nothing instance Expires (EventKey L4Proto (PeerMetaProto L4Proto)) where expiresIn _ = Just 600 +-- instance Expires (EventKey L4Proto (EncryptionHandshake L4Proto)) where +-- expiresIn _ = Just 600 + -- instance MonadIO m => HasNonces () m where -- type instance Nonce (PeerHandshake L4Proto) = BS.ByteString -- newNonce = do --- n <- liftIO ( Crypto.newNonce <&> Crypto.encode ) +-- n <- liftIO ( Encrypt.newNonce <&> Crypto.encode ) -- pure $ BS.take 32 n instance MonadIO m => HasNonces (PeerHandshake L4Proto) m where type instance Nonce (PeerHandshake L4Proto) = BS.ByteString newNonce = do - n <- liftIO ( Crypto.newNonce <&> Crypto.encode ) + n <- liftIO ( Encrypt.newNonce <&> Crypto.encode ) pure $ BS.take 32 n instance MonadIO m => HasNonces (PeerExchange L4Proto) m where type instance Nonce (PeerExchange L4Proto) = BS.ByteString newNonce = do - n <- liftIO ( Crypto.newNonce <&> Crypto.encode ) + n <- liftIO ( Encrypt.newNonce <&> Crypto.encode ) pure $ BS.take 32 n instance MonadIO m => HasNonces (RefLogUpdate L4Proto) m where type instance Nonce (RefLogUpdate L4Proto) = BS.ByteString newNonce = do - n <- liftIO ( Crypto.newNonce <&> Crypto.encode ) + n <- liftIO ( Encrypt.newNonce <&> Crypto.encode ) pure $ BS.take 32 n instance MonadIO m => HasNonces () m where type instance Nonce () = BS.ByteString newNonce = do - n <- liftIO ( Crypto.newNonce <&> Crypto.encode ) + n <- liftIO ( Encrypt.newNonce <&> Crypto.encode ) pure $ BS.take 32 n -instance Serialise Sign.Signature - -instance 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 + 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/EncryptionHandshake.hs b/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs new file mode 100644 index 00000000..c9faecaf --- /dev/null +++ b/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs @@ -0,0 +1,190 @@ +{-# Language TemplateHaskell #-} +{-# Language UndecidableInstances #-} + +module HBS2.Net.Proto.EncryptionHandshake where + +import HBS2.Actors.Peer +import HBS2.Clock +import HBS2.Data.Types +import HBS2.Net.Auth.Credentials +import HBS2.Net.Proto +import HBS2.Net.Proto.Peer +import HBS2.Net.Proto.Sessions +import HBS2.Prelude.Plated +import HBS2.System.Logger.Simple + +import Crypto.Saltine.Core.Box qualified as Encrypt +import Data.ByteString qualified as BS +import Data.String.Conversions (cs) +import Lens.Micro.Platform + +instance + ( Show (PubKey 'Encrypt (Encryption e)) + , Show (PubKey 'Sign (Encryption e)) + , Show (Nonce ()) + ) + => Pretty (PeerData e) where + pretty = viaShow + +data EncryptionHandshake e = + BeginEncryptionExchange (Signature (Encryption e)) (PubKey 'Encrypt (Encryption e)) + | AckEncryptionExchange (Signature (Encryption e)) (PubKey 'Encrypt (Encryption e)) + | ResetEncryptionKeys + deriving stock (Generic) + +sendResetEncryptionKeys :: forall e s m . + ( MonadIO m + , Request e (EncryptionHandshake e) m + , e ~ L4Proto + , s ~ Encryption e + ) + => Peer e + -> m () + +sendResetEncryptionKeys peer = do + request peer (ResetEncryptionKeys @e) + +sendBeginEncryptionExchange :: forall e s m . + ( MonadIO m + , Request e (EncryptionHandshake e) m + , Sessions e (EncryptionHandshake e) m + -- , HasCredentials s m + , Asymm s + , Signatures s + , Serialise (PubKey 'Encrypt s) + , Pretty (Peer e) + , HasProtocol e (EncryptionHandshake e) + , e ~ L4Proto + , s ~ Encryption e + ) + => PeerCredentials s + -> PubKey 'Encrypt (Encryption e) + -> Peer e + -> m () + +sendBeginEncryptionExchange creds ourpubkey peer = do + let sign = makeSign @s (view peerSignSk creds) ((cs . serialise) ourpubkey) + request peer (BeginEncryptionExchange @e sign ourpubkey) + +data EncryptionHandshakeAdapter e m s = EncryptionHandshakeAdapter + { encHandshake_considerPeerAsymmKey :: Peer e -> Maybe Encrypt.PublicKey -> m () + } + + +encryptionHandshakeProto :: forall e s m . + ( MonadIO m + , Response e (EncryptionHandshake e) m + , Request e (EncryptionHandshake e) m + , Sessions e (KnownPeer e) m + , HasCredentials s m + , Asymm s + , Signatures s + , Sessions e (EncryptionHandshake e) m + , Serialise (PubKey 'Encrypt (Encryption e)) + , s ~ Encryption e + , e ~ L4Proto + , PubKey Encrypt s ~ Encrypt.PublicKey + , Show (PubKey 'Sign s) + , Show (Nonce ()) + ) + => EncryptionHandshakeAdapter e m s + -> PeerEnv e + -> EncryptionHandshake e + -> m () + +encryptionHandshakeProto EncryptionHandshakeAdapter{..} penv = \case + + ResetEncryptionKeys -> do + peer <- thatPeer proto + mpeerData <- find (KnownPeerKey peer) id + -- TODO: check theirsign + trace $ "ENCRYPTION EHSP ResetEncryptionKeys from" <+> viaShow (peer, mpeerData) + + -- сначала удалим у себя его прошлый ключ + encHandshake_considerPeerAsymmKey peer Nothing + + creds <- getCredentials @s + let ourpubkey = pubKeyFromKeypair @s $ view envAsymmetricKeyPair penv + sendBeginEncryptionExchange @e creds ourpubkey peer + + BeginEncryptionExchange theirsign theirpubkey -> do + peer <- thatPeer proto + mpeerData <- find (KnownPeerKey peer) id + -- TODO: check theirsign + + trace $ "ENCRYPTION EHSP BeginEncryptionExchange from" <+> viaShow (peer, mpeerData) + + -- взять свои ключи + creds <- getCredentials @s + + let ourpubkey = pubKeyFromKeypair @s $ view envAsymmetricKeyPair penv + + -- подписать нонс + let sign = makeSign @s (view peerSignSk creds) ((cs . serialise) ourpubkey) + + -- сначала удалим у себя его прошлый ключ + encHandshake_considerPeerAsymmKey peer Nothing + + -- отправить обратно свой публичный ключ + -- отправится пока ещё в плоском виде + response (AckEncryptionExchange @e sign ourpubkey) + + -- Только после этого прописываем его ключ у себя + encHandshake_considerPeerAsymmKey peer (Just theirpubkey) + + AckEncryptionExchange theirsign theirpubkey -> do + peer <- thatPeer proto + mpeerData <- find (KnownPeerKey peer) id + -- TODO: check theirsign + + trace $ "ENCRYPTION EHSP AckEncryptionExchange from" <+> viaShow (peer, mpeerData) + + -- Он уже прописал у себя наш публичный ключ и готов общаться шифрованными сообщениями + -- Прописываем его ключ у себя + encHandshake_considerPeerAsymmKey peer (Just theirpubkey) + + where + proto = Proxy @(EncryptionHandshake e) + +----- + +data PeerAsymmInfo e = PeerAsymmInfo + +data instance EventKey e (PeerAsymmInfo e) = PeerAsymmInfoKey + deriving stock (Generic) + +deriving stock instance (Eq (Peer e)) => Eq (EventKey e (PeerAsymmInfo e)) +instance (Hashable (Peer e)) => Hashable (EventKey e (PeerAsymmInfo e)) + +data instance Event e (PeerAsymmInfo e) = + PeerAsymmPubKey (Peer e) (AsymmPubKey (Encryption e)) + deriving stock (Typeable) + +instance Expires (EventKey e (PeerAsymmInfo e)) where + expiresIn _ = Nothing + +instance + ( Serialise (PubKey 'Sign (Encryption e)) + , Serialise (PubKey 'Encrypt (Encryption e)) + , Serialise (Signature (Encryption e)) + ) + => Serialise (EncryptionHandshake e) + +deriving instance + ( Show (PubKey 'Encrypt (Encryption e)) + , Show (Signature (Encryption e)) + ) + => Show (EncryptionHandshake e) + +type instance SessionData e (EncryptionHandshake e) = () + +newtype instance SessionKey e (EncryptionHandshake e) = + KnownPeerAsymmInfoKey (Peer e) + deriving stock (Generic, Typeable) + +deriving instance Eq (Peer e) => Eq (SessionKey e (EncryptionHandshake e)) +instance Hashable (Peer e) => Hashable (SessionKey e (EncryptionHandshake e)) + +data instance EventKey e (EncryptionHandshake e) = + AnyKnownPeerEncryptionHandshakeEventKey + deriving stock (Typeable, Eq,Generic) 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..347e9877 --- /dev/null +++ b/hbs2-core/lib/HBS2/Net/Proto/Event/PeerExpired.hs @@ -0,0 +1,35 @@ +module HBS2.Net.Proto.Event.PeerExpired where + +import HBS2.Clock +import HBS2.Data.Types.Peer +import HBS2.Events +import HBS2.Net.Proto +import HBS2.Net.Proto.Peer +import HBS2.Prelude.Plated + +data PeerExpires = PeerExpires + +data instance EventKey e PeerExpires = + PeerExpiredEventKey + deriving stock (Typeable, Eq, Generic) + +data instance Event e PeerExpires = + PeerExpiredEvent (Peer e) -- (Maybe (PeerData e)) + deriving stock (Typeable) + +instance EventType (Event e PeerExpires) where + isPersistent = True + +instance Expires (EventKey e PeerExpires) where + expiresIn _ = Nothing + +instance Hashable (EventKey e PeerExpires) + +--instance ( Serialise (PubKey 'Sign (Encryption e)) +-- , Serialise (PubKey 'Encrypt (Encryption e)) +-- , Serialise (Signature (Encryption e)) +-- , Serialise PeerNonce +-- ) + +-- => Serialise PeerExpires + diff --git a/hbs2-core/lib/HBS2/Net/Proto/Peer.hs b/hbs2-core/lib/HBS2/Net/Proto/Peer.hs index 1de440a6..c9b6ac23 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,33 +11,30 @@ import HBS2.Clock import HBS2.Net.Proto.Sessions import HBS2.Prelude.Plated import HBS2.Net.Auth.Credentials +import HBS2.System.Logger.Simple --- import HBS2.System.Logger.Simple - +import Control.Monad +import Crypto.Saltine.Core.Box qualified as Encrypt import Data.Maybe import Codec.Serialise() import Data.ByteString qualified as BS import Data.Hashable +import Data.String.Conversions (cs) import Lens.Micro.Platform import Type.Reflection (someTypeRep) -type PingSign e = Signature (Encryption e) -type PingNonce = BS.ByteString - -data PeerData e = - PeerData - { _peerSignKey :: PubKey 'Sign (Encryption e) - , _peerOwnNonce :: PeerNonce -- TODO: to use this field to detect if it's own peer to avoid loops - } - deriving stock (Typeable,Generic) - -makeLenses 'PeerData - data PeerHandshake e = PeerPing PingNonce | PeerPong PingNonce (Signature (Encryption e)) (PeerData e) deriving stock (Generic) +deriving instance + ( Show (PubKey 'Encrypt (Encryption e)) + , Show (Signature (Encryption e)) + , Show (PeerData e) + ) + => Show (PeerHandshake e) + newtype KnownPeer e = KnownPeer (PeerData e) deriving stock (Typeable,Generic) @@ -104,14 +102,18 @@ peerHandShakeProto :: forall e s m . ( MonadIO m , EventEmitter e (PeerHandshake e) m , EventEmitter e (ConcretePeer e) m , HasCredentials s m + , Asymm s , Signatures s + , Serialise (PubKey 'Encrypt (Encryption e)) , s ~ Encryption e , e ~ L4Proto ) => PeerHandshakeAdapter e m - -> PeerHandshake e -> m () + -> PeerEnv e + -> PeerHandshake e + -> m () -peerHandShakeProto adapter = +peerHandShakeProto adapter penv = \case PeerPing nonce -> do pip <- thatPeer proto @@ -176,6 +178,8 @@ data instance Event e (ConcretePeer e) = ConcretePeerData (Peer e) (PeerData e) deriving stock (Typeable) +--- + data instance EventKey e (PeerHandshake e) = AnyKnownPeerEventKey deriving stock (Typeable, Eq,Generic) @@ -209,6 +213,7 @@ deriving instance Eq (Peer e) => Eq (SessionKey e (PeerHandshake e)) instance Hashable (Peer e) => Hashable (SessionKey e (PeerHandshake e)) instance ( Serialise (PubKey 'Sign (Encryption e)) + , Serialise (PubKey 'Encrypt (Encryption e)) , Serialise (Signature (Encryption e)) , Serialise PeerNonce ) @@ -216,6 +221,7 @@ instance ( Serialise (PubKey 'Sign (Encryption e)) => Serialise (PeerData e) instance ( Serialise (PubKey 'Sign (Encryption e)) + , Serialise (PubKey 'Encrypt (Encryption e)) , Serialise (Signature (Encryption e)) , Serialise PeerNonce ) 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 c691f356..413c677a 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/Types.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/Types.hs @@ -111,7 +111,8 @@ data ReqLimPeriod = NoLimit | ReqLimPerProto (Timeout 'Seconds) | ReqLimPerMessage (Timeout 'Seconds) -class (KnownNat (ProtocolId p), HasPeer e) => HasProtocol e p | p -> e where +class (KnownNat (ProtocolId p), HasPeer e, Show (Encoded e) + ) => HasProtocol e p | p -> e where type family ProtocolId p = (id :: Nat) | id -> p type family Encoded e :: Type 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-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/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/Brains.hs b/hbs2-peer/app/Brains.hs index 8724a4c8..c4f60307 100644 --- a/hbs2-peer/app/Brains.hs +++ b/hbs2-peer/app/Brains.hs @@ -17,9 +17,11 @@ import HBS2.System.Logger.Simple import PeerConfig -import Control.Concurrent.STM -import Control.Exception +import Crypto.Saltine.Core.Box qualified as Encrypt +import Data.Maybe import Control.Monad +import Control.Exception +import Control.Concurrent.STM import Database.SQLite.Simple import Database.SQLite.Simple.FromField import Data.Cache (Cache) @@ -633,6 +635,56 @@ transactional brains action = do err $ "BRAINS: " <+> viaShow e execute_ conn [qc|ROLLBACK TO SAVEPOINT {sp}|] +--- + +insertPeerAsymmKey :: forall e m . (e ~ L4Proto, MonadIO m) + => BasicBrains e + -> Peer e + -> Encrypt.PublicKey + -> Encrypt.CombinedKey + -> m () + +insertPeerAsymmKey br peer hAsymmKey hSymmKey = do + insertPeerAsymmKey br peer hAsymmKey hSymmKey + insertPeerAsymmKey' br (show $ pretty peer) hAsymmKey hSymmKey + +insertPeerAsymmKey' :: forall e m . (e ~ L4Proto, MonadIO m) + => BasicBrains e + -> String + -> Encrypt.PublicKey + -> Encrypt.CombinedKey + -> m () + +insertPeerAsymmKey' br key hAsymmKey hSymmKey = do + let conn = view brainsDb br + void $ liftIO $ execute conn [qc| + INSERT INTO peer_asymmkey (peer,asymmkey,symmkey) + VALUES (?,?,?) + ON CONFLICT (peer) + DO UPDATE SET + asymmkey = excluded.asymmkey + , symmkey = excluded.symmkey + |] (key, show hAsymmKey, show hSymmKey) + +--- + +deletePeerAsymmKey :: forall e m . (e ~ L4Proto, MonadIO m) + => BasicBrains e -> Peer e -> m () + +deletePeerAsymmKey br peer = + deletePeerAsymmKey' br (show $ pretty peer) + +deletePeerAsymmKey' :: forall e m . (e ~ L4Proto, MonadIO m) + => BasicBrains e -> String -> m () + +deletePeerAsymmKey' br key = + void $ liftIO $ execute (view brainsDb br) [qc| + DELETE FROM peer_asymmkey + WHERE peer = ? + |] (Only key) + +--- + -- FIXME: eventually-close-db newBasicBrains :: forall e m . (Hashable (Peer e), MonadIO m) => PeerConfig @@ -731,6 +783,16 @@ newBasicBrains cfg = liftIO do |] + execute_ conn [qc| + create table if not exists peer_asymmkey + ( peer text not null + , asymmkey text not null + , symmkey text not null + , ts DATE DEFAULT (datetime('now','localtime')) + , primary key (peer) + ) + |] + BasicBrains <$> newTVarIO mempty <*> newTVarIO mempty <*> Cache.newCache (Just (toTimeSpec (30 :: Timeout 'Seconds))) diff --git a/hbs2-peer/app/EncryptionKeys.hs b/hbs2-peer/app/EncryptionKeys.hs new file mode 100644 index 00000000..2a963e40 --- /dev/null +++ b/hbs2-peer/app/EncryptionKeys.hs @@ -0,0 +1,82 @@ +module EncryptionKeys where + +import HBS2.Actors.Peer +import HBS2.Base58 +import HBS2.Clock +import HBS2.Data.Detect +import HBS2.Data.Types.Refs +import HBS2.Events +import HBS2.Hash +import HBS2.Merkle +import HBS2.Net.Auth.Credentials +import HBS2.Net.PeerLocator +import HBS2.Net.Proto +import HBS2.Net.Proto.EncryptionHandshake +import HBS2.Net.Proto.Peer +import HBS2.Net.Proto.Sessions +import HBS2.Prelude.Plated +import HBS2.Storage +import HBS2.System.Logger.Simple + +import PeerConfig +import PeerTypes + +import Codec.Serialise +import Control.Concurrent.Async +import Control.Concurrent.STM +import Control.Monad +import Control.Monad.Reader +import Control.Monad.Trans.Maybe +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as LBS +import Data.Foldable(for_) +import Data.Function(fix) +import Data.Functor +import Data.HashMap.Strict qualified as HashMap +import Data.HashSet (HashSet) +import Data.HashSet qualified as HashSet +import Data.Maybe +import Data.Text qualified as Text + + +encryptionHandshakeWorker :: forall e m s . + ( MonadIO m + , m ~ PeerM e IO + , s ~ Encryption e + , e ~ L4Proto + , HasPeerLocator e m + -- , HasPeer e + -- , HasNonces (EncryptionHandshake e) m + -- , Request e (EncryptionHandshake e) m + -- , Sessions e (EncryptionHandshake e) m + -- , Sessions e (PeerInfo e) m + -- , Sessions e (KnownPeer e) m + -- , Pretty (Peer e) + -- , HasCredentials s m + ) + => PeerConfig + -> PeerEnv e + -> PeerCredentials s + -> EncryptionHandshakeAdapter e m s + -> m () + +encryptionHandshakeWorker pconf penv creds EncryptionHandshakeAdapter{..} = do + + -- e :: PeerEnv e <- ask + let ourpubkey = pubKeyFromKeypair @s $ _envAsymmetricKeyPair penv + + pl <- getPeerLocator @e + + forever do + liftIO $ pause @'Seconds 30 + + peers <- knownPeers @e pl + + forM_ peers \peer -> do + -- Только если ещё не знаем ключ ноды + mpeerData <- find (KnownPeerKey peer) id + mkey <- liftIO do + join <$> forM mpeerData \peerData -> getEncryptionKey penv peerData + case mkey of + Just _ -> pure () + Nothing -> sendBeginEncryptionExchange @e creds ourpubkey peer diff --git a/hbs2-peer/app/HttpWorker.hs b/hbs2-peer/app/HttpWorker.hs index e6dfcf8a..704de207 100644 --- a/hbs2-peer/app/HttpWorker.hs +++ b/hbs2-peer/app/HttpWorker.hs @@ -4,6 +4,7 @@ import HBS2.Prelude import HBS2.Actors.Peer import HBS2.Storage import HBS2.Data.Types.Refs +import HBS2.Merkle (AnnMetaData) import HBS2.Net.Proto.Types import HBS2.Net.Proto.RefLog import HBS2.Events @@ -33,9 +34,9 @@ httpWorker :: forall e s m . ( MyPeer e , s ~ Encryption e , m ~ PeerM e IO , e ~ L4Proto - ) => PeerConfig -> DownloadEnv e -> m () + ) => PeerConfig -> AnnMetaData -> DownloadEnv e -> m () -httpWorker conf e = do +httpWorker conf pmeta e = do sto <- getStorage let port' = cfgValue @PeerHttpPortKey conf <&> fromIntegral @@ -90,7 +91,7 @@ httpWorker conf e = do status status200 get "/metadata" do - raw $ serialise $ mkPeerMeta conf + raw $ serialise $ pmeta put "/" do -- FIXME: optional-header-based-authorization diff --git a/hbs2-peer/app/PeerInfo.hs b/hbs2-peer/app/PeerInfo.hs index 0743060b..58598c3a 100644 --- a/hbs2-peer/app/PeerInfo.hs +++ b/hbs2-peer/app/PeerInfo.hs @@ -4,8 +4,11 @@ module PeerInfo where import HBS2.Actors.Peer import HBS2.Clock +import HBS2.Data.Types import HBS2.Events +import HBS2.Net.Auth.Credentials import HBS2.Net.PeerLocator +import HBS2.Net.Proto.Event.PeerExpired import HBS2.Net.Proto.Peer import HBS2.Net.Proto.PeerExchange import HBS2.Net.Proto.Sessions @@ -145,8 +148,8 @@ peerPingLoop :: forall e m . ( HasPeerLocator e m , m ~ PeerM e IO , e ~ L4Proto ) - => PeerConfig -> m () -peerPingLoop cfg = do + => PeerConfig -> PeerEnv e -> m () +peerPingLoop cfg penv = do e <- ask @@ -217,9 +220,11 @@ peerPingLoop cfg = do let l = realToFrac (toNanoSecs $ now - seen) / 1e9 -- FIXME: time-hardcode when ( l > 300 ) do + mpeerData <- find (KnownPeerKey p) id delPeers pl [p] expire (PeerInfoKey p) expire (KnownPeerKey p) + emit PeerExpiredEventKey (PeerExpiredEvent @e p {-mpeerData-}) liftIO $ mapM_ link [watch, infoLoop] @@ -240,7 +245,6 @@ peerPingLoop cfg = do pips <- knownPeers @e pl <&> (<> sas) <&> List.nub for_ pips $ \p -> do - trace $ "SEND PING TO" <+> pretty p + -- trace $ "SEND PING TO" <+> pretty p sendPing @e p - - + -- trace $ "SENT PING TO" <+> pretty p diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index 4c8b0735..0df51ee2 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -14,13 +14,17 @@ import HBS2.Defaults import HBS2.Events import HBS2.Hash import HBS2.Data.Types.Refs +import HBS2.Data.Types import HBS2.Net.Auth.Credentials import HBS2.Net.IP.Addr +import HBS2.Net.Messaging import HBS2.Net.Messaging.UDP import HBS2.Net.Messaging.TCP import HBS2.Net.PeerLocator -import HBS2.Net.Proto +import HBS2.Net.Proto as Proto import HBS2.Net.Proto.Definition +import HBS2.Net.Proto.EncryptionHandshake +import HBS2.Net.Proto.Event.PeerExpired import HBS2.Net.Proto.Peer import HBS2.Net.Proto.PeerAnnounce import HBS2.Net.Proto.PeerExchange @@ -45,6 +49,7 @@ import PeerInfo import PeerConfig import Bootstrap import CheckMetrics +import EncryptionKeys import RefLog qualified import RefLog (reflogWorker) import HttpWorker @@ -53,7 +58,7 @@ import PeerMeta import CLI.RefChan import RefChan -import Codec.Serialise +import Codec.Serialise as Serialise -- import Control.Concurrent.Async import Control.Concurrent.STM import Control.Exception as Exception @@ -66,7 +71,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 @@ -77,7 +83,7 @@ import Data.Text (Text) import Data.HashSet qualified as HashSet import GHC.Stats import GHC.TypeLits -import Lens.Micro.Platform +import Lens.Micro.Platform as Lens import Network.Socket import Options.Applicative import System.Directory @@ -87,6 +93,7 @@ import System.Mem import System.Metrics import System.Posix.Process import System.Environment +import Text.InterpolatedString.Perl6 (qc) import UnliftIO.Exception qualified as U -- import UnliftIO.STM @@ -228,6 +235,7 @@ runCLI = join . customExecParser (prefs showHelpOnError) $ <> command "reflog" (info pRefLog (progDesc "reflog commands")) <> command "refchan" (info pRefChan (progDesc "refchan commands")) <> command "peers" (info pPeers (progDesc "show known peers")) + <> command "pexinfo" (info pPexInfo (progDesc "show pex")) <> command "log" (info pLog (progDesc "set logging level")) ) @@ -289,6 +297,10 @@ runCLI = join . customExecParser (prefs showHelpOnError) $ rpc <- pRpcCommon pure $ runRpcCommand rpc PEERS + pPexInfo = do + rpc <- pRpcCommon + pure $ runRpcCommand rpc PEXINFO + onOff l = hsubparser ( command "on" (info (pure (l True) ) (progDesc "on") ) ) <|> hsubparser ( command "off" (info (pure (l False) ) (progDesc "off") ) ) @@ -479,16 +491,16 @@ runPeer opts = U.handle (\e -> myException e liftIO $ print $ pretty accptAnn -- FIXME: move-peerBanned-somewhere - let peerBanned p d = do - let 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 @@ -548,11 +560,42 @@ runPeer opts = U.handle (\e -> myException e void $ async $ runMessagingTCP tcpEnv pure $ Just tcpEnv - proxy <- newProxyMessaging mess tcp + (proxy, penv) <- mdo + proxy <- newProxyMessaging mess tcp >>= \peer -> pure peer + { _proxy_getEncryptionKey = \peer -> do + mpeerData <- withPeerM penv $ find (KnownPeerKey peer) id + mkey <- join <$> forM mpeerData \peerData -> getEncryptionKey penv peerData + case mkey of + Nothing -> + trace $ "ENCRYPTION empty getEncryptionKey" + <+> pretty peer <+> viaShow mpeerData + Just k -> + trace $ "ENCRYPTION success getEncryptionKey" + <+> pretty peer <+> viaShow mpeerData <+> viaShow k + pure mkey + + , _proxy_clearEncryptionKey = \peer -> do + mpeerData <- withPeerM penv $ find (KnownPeerKey peer) id + forM_ mpeerData \peerData -> setEncryptionKey penv peer peerData Nothing + -- deletePeerAsymmKey brains peer + forM_ mpeerData \peerData -> + deletePeerAsymmKey' brains (show peerData) + + , _proxy_sendResetEncryptionKeys = \peer -> withPeerM penv do + sendResetEncryptionKeys peer + + , _proxy_sendBeginEncryptionExchange = \peer -> withPeerM penv do + sendBeginEncryptionExchange pc + ((pubKeyFromKeypair @s . view envAsymmetricKeyPair) penv) + peer + + } + penv <- newPeerEnv (AnyStorage s) (Fabriq proxy) (getOwnPeer mess) + pure (proxy, penv) proxyThread <- async $ runProxyMessaging proxy - penv <- newPeerEnv (AnyStorage s) (Fabriq proxy) (getOwnPeer mess) + let peerMeta = mkPeerMeta conf penv nbcache <- liftIO $ Cache.newCache (Just $ toTimeSpec ( 600 :: Timeout 'Seconds)) @@ -581,8 +624,8 @@ runPeer opts = U.handle (\e -> myException e let onNoBlock (p, h) = do already <- liftIO $ Cache.lookup nbcache (p,h) <&> isJust unless already do - pd' <- find (KnownPeerKey p) id - maybe1 pd' none $ \pd -> do + mpde <- find (KnownPeerKey p) id + maybe1 mpde none $ \pd -> do let pk = view peerSignKey pd when (Set.member pk helpFetchKeys) do liftIO $ Cache.insert nbcache (p,h) () @@ -624,6 +667,36 @@ runPeer opts = U.handle (\e -> myException e let hshakeAdapter = PeerHandshakeAdapter addNewRtt + let encryptionHshakeAdapter :: + ( MonadIO m + , EventEmitter e (PeerAsymmInfo e) m + ) => EncryptionHandshakeAdapter L4Proto m s + encryptionHshakeAdapter = EncryptionHandshakeAdapter + { encHandshake_considerPeerAsymmKey = \peer mpubkey -> withPeerM penv do + mpeerData <- withPeerM penv $ find (KnownPeerKey peer) id + case mpubkey of + Nothing -> do + -- trace $ "ENCRYPTION delete key" <+> pretty peer <+> viaShow mpeerData + -- deletePeerAsymmKey brains peer + forM_ mpeerData \peerData -> + deletePeerAsymmKey' brains (show peerData) + Just pk -> do + -- emit PeerAsymmInfoKey (PeerAsymmPubKey peer pk) + let symmk = genCommonSecret @s + (privKeyFromKeypair @s (view envAsymmetricKeyPair penv)) + pk + case mpeerData of + Nothing -> do + -- insertPeerAsymmKey brains peer pk symmk + -- insertPeerAsymmKey' brains (show peer) pk symmk + trace $ "ENCRYPTION can not store key. No peerData" + <+> pretty peer <+> viaShow mpeerData + Just peerData -> do + liftIO $ setEncryptionKey penv peer peerData (Just symmk) + insertPeerAsymmKey' brains (show peerData) pk symmk + + } + env <- ask pnonce <- peerNonce @e @@ -632,29 +705,39 @@ runPeer opts = U.handle (\e -> myException e addPeers @e pl ps + subscribe @e PeerExpiredEventKey \(PeerExpiredEvent peer {-mpeerData-}) -> liftIO do + mpeerData <- withPeerM penv $ find (KnownPeerKey peer) id + forM_ mpeerData \peerData -> setEncryptionKey penv peer peerData Nothing + -- deletePeerAsymmKey brains peer + forM_ mpeerData \peerData -> + deletePeerAsymmKey' brains (show peerData) + subscribe @e PeerAnnounceEventKey $ \(PeerAnnounceEvent pip nonce) -> do unless (nonce == pnonce) $ do debug $ "Got peer announce!" <+> pretty pip - pd <- find (KnownPeerKey pip) id -- <&> isJust - banned <- maybe (pure False) (peerBanned pip) pd - let known = isJust pd && 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 AnyKnownPeerEventKey $ \(KnownPeerEvent p d) -> do + subscribe @e AnyKnownPeerEventKey $ \(KnownPeerEvent p pd) -> do - let thatNonce = view peerOwnNonce d + let thatNonce = view peerOwnNonce pd now <- liftIO getTimeCoarse - pinfo' <- find (PeerInfoKey p) id -- (view peerPingFailed) - maybe1 pinfo' none $ \pinfo -> do - 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 + + find (PeerInfoKey p) id >>= mapM_ \pinfo -> do + liftIO $ atomically $ writeTVar (view peerPingFailed pinfo) 0 + liftIO $ atomically $ writeTVar (view peerLastWatched pinfo) now + + banned <- peerBanned p pd let doAddPeer p = do addPeers pl [p] @@ -666,7 +749,7 @@ runPeer opts = U.handle (\e -> myException e unless here do debug $ "Got authorized peer!" <+> pretty p - <+> pretty (AsBase58 (view peerSignKey d)) + <+> pretty (AsBase58 (view peerSignKey pd)) request @e p (GetPeerMeta @e) @@ -682,18 +765,15 @@ runPeer opts = U.handle (\e -> myException e | otherwise -> do - update d (KnownPeerKey p) id + update pd (KnownPeerKey p) id - pd' <- knownPeers @e pl >>= - \peers -> forM peers $ \pip -> do - pd <- find (KnownPeerKey pip) (view peerOwnNonce) - pure $ (,pip) <$> pd - - let pd = Map.fromList $ catMaybes pd' + pdkv :: Map BS.ByteString (Peer L4Proto) <- fmap (Map.fromList . catMaybes) + $ knownPeers @e pl >>= mapM \pip -> + 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 @@ -758,11 +838,11 @@ runPeer opts = U.handle (\e -> myException e -- peerThread "tcpWorker" (tcpWorker conf) - peerThread "httpWorker" (httpWorker conf denv) + peerThread "httpWorker" (httpWorker conf peerMeta denv) peerThread "checkMetrics" (checkMetrics metrics) - peerThread "peerPingLoop" (peerPingLoop @e conf) + peerThread "peerPingLoop" (peerPingLoop @e conf penv) peerThread "knownPeersPingLoop" (knownPeersPingLoop @e conf) @@ -772,6 +852,9 @@ runPeer opts = U.handle (\e -> myException e peerThread "blockDownloadLoop" (blockDownloadLoop denv) + peerThread "encryptionHandshakeWorker" + (EncryptionKeys.encryptionHandshakeWorker @e conf penv pc encryptionHshakeAdapter) + let tcpProbeWait :: Timeout 'Seconds tcpProbeWait = (fromInteger . fromMaybe 300) (cfgValue @PeerTcpProbeWaitKey conf) @@ -798,11 +881,14 @@ runPeer opts = U.handle (\e -> myException e PING pa r -> do debug $ "ping" <+> pretty pa pip <- fromPeerAddr @e pa - subscribe (ConcretePeerKey pip) $ \(ConcretePeerData{}) -> do + subscribe (ConcretePeerKey pip) $ \(ConcretePeerData _ pde) -> do maybe1 r (pure ()) $ \rpcPeer -> do pinged <- toPeerAddr pip request rpcPeer (RPCPong @e pinged) + -- case (view peerEncPubKey pde) of + -- Nothing -> unencrypted ping + -- Just pubkey -> encryptengd sendPing pip @@ -832,13 +918,13 @@ runPeer opts = U.handle (\e -> myException e unless (nonce == n1) do - peer <- find @e (KnownPeerKey pip) id + mpde <- find @e (KnownPeerKey pip) id debug $ "received announce from" <+> pretty pip <+> pretty h - case peer of + case mpde of Nothing -> do sendPing @e pip -- TODO: enqueue-announce-from-unknown-peer? @@ -886,11 +972,12 @@ runPeer opts = U.handle (\e -> myException e [ makeResponse (blockSizeProto blk dontHandle onNoBlock) , makeResponse (blockChunksProto adapter) , makeResponse blockAnnounceProto - , makeResponse (withCredentials @e pc . peerHandShakeProto hshakeAdapter) + , makeResponse (withCredentials @e pc . peerHandShakeProto hshakeAdapter penv) + , makeResponse (withCredentials @e pc . encryptionHandshakeProto encryptionHshakeAdapter penv) , makeResponse (peerExchangeProto pexFilt) , makeResponse (refLogUpdateProto reflogAdapter) , makeResponse (refLogRequestProto reflogReqAdapter) - , makeResponse (peerMetaProto (mkPeerMeta conf)) + , makeResponse (peerMetaProto peerMeta) , makeResponse (refChanHeadProto False refChanAdapter) , makeResponse (refChanUpdateProto False pc refChanAdapter) , makeResponse (refChanRequestProto False refChanAdapter) @@ -937,11 +1024,19 @@ runPeer opts = U.handle (\e -> myException e let peersAction _ = do who <- thatPeer (Proxy @(RPC e)) void $ liftIO $ async $ withPeerM penv $ do - forKnownPeers @e $ \p pd -> do + forKnownPeers @e $ \p pde -> do pa <- toPeerAddr p - let k = view peerSignKey pd + let k = view peerSignKey pde request who (RPCPeersAnswer @e pa k) + let pexInfoAction :: RPC L4Proto -> ResponseM L4Proto (RpcM (ResourceT IO)) () + pexInfoAction _ = do + who <- thatPeer (Proxy @(RPC e)) + void $ liftIO $ async $ withPeerM penv $ do + -- FIXME: filter-pexinfo-entries + ps <- getAllPex2Peers + request who (RPCPexInfoAnswer @e ps) + let logLevelAction = \case DebugOn True -> do setLogging @DEBUG debugPrefix 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 ad183b37..fe9b08a5 100644 --- a/hbs2-peer/app/PeerTypes.hs +++ b/hbs2-peer/app/PeerTypes.hs @@ -8,9 +8,12 @@ module PeerTypes where import HBS2.Actors.Peer import HBS2.Actors.Peer.Types import HBS2.Clock +import HBS2.Data.Types.Peer import HBS2.Defaults import HBS2.Events import HBS2.Hash +import HBS2.Merkle (AnnMetaData) +import HBS2.Net.Auth.Credentials import HBS2.Net.IP.Addr import HBS2.Net.Proto import HBS2.Net.Proto.Peer @@ -31,12 +34,15 @@ import Data.Foldable (for_) import Control.Concurrent.Async import Control.Concurrent.STM import Control.Monad.Reader +import Control.Monad.Writer qualified as W +import Crypto.Saltine.Core.Box qualified as Encrypt import Data.ByteString.Lazy (ByteString) import Data.Cache (Cache) import Data.Cache qualified as Cache import Data.HashSet (HashSet) import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict qualified as HashMap +import Data.List qualified as L import Data.Maybe import Lens.Micro.Platform import Data.Hashable @@ -47,8 +53,9 @@ import Data.Text qualified as Text import Data.Text.Encoding qualified as TE import Data.Time.Clock (NominalDiffTime) import Data.Heap qualified as Heap -import Data.Heap (Entry(..)) --- import Data.Time.Clock +import Data.Heap (Heap,Entry(..)) +import Data.Time.Clock +import Data.Word data PeerInfo e = PeerInfo @@ -77,23 +84,25 @@ makeLenses 'PeerInfo newPeerInfo :: MonadIO m => m (PeerInfo e) newPeerInfo = liftIO do - PeerInfo <$> newTVarIO defBurst - <*> 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 @@ -376,8 +385,8 @@ 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 @@ -394,18 +403,29 @@ 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 ,) data Polling = diff --git a/hbs2-peer/app/ProxyMessaging.hs b/hbs2-peer/app/ProxyMessaging.hs index e70d093a..0c2be25c 100644 --- a/hbs2-peer/app/ProxyMessaging.hs +++ b/hbs2-peer/app/ProxyMessaging.hs @@ -1,37 +1,64 @@ {-# Language TemplateHaskell #-} module ProxyMessaging - ( ProxyMessaging + ( ProxyMessaging(..) , newProxyMessaging , runProxyMessaging + , sendToPlainProxyMessaging ) where import HBS2.Prelude.Plated import HBS2.Net.Messaging import HBS2.Clock +import HBS2.Crypto +import HBS2.Net.Auth.Credentials +import HBS2.Net.Proto.Definition () +import HBS2.Net.Proto.Peer import HBS2.Net.Proto.Types import HBS2.Net.Messaging.UDP import HBS2.Net.Messaging.TCP import HBS2.System.Logger.Simple +import Crypto.Saltine.Class as SCl +import Crypto.Saltine.Core.Box qualified as Encrypt + +import Codec.Serialise +import Control.Applicative +import Control.Arrow hiding ((<+>)) import Control.Concurrent.Async import Control.Concurrent.STM import Control.Concurrent.STM.TQueue -import Data.ByteString.Lazy (ByteString) +import Control.Monad.Trans.Maybe +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS import Data.ByteString.Lazy qualified as LBS +import Data.Maybe +import Data.String.Conversions (cs) import Data.List qualified as L -import Lens.Micro.Platform +import Data.Map (Map) +import Data.Map qualified as Map +import Lens.Micro.Platform as Lens import Control.Monad -- TODO: protocol-encryption-goes-here -data ProxyMessaging = +data ProxyMessaging = ProxyMessaging { _proxyUDP :: MessagingUDP , _proxyTCP :: Maybe MessagingTCP - , _proxyAnswers :: TQueue (From L4Proto, ByteString) + , _proxyAnswers :: TQueue (From L4Proto, LBS.ByteString) + + , _proxy_getEncryptionKey :: Peer L4Proto -> IO (Maybe (CommonSecret (Encryption L4Proto))) + , _proxy_clearEncryptionKey :: Peer L4Proto -> IO () + , _proxy_sendResetEncryptionKeys :: Peer L4Proto -> IO () + , _proxy_sendBeginEncryptionExchange :: Peer L4Proto -> IO () } +-- 1 нода X создаёт себе Encrypt.Keypair +-- 2 подписывает из него публичный ключ ключом подписи ноды X и отправляет ноде Y +-- 3 нода Y получила Публичный ключ ноды X, создала симметричный Key, +-- зашифровала его для полученного Публичного ключа ноды X и отравила ей + makeLenses 'ProxyMessaging newProxyMessaging :: forall m . MonadIO m @@ -40,8 +67,16 @@ newProxyMessaging :: forall m . MonadIO m -> m ProxyMessaging newProxyMessaging u t = liftIO do - ProxyMessaging u t - <$> newTQueueIO + 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 @@ -66,23 +101,120 @@ runProxyMessaging env = liftIO do liftIO $ mapM_ waitCatch [u,t] -instance Messaging ProxyMessaging L4Proto ByteString where - sendTo bus t@(To whom) f m = do - -- sendTo (view proxyUDP bus) t f m - -- trace $ "PROXY: SEND" <+> pretty whom +instance Messaging ProxyMessaging L4Proto LBS.ByteString where + + sendTo = sendToProxyMessaging + + receive = receiveFromProxyMessaging + + -- receive bus _ = liftIO do + -- -- trace "PROXY: RECEIVE" + -- -- receive (view proxyUDP bus) w + -- let answ = view proxyAnswers bus + -- atomically $ do + -- r <- readTQueue answ + -- rs <- flushTQueue answ + -- pure (r:rs) + +sendToPlainProxyMessaging :: (MonadIO m) + => ProxyMessaging + -> To L4Proto + -> From L4Proto + -> LBS.ByteString + -> m () +sendToPlainProxyMessaging bus t@(To whom) proto msg = do let udp = view proxyUDP bus case view sockType whom of - UDP -> sendTo udp t f m + UDP -> sendTo udp t proto msg TCP -> maybe1 (view proxyTCP bus) none $ \tcp -> do - sendTo tcp t f m + sendTo tcp t proto msg - receive bus _ = liftIO do +sendToProxyMessaging :: (MonadIO m) + => ProxyMessaging + -> To L4Proto + -> From L4Proto + -> LBS.ByteString + -> m () +sendToProxyMessaging bus t@(To whom) proto msg = do + -- sendTo (view proxyUDP bus) t proto msg + -- trace $ "PROXY: SEND" <+> pretty whom + mencKey <- liftIO $ _proxy_getEncryptionKey bus whom + cf <- case mencKey of + Nothing -> do + trace $ "ENCRYPTION SEND: sending plain message to" <+> pretty whom + pure id + Just k -> do + trace $ "ENCRYPTION SEND: sending encrypted message to" <+> pretty whom <+> "with key" <+> viaShow k + boxAfterNMLazy k <$> liftIO Encrypt.newNonce + sendToPlainProxyMessaging bus t proto (cf msg) + +receiveFromProxyMessaging :: MonadIO m + => ProxyMessaging -> To L4Proto -> m [(From L4Proto, LBS.ByteString)] +receiveFromProxyMessaging bus _ = liftIO do -- trace "PROXY: RECEIVE" -- receive (view proxyUDP bus) w let answ = view proxyAnswers bus - atomically $ do - 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 + fmap (w, ) <$> dfm whom msg + -- Здесь: + -- 1. У нас есть ключ сессии и мы не смогли расшифровать -> do + -- удаляем у себя ключ + -- отправляем sendBeginEncryptionExchange + -- 2. У нас (до сих пор, даже если мы давно стартовали) нет ключа сессии -> do + -- sendResetEncryptionKeys + -- просто передаём сообщение как есть + + -- В протоколе пингов: + -- 1. Если слишком долго нет ответа на ping, то удаляем у себя ключ, отправляем sendResetEncryptionKeys + -- Выполняется в PeerInfo: + -- emit PeerExpiredEventKey (PeerExpiredEvent @e p mpeerData) + + where + dfm :: Peer L4Proto -> LBS.ByteString -> IO (Maybe LBS.ByteString) + dfm = \whom msg -> liftIO $ _proxy_getEncryptionKey bus whom >>= \case + + Nothing -> do + trace $ "ENCRYPTION RECEIVE: we do not have a key to decode" <+> pretty whom + liftIO $ _proxy_sendBeginEncryptionExchange bus whom + pure (Just msg) + + Just k -> runMaybeT $ + -- А будем-ка мы просто передавать сообщение дальше как есть, если не смогли расшифровать + (<|> (do + + liftIO $ _proxy_clearEncryptionKey bus whom + + liftIO $ _proxy_sendResetEncryptionKeys bus whom + + trace $ "ENCRYPTION RECEIVE: got plain message. clearing key of" <+> pretty whom + pure msg + )) $ + do + trace $ "ENCRYPTION RECEIVE: we have a key to decode from" <+> pretty whom <+> ":" <+> viaShow k + case ((extractNonce . cs) msg) of + Nothing -> do + trace $ "ENCRYPTION RECEIVE: can not extract nonce from" <+> pretty whom <+> "message" <+> viaShow msg + fail "" + + Just (nonce, msg') -> + ((MaybeT . pure) (boxOpenAfterNMLazy k nonce msg') + <* (trace $ "ENCRYPTION RECEIVE: message successfully decoded from" <+> pretty whom) + ) + <|> + (do + (trace $ "ENCRYPTION RECEIVE: can not decode message from" <+> pretty whom) + fail "" + + -- -- Попытаться десериализовать сообщение как PeerPing или PeerPingCrypted + -- case deserialiseOrFail msg of + -- Right (_ :: PeerHandshake L4Proto) -> do + -- trace $ "ENCRYPTION RECEIVE: plain message decoded as PeerHandshake" <+> pretty whom + -- fail "" + -- Left _ -> do + -- trace $ "ENCRYPTION RECEIVE: failed" <+> pretty whom + -- mzero + + ) diff --git a/hbs2-peer/app/RPC.hs b/hbs2-peer/app/RPC.hs index 85ee9ce2..da101920 100644 --- a/hbs2-peer/app/RPC.hs +++ b/hbs2-peer/app/RPC.hs @@ -57,6 +57,7 @@ data RPCCommand = | CHECK PeerNonce (PeerAddr L4Proto) (Hash HbSync) | FETCH (Hash HbSync) | PEERS + | PEXINFO | SETLOG SetLogging | REFLOGUPDATE ByteString | REFLOGFETCH (PubKey 'Sign (Encryption L4Proto)) @@ -79,6 +80,8 @@ data RPC e = | RPCFetch (Hash HbSync) | RPCPeers | RPCPeersAnswer (PeerAddr e) (PubKey 'Sign (Encryption e)) + | RPCPexInfo + | RPCPexInfoAnswer [PeerAddr L4Proto] | RPCLogLevel SetLogging | RPCRefLogUpdate ByteString | RPCRefLogFetch (PubKey 'Sign (Encryption e)) @@ -98,6 +101,11 @@ data RPC e = deriving stock (Generic) +deriving instance + ( Show (PubKey 'Sign (Encryption e)) + , Show (PeerAddr e) + ) => Show (RPC e) + instance (Serialise (PeerAddr e), Serialise (PubKey 'Sign (Encryption e))) => Serialise (RPC e) instance HasProtocol L4Proto (RPC L4Proto) where @@ -127,6 +135,8 @@ data RpcAdapter e m = , rpcOnFetch :: Hash HbSync -> m () , rpcOnPeers :: RPC e -> m () , rpcOnPeersAnswer :: (PeerAddr e, PubKey 'Sign (Encryption e)) -> m () + , rpcOnPexInfo :: RPC e -> m () + , rpcOnPexInfoAnswer :: [PeerAddr L4Proto] -> m () , rpcOnLogLevel :: SetLogging -> m () , rpcOnRefLogUpdate :: ByteString -> m () , rpcOnRefLogFetch :: PubKey 'Sign (Encryption e) -> m () @@ -194,6 +204,8 @@ rpcHandler adapter = \case (RPCFetch h) -> rpcOnFetch adapter h p@RPCPeers{} -> rpcOnPeers adapter p (RPCPeersAnswer pa k) -> rpcOnPeersAnswer adapter (pa,k) + p@RPCPexInfo{} -> rpcOnPexInfo adapter p + (RPCPexInfoAnswer pa) -> rpcOnPexInfoAnswer adapter pa (RPCLogLevel l) -> rpcOnLogLevel adapter l (RPCRefLogUpdate bs) -> rpcOnRefLogUpdate adapter bs (RPCRefLogFetch e) -> rpcOnRefLogFetch adapter e diff --git a/hbs2-peer/hbs2-peer.cabal b/hbs2-peer/hbs2-peer.cabal index e785a5b0..cccd1203 100644 --- a/hbs2-peer/hbs2-peer.cabal +++ b/hbs2-peer/hbs2-peer.cabal @@ -49,6 +49,7 @@ common common-deps , stm , streaming , sqlite-simple + , time , temporary , text , time @@ -61,6 +62,7 @@ common common-deps , filelock , ekg-core , scotty + , string-conversions , warp , http-conduit , http-types @@ -107,6 +109,8 @@ common shared-properties , MultiParamTypeClasses , OverloadedStrings , QuasiQuotes + , RecordWildCards + , RecursiveDo , ScopedTypeVariables , StandaloneDeriving , TupleSections @@ -123,6 +127,7 @@ executable hbs2-peer other-modules: BlockDownload , BlockHttpDownload , DownloadQ + , EncryptionKeys , Bootstrap , PeerInfo , PeerMeta diff --git a/hbs2/Main.hs b/hbs2/Main.hs index 9b385153..4fc5dbfa 100644 --- a/hbs2/Main.hs +++ b/hbs2/Main.hs @@ -548,6 +548,7 @@ main = join . customExecParser (prefs showHelpOnError) $ <> command "lref-update" (info pUpdateLRef (progDesc "updates a linear ref")) <> command "reflog" (info pReflog (progDesc "reflog commands")) -- <> command "lref-del" (info pDelLRef (progDesc "removes a linear ref from node linear ref list")) + <> command "showpex" (info pReflog (progDesc "reflog commands")) ) common = do