mirror of https://github.com/voidlizard/hbs2
Extracted EncryptionHandshake from PeerHandshake
This commit is contained in:
Sergey Ivanov
parent
9c408bcb03
commit
75232557f3
|
|
@ -94,6 +94,7 @@ library
|
|||
, HBS2.Net.Proto.BlockChunks
|
||||
, HBS2.Net.Proto.BlockInfo
|
||||
, HBS2.Net.Proto.Definition
|
||||
, HBS2.Net.Proto.EncryptionHandshake
|
||||
, HBS2.Net.Proto.Peer
|
||||
, HBS2.Net.Proto.PeerAnnounce
|
||||
, HBS2.Net.Proto.PeerExchange
|
||||
|
|
|
|||
|
|
@ -0,0 +1,122 @@
|
|||
{-# Language TemplateHaskell #-}
|
||||
{-# Language UndecidableInstances #-}
|
||||
module HBS2.Net.Proto.EncryptionHandshake where
|
||||
|
||||
-- import HBS2.Base58
|
||||
import HBS2.Actors.Peer
|
||||
import HBS2.Data.Types
|
||||
import HBS2.Events
|
||||
import HBS2.Net.Proto
|
||||
import HBS2.Clock
|
||||
import HBS2.Net.Proto.Sessions
|
||||
import HBS2.Prelude.Plated
|
||||
import HBS2.Net.Auth.Credentials
|
||||
import HBS2.System.Logger.Simple
|
||||
|
||||
import Control.Monad
|
||||
import Crypto.Saltine.Core.Box qualified as Encrypt
|
||||
import Data.Maybe
|
||||
import Codec.Serialise()
|
||||
import Data.ByteString qualified as BS
|
||||
import Data.Hashable
|
||||
import Data.String.Conversions (cs)
|
||||
import Lens.Micro.Platform
|
||||
import Type.Reflection (someTypeRep)
|
||||
|
||||
newtype EENonce = EENonce { unEENonce :: BS.ByteString }
|
||||
|
||||
data EncryptionHandshake e =
|
||||
BeginEncryptionExchange EENonce (PubKey 'Encrypt (Encryption e))
|
||||
| AckEncryptionExchange EENonce (Signature (Encryption e)) (PubKey 'Encrypt (Encryption e))
|
||||
deriving stock (Generic)
|
||||
|
||||
sendEncryptionPubKey :: forall e m . ( MonadIO m
|
||||
, Request e (EncryptionHandshake e) m
|
||||
, Sessions e (EncryptionHandshake e) m
|
||||
, HasNonces (EncryptionHandshake e) m
|
||||
, Nonce (EncryptionHandshake e) ~ EENonce
|
||||
, Pretty (Peer e)
|
||||
, HasProtocol e (EncryptionHandshake e)
|
||||
, e ~ L4Proto
|
||||
)
|
||||
=> Peer e -> PubKey 'Encrypt (Encryption e) -> m ()
|
||||
|
||||
sendEncryptionPubKey pip pubkey = do
|
||||
nonce <- newNonce @(EncryptionHandshake e)
|
||||
tt <- liftIO $ getTimeCoarse
|
||||
request pip (BeginEncryptionExchange @e nonce pubkey)
|
||||
|
||||
encryptionHandshakeProto :: forall e s m . ( MonadIO m
|
||||
, Response e (EncryptionHandshake e) m
|
||||
, Request e (EncryptionHandshake e) m
|
||||
, Sessions e (EncryptionHandshake e) m
|
||||
, HasNonces (EncryptionHandshake e) m
|
||||
, HasPeerNonce e m
|
||||
, Nonce (EncryptionHandshake e) ~ EENonce
|
||||
, Pretty (Peer e)
|
||||
, EventEmitter e (EncryptionHandshake e) m
|
||||
, EventEmitter e (PeerAsymmInfo e) m
|
||||
, HasCredentials s m
|
||||
, Asymm s
|
||||
, Signatures s
|
||||
, Serialise (PubKey 'Encrypt (Encryption e))
|
||||
, s ~ Encryption e
|
||||
, e ~ L4Proto
|
||||
)
|
||||
=> PeerEnv e
|
||||
-> EncryptionHandshake e
|
||||
-> m ()
|
||||
|
||||
encryptionHandshakeProto penv =
|
||||
\case
|
||||
|
||||
BeginEncryptionExchange nonce theirpubkey -> do
|
||||
pip <- thatPeer proto
|
||||
trace $ "GOT BeginEncryptionExchange from" <+> pretty pip
|
||||
|
||||
-- взять свои ключи
|
||||
creds <- getCredentials @s
|
||||
|
||||
let ourpubkey = pubKeyFromKeypair @s $ view envAsymmetricKeyPair penv
|
||||
|
||||
-- подписать нонс
|
||||
let sign = makeSign @s (view peerSignSk creds) (unEENonce nonce <> (cs . serialise) ourpubkey)
|
||||
|
||||
-- отправить обратно вместе с публичным ключом
|
||||
-- response (AckEncryptionExchange @e nonce sign ourpubkey (PeerData (view peerSignPk creds)))
|
||||
|
||||
-- Нужно ли запомнить его theirpubkey или достаточно того, что будет
|
||||
-- получено в обратном AckEncryptionExchange?
|
||||
-- Нужно!
|
||||
emit PeerAsymmInfoKey (PeerAsymmPubKey pip theirpubkey)
|
||||
|
||||
-- se <- find (KnownPeerKey pip) id <&> isJust
|
||||
-- unless se $ do
|
||||
-- sendEncryptionPubKey pip ourpubkey
|
||||
|
||||
AckEncryptionExchange nonce0 sign theirpubkey -> do
|
||||
pip <- thatPeer proto
|
||||
-- trace $ "AckEncryptionExchange" <+> pretty pip
|
||||
|
||||
emit PeerAsymmInfoKey (PeerAsymmPubKey pip theirpubkey)
|
||||
|
||||
where
|
||||
proto = Proxy @(EncryptionHandshake e)
|
||||
|
||||
-----
|
||||
|
||||
data PeerAsymmInfo e = PeerAsymmInfo
|
||||
|
||||
data instance EventKey e (PeerAsymmInfo e) =
|
||||
PeerAsymmInfoKey
|
||||
deriving stock (Generic)
|
||||
|
||||
deriving stock instance (Eq (Peer e)) => Eq (EventKey e (PeerAsymmInfo e))
|
||||
instance (Hashable (Peer e)) => Hashable (EventKey e (PeerAsymmInfo e))
|
||||
|
||||
data instance Event e (PeerAsymmInfo e) =
|
||||
PeerAsymmPubKey (Peer e) (AsymmPubKey (Encryption e))
|
||||
deriving stock (Typeable)
|
||||
|
||||
instance Expires (EventKey e (PeerAsymmInfo e)) where
|
||||
expiresIn _ = Nothing
|
||||
|
|
@ -41,19 +41,9 @@ deriving instance
|
|||
|
||||
makeLenses 'PeerData
|
||||
|
||||
data PeerDataExt e = PeerDataExt
|
||||
{ _peerData :: PeerData e
|
||||
, _peerEncPubKey :: Maybe (PubKey 'Encrypt (Encryption e))
|
||||
}
|
||||
deriving stock (Typeable,Generic)
|
||||
|
||||
makeLenses 'PeerDataExt
|
||||
|
||||
data PeerHandshake e =
|
||||
PeerPing PingNonce
|
||||
| PeerPong PingNonce (Signature (Encryption e)) (PeerData e)
|
||||
| PeerPingCrypted PingNonce (PubKey 'Encrypt (Encryption e))
|
||||
| PeerPongCrypted PingNonce (Signature (Encryption e)) (PubKey 'Encrypt (Encryption e)) (PeerData e)
|
||||
deriving stock (Generic)
|
||||
|
||||
deriving instance
|
||||
|
|
@ -74,13 +64,12 @@ data PeerPingData e =
|
|||
PeerPingData
|
||||
{ _peerPingNonce :: PingNonce
|
||||
, _peerPingSent :: TimeSpec
|
||||
, _peerPingEncPubKey :: Maybe (PubKey 'Encrypt (Encryption e))
|
||||
}
|
||||
deriving stock (Generic,Typeable)
|
||||
|
||||
makeLenses 'PeerPingData
|
||||
|
||||
type instance SessionData e (KnownPeer e) = PeerDataExt e
|
||||
type instance SessionData e (KnownPeer e) = PeerData e
|
||||
|
||||
newtype instance SessionKey e (PeerHandshake e) =
|
||||
PeerHandshakeKey (PingNonce, Peer e)
|
||||
|
|
@ -109,28 +98,10 @@ sendPing :: forall e m . ( MonadIO m
|
|||
sendPing pip = do
|
||||
nonce <- newNonce @(PeerHandshake e)
|
||||
tt <- liftIO $ getTimeCoarse
|
||||
let pdd = PeerPingData nonce tt Nothing
|
||||
let pdd = PeerPingData nonce tt
|
||||
update pdd (PeerHandshakeKey (nonce,pip)) id
|
||||
request pip (PeerPing @e nonce)
|
||||
|
||||
sendPingCrypted :: forall e m . ( MonadIO m
|
||||
, Request e (PeerHandshake e) m
|
||||
, Sessions e (PeerHandshake e) m
|
||||
, HasNonces (PeerHandshake e) m
|
||||
, Nonce (PeerHandshake e) ~ PingNonce
|
||||
, Pretty (Peer e)
|
||||
, HasProtocol e (PeerHandshake e)
|
||||
, e ~ L4Proto
|
||||
)
|
||||
=> Peer e -> PubKey 'Encrypt (Encryption e) -> m ()
|
||||
|
||||
sendPingCrypted pip pubkey = do
|
||||
nonce <- newNonce @(PeerHandshake e)
|
||||
tt <- liftIO $ getTimeCoarse
|
||||
let pdd = PeerPingData nonce tt (Just pubkey)
|
||||
update pdd (PeerHandshakeKey (nonce,pip)) id
|
||||
request pip (PeerPingCrypted @e nonce pubkey)
|
||||
|
||||
newtype PeerHandshakeAdapter e m =
|
||||
PeerHandshakeAdapter
|
||||
{ onPeerRTT :: (Peer e, Integer) -> m ()
|
||||
|
|
@ -148,7 +119,6 @@ peerHandShakeProto :: forall e s m . ( MonadIO m
|
|||
, Pretty (Peer e)
|
||||
, EventEmitter e (PeerHandshake e) m
|
||||
, EventEmitter e (ConcretePeer e) m
|
||||
, EventEmitter e (PeerAsymmInfo e) m
|
||||
, HasCredentials s m
|
||||
, Asymm s
|
||||
, Signatures s
|
||||
|
|
@ -188,11 +158,7 @@ peerHandShakeProto adapter penv =
|
|||
|
||||
se' <- find @e (PeerHandshakeKey (nonce0,pip)) id
|
||||
|
||||
maybe1 se' (pure ()) $ \(PeerPingData nonce t0 mpubkey) -> do
|
||||
|
||||
-- Мы отправляли ключ шифрования, но собеседник отказался
|
||||
-- от шифрованной сессии
|
||||
-- when (isJust mpubkey) do
|
||||
maybe1 se' (pure ()) $ \(PeerPingData nonce t0) -> do
|
||||
|
||||
let pk = view peerSignKey d
|
||||
|
||||
|
|
@ -209,76 +175,10 @@ peerHandShakeProto adapter penv =
|
|||
|
||||
-- FIXME: check if peer is blacklisted
|
||||
-- right here
|
||||
let pde = PeerDataExt d Nothing
|
||||
update pde (KnownPeerKey pip) id
|
||||
update d (KnownPeerKey pip) id
|
||||
|
||||
emit AnyKnownPeerEventKey (KnownPeerEvent pip pde)
|
||||
emit (ConcretePeerKey pip) (ConcretePeerData pip pde)
|
||||
|
||||
---- Crypted
|
||||
PeerPingCrypted nonce theirpubkey -> do
|
||||
pip <- thatPeer proto
|
||||
trace $ "GOT PING CRYPTED from" <+> pretty pip
|
||||
|
||||
-- взять свои ключи
|
||||
creds <- getCredentials @s
|
||||
|
||||
let ourpubkey = pubKeyFromKeypair @s $ view envAsymmetricKeyPair penv
|
||||
|
||||
-- подписать нонс
|
||||
let sign = makeSign @s (view peerSignSk creds) (nonce <> (cs . serialise) ourpubkey)
|
||||
|
||||
own <- peerNonce @e
|
||||
|
||||
-- отправить обратно вместе с публичным ключом
|
||||
response (PeerPongCrypted @e nonce sign ourpubkey (PeerData (view peerSignPk creds) own))
|
||||
|
||||
-- да и пингануть того самим
|
||||
|
||||
se <- find (KnownPeerKey pip) id <&> isJust
|
||||
|
||||
-- Нужно ли запомнить его theirpubkey или достаточно того, что будет
|
||||
-- получено в обратном PeerPongCrypted?
|
||||
-- Нужно!
|
||||
emit PeerAsymmInfoKey (PeerAsymmPubKey pip theirpubkey)
|
||||
|
||||
unless se $ do
|
||||
sendPingCrypted pip ourpubkey
|
||||
|
||||
PeerPongCrypted nonce0 sign theirpubkey pd -> do
|
||||
pip <- thatPeer proto
|
||||
trace $ "GOT PONG CRYPTED from" <+> pretty pip
|
||||
|
||||
se' <- find @e (PeerHandshakeKey (nonce0,pip)) id
|
||||
|
||||
maybe1 se' (pure ()) $ \(PeerPingData nonce t0 mpubkey) -> do
|
||||
|
||||
-- TODO: Мы не отправляли ключ шифрования, а собеседник ответил как будто
|
||||
-- отправляли. Как тут поступать?
|
||||
-- guard (isNothing mpubkey)
|
||||
|
||||
let pk = view peerSignKey pd
|
||||
pde = PeerDataExt pd (Just theirpubkey)
|
||||
|
||||
let signed = verifySign @s pk sign (nonce <> (cs . serialise) theirpubkey)
|
||||
|
||||
when signed $ do
|
||||
|
||||
now <- liftIO getTimeCoarse
|
||||
let rtt = toNanoSecs $ now - t0
|
||||
|
||||
onPeerRTT adapter (pip,rtt)
|
||||
|
||||
expire (PeerHandshakeKey (nonce0,pip))
|
||||
|
||||
-- FIXME: check if peer is blacklisted
|
||||
-- right here
|
||||
update pde (KnownPeerKey pip) id
|
||||
|
||||
emit AnyKnownPeerEventKey (KnownPeerEvent pip pde)
|
||||
emit (ConcretePeerKey pip) (ConcretePeerData pip pde)
|
||||
|
||||
---- /Crypted
|
||||
emit AnyKnownPeerEventKey (KnownPeerEvent pip d)
|
||||
emit (ConcretePeerKey pip) (ConcretePeerData pip d)
|
||||
|
||||
where
|
||||
proto = Proxy @(PeerHandshake e)
|
||||
|
|
@ -293,22 +193,7 @@ deriving stock instance (Eq (Peer e)) => Eq (EventKey e (ConcretePeer e))
|
|||
instance (Hashable (Peer e)) => Hashable (EventKey e (ConcretePeer e))
|
||||
|
||||
data instance Event e (ConcretePeer e) =
|
||||
ConcretePeerData (Peer e) (PeerDataExt e)
|
||||
deriving stock (Typeable)
|
||||
|
||||
---
|
||||
|
||||
data PeerAsymmInfo e = PeerAsymmInfo
|
||||
|
||||
data instance EventKey e (PeerAsymmInfo e) =
|
||||
PeerAsymmInfoKey
|
||||
deriving stock (Generic)
|
||||
|
||||
deriving stock instance (Eq (Peer e)) => Eq (EventKey e (PeerAsymmInfo e))
|
||||
instance (Hashable (Peer e)) => Hashable (EventKey e (PeerAsymmInfo e))
|
||||
|
||||
data instance Event e (PeerAsymmInfo e) =
|
||||
PeerAsymmPubKey (Peer e) (AsymmPubKey (Encryption e))
|
||||
ConcretePeerData (Peer e) (PeerData e)
|
||||
deriving stock (Typeable)
|
||||
|
||||
---
|
||||
|
|
@ -318,7 +203,7 @@ data instance EventKey e (PeerHandshake e) =
|
|||
deriving stock (Typeable, Eq,Generic)
|
||||
|
||||
data instance Event e (PeerHandshake e) =
|
||||
KnownPeerEvent (Peer e) (PeerDataExt e)
|
||||
KnownPeerEvent (Peer e) (PeerData e)
|
||||
deriving stock (Typeable)
|
||||
|
||||
instance ( Typeable (KnownPeer e)
|
||||
|
|
@ -334,9 +219,6 @@ instance EventType ( Event e ( PeerHandshake e) ) where
|
|||
instance Expires (EventKey e (PeerHandshake e)) where
|
||||
expiresIn _ = Nothing
|
||||
|
||||
instance Expires (EventKey e (PeerAsymmInfo e)) where
|
||||
expiresIn _ = Nothing
|
||||
|
||||
instance Expires (EventKey e (ConcretePeer e)) where
|
||||
expiresIn _ = Just 60
|
||||
|
||||
|
|
|
|||
|
|
@ -602,7 +602,7 @@ runPeer opts = U.handle (\e -> myException e
|
|||
already <- liftIO $ Cache.lookup nbcache (p,h) <&> isJust
|
||||
unless already do
|
||||
mpde <- find (KnownPeerKey p) id
|
||||
maybe1 mpde none $ \pde@(PeerDataExt {_peerData = pd}) -> do
|
||||
maybe1 mpde none $ \pd -> do
|
||||
let pk = view peerSignKey pd
|
||||
when (Set.member pk helpFetchKeys) do
|
||||
liftIO $ Cache.insert nbcache (p,h) ()
|
||||
|
|
@ -655,38 +655,27 @@ runPeer opts = U.handle (\e -> myException e
|
|||
subscribe @e PeerAnnounceEventKey $ \(PeerAnnounceEvent pip nonce) -> do
|
||||
unless (nonce == pnonce) $ do
|
||||
debug $ "Got peer announce!" <+> pretty pip
|
||||
mpde :: Maybe (PeerDataExt e) <- find (KnownPeerKey pip) id
|
||||
banned <- maybe (pure False) (peerBanned pip . view peerData) mpde
|
||||
let known = isJust mpde && not banned
|
||||
mpd :: Maybe (PeerData e) <- find (KnownPeerKey pip) id
|
||||
banned <- maybe (pure False) (peerBanned pip) mpd
|
||||
let known = isJust mpd && not banned
|
||||
sendPing pip
|
||||
|
||||
subscribe @e BlockAnnounceInfoKey $ \(BlockAnnounceEvent p bi no) -> do
|
||||
pa <- toPeerAddr p
|
||||
liftIO $ atomically $ writeTQueue rpcQ (CHECK no pa (view biHash bi))
|
||||
|
||||
subscribe @e PeerAsymmInfoKey $ \(PeerAsymmPubKey p peerpubkey) -> do
|
||||
defPeerInfo <- newPeerInfo
|
||||
fetch True defPeerInfo (PeerInfoKey p) id >>= \pinfo -> do
|
||||
let updj = genCommonSecret @s (privKeyFromKeypair @s (view envAsymmetricKeyPair penv))
|
||||
$ peerpubkey
|
||||
liftIO $ atomically $ modifyTVar' (view proxyEncryptionKeys proxy) $ Lens.at p .~ Just updj
|
||||
liftIO $ trace [qc| UPDJust from PeerAsymmInfoKey at {p} {updj} |]
|
||||
|
||||
subscribe @e AnyKnownPeerEventKey $ \(KnownPeerEvent p pde@(PeerDataExt{_peerData = pd})) -> do
|
||||
subscribe @e AnyKnownPeerEventKey $ \(KnownPeerEvent p pd) -> do
|
||||
|
||||
let thatNonce = view peerOwnNonce pd
|
||||
|
||||
now <- liftIO getTimeCoarse
|
||||
|
||||
defPeerInfo <- newPeerInfo
|
||||
fetch True defPeerInfo (PeerInfoKey p) id >>= \pinfo -> do
|
||||
-- defPeerInfo <- newPeerInfo
|
||||
-- fetch True defPeerInfo (PeerInfoKey p) id >>= \pinfo -> do
|
||||
|
||||
find (PeerInfoKey p) id >>= mapM_ \pinfo -> do
|
||||
liftIO $ atomically $ writeTVar (view peerPingFailed pinfo) 0
|
||||
liftIO $ atomically $ writeTVar (view peerLastWatched pinfo) now
|
||||
let mupd = genCommonSecret @s (privKeyFromKeypair @s (view envAsymmetricKeyPair penv))
|
||||
<$> view peerEncPubKey pde
|
||||
forM_ mupd \upd -> do
|
||||
liftIO $ atomically $ modifyTVar' (view proxyEncryptionKeys proxy) $ Lens.at p .~ Just upd
|
||||
liftIO $ trace [qc| UPDJust from AnyKnownPeerEventKey at {p} {upd} |]
|
||||
|
||||
banned <- peerBanned p pd
|
||||
|
||||
|
|
@ -716,15 +705,15 @@ runPeer opts = U.handle (\e -> myException e
|
|||
|
||||
| otherwise -> do
|
||||
|
||||
update pde (KnownPeerKey p) id
|
||||
update pd (KnownPeerKey p) id
|
||||
|
||||
pd :: Map BS.ByteString (Peer L4Proto) <- fmap (Map.fromList . catMaybes)
|
||||
pdkv :: Map BS.ByteString (Peer L4Proto) <- fmap (Map.fromList . catMaybes)
|
||||
$ knownPeers @e pl >>= mapM \pip ->
|
||||
fmap (, pip) <$> find (KnownPeerKey pip) (view (peerData . peerOwnNonce))
|
||||
fmap (, pip) <$> find (KnownPeerKey pip) (view peerOwnNonce)
|
||||
|
||||
let proto1 = view sockType p
|
||||
|
||||
case Map.lookup thatNonce pd of
|
||||
case Map.lookup thatNonce pdkv of
|
||||
|
||||
-- TODO: prefer-local-peer-with-same-nonce-over-remote-peer
|
||||
-- remove remote peer
|
||||
|
|
@ -875,7 +864,7 @@ runPeer opts = U.handle (\e -> myException e
|
|||
sendPing @e pip
|
||||
-- TODO: enqueue-announce-from-unknown-peer?
|
||||
|
||||
Just (pde@(PeerDataExt {_peerData = pd})) -> do
|
||||
Just pd -> do
|
||||
|
||||
banned <- peerBanned pip pd
|
||||
|
||||
|
|
@ -968,7 +957,7 @@ runPeer opts = U.handle (\e -> myException e
|
|||
void $ liftIO $ async $ withPeerM penv $ do
|
||||
forKnownPeers @e $ \p pde -> do
|
||||
pa <- toPeerAddr p
|
||||
let k = view (peerData . peerSignKey) pde
|
||||
let k = view peerSignKey pde
|
||||
request who (RPCPeersAnswer @e pa k)
|
||||
|
||||
let pexInfoAction :: RPC L4Proto -> ResponseM L4Proto (RpcM (ResourceT IO)) ()
|
||||
|
|
|
|||
|
|
@ -359,7 +359,7 @@ forKnownPeers :: forall e m . ( MonadIO m
|
|||
, Sessions e (KnownPeer e) m
|
||||
, HasPeer e
|
||||
)
|
||||
=> ( Peer e -> PeerDataExt e -> m () ) -> m ()
|
||||
=> ( Peer e -> PeerData e -> m () ) -> m ()
|
||||
forKnownPeers m = do
|
||||
pl <- getPeerLocator @e
|
||||
pips <- knownPeers @e pl
|
||||
|
|
|
|||
Loading…
Reference in New Issue