From 16cdf223af47800e44ed6b72ae683e93e9178782 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Thu, 2 Feb 2023 19:08:16 +0300 Subject: [PATCH] peers handshake somehow works --- hbs2-core/lib/HBS2/Base58.hs | 8 ++ hbs2-core/lib/HBS2/Net/Auth/Credentials.hs | 1 - hbs2-core/lib/HBS2/Net/IP/Addr.hs | 10 +++ hbs2-core/lib/HBS2/Net/Messaging/UDP.hs | 7 +- hbs2-core/lib/HBS2/Net/Proto/Peer.hs | 95 +++++++++++++++++----- hbs2-peer/app/PeerMain.hs | 46 ++++++++--- hbs2/Main.hs | 12 +-- 7 files changed, 138 insertions(+), 41 deletions(-) diff --git a/hbs2-core/lib/HBS2/Base58.hs b/hbs2-core/lib/HBS2/Base58.hs index bcd5828e..cc67bce6 100644 --- a/hbs2-core/lib/HBS2/Base58.hs +++ b/hbs2-core/lib/HBS2/Base58.hs @@ -4,6 +4,10 @@ import Data.ByteString.Base58 (encodeBase58, bitcoinAlphabet, decodeBase58,Alpha import Data.ByteString.Char8 qualified as BS8 import Data.ByteString.Char8 (ByteString) +import Prettyprinter + +newtype AsBase58 a = AsBase58 a + alphabet :: Alphabet alphabet = bitcoinAlphabet @@ -17,3 +21,7 @@ toBase58 = encodeBase58 bitcoinAlphabet fromBase58 :: ByteString -> Maybe ByteString fromBase58 = decodeBase58 bitcoinAlphabet + +instance Pretty (AsBase58 ByteString) where + pretty (AsBase58 bs) = pretty $ BS8.unpack $ toBase58 bs + diff --git a/hbs2-core/lib/HBS2/Net/Auth/Credentials.hs b/hbs2-core/lib/HBS2/Net/Auth/Credentials.hs index 23ea6aea..acedd386 100644 --- a/hbs2-core/lib/HBS2/Net/Auth/Credentials.hs +++ b/hbs2-core/lib/HBS2/Net/Auth/Credentials.hs @@ -18,7 +18,6 @@ import Data.Function import Data.List.Split (chunksOf) import Prettyprinter -newtype AsBase58 a = AsBase58 a newtype AsCredFile a = AsCredFile a diff --git a/hbs2-core/lib/HBS2/Net/IP/Addr.hs b/hbs2-core/lib/HBS2/Net/IP/Addr.hs index 0afdc6fa..650948de 100644 --- a/hbs2-core/lib/HBS2/Net/IP/Addr.hs +++ b/hbs2-core/lib/HBS2/Net/IP/Addr.hs @@ -4,6 +4,7 @@ module HBS2.Net.IP.Addr , getHostPort , Pretty , IPAddrPort(..) + , AddrPriority(..) ) where import HBS2.Prelude.Plated @@ -25,6 +26,15 @@ import Network.Socket import Data.Word (Word16) import Prettyprinter +class AddrPriority a where + addrPriority :: a -> Int + +instance AddrPriority SockAddr where + addrPriority = \case + SockAddrInet{} -> 1 + SockAddrInet6{} -> 2 + SockAddrUnix{} -> 3 + instance Pretty SockAddr where pretty sa = pretty (show sa) diff --git a/hbs2-core/lib/HBS2/Net/Messaging/UDP.hs b/hbs2-core/lib/HBS2/Net/Messaging/UDP.hs index 64c7bbb4..f43b1754 100644 --- a/hbs2-core/lib/HBS2/Net/Messaging/UDP.hs +++ b/hbs2-core/lib/HBS2/Net/Messaging/UDP.hs @@ -30,10 +30,7 @@ import Lens.Micro.Platform import Network.Socket import Network.Socket.ByteString import Network.Multicast -import Data.IP -import Data.Word import Prettyprinter -import Codec.Serialise (Serialise(..)) data UDP @@ -45,6 +42,10 @@ instance HasPeer UDP where } deriving stock (Eq,Ord,Show,Generic) + +instance AddrPriority (Peer UDP) where + addrPriority (PeerUDP sa) = addrPriority sa + instance Hashable (Peer UDP) where hashWithSalt salt p = case _sockAddr p of SockAddrInet pn h -> hashWithSalt salt (4, fromIntegral pn, h) diff --git a/hbs2-core/lib/HBS2/Net/Proto/Peer.hs b/hbs2-core/lib/HBS2/Net/Proto/Peer.hs index aa2b6f04..416a2c5d 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/Peer.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/Peer.hs @@ -2,15 +2,24 @@ {-# Language UndecidableInstances #-} module HBS2.Net.Proto.Peer where +import HBS2.Base58 import HBS2.Data.Types +import HBS2.Events +import HBS2.Net.Auth.Credentials +import HBS2.Net.PeerLocator import HBS2.Net.Proto +import HBS2.Clock import HBS2.Net.Proto.Sessions import HBS2.Prelude.Plated +import Codec.Serialise() import Data.ByteString.Lazy (ByteString) import Data.ByteString qualified as BS +import Data.Hashable import Lens.Micro.Platform -import Codec.Serialise() +import Type.Reflection (someTypeRep) + +import Prettyprinter type PingSign e = Signature e type PingNonce = BS.ByteString @@ -28,7 +37,7 @@ newtype PeerAnnounce e = PeerAnnounce (PeerData e) data PeerHandshake e = PeerPing PingNonce - | PeerPong (PeerData e) (Signature e) + | PeerPong (Signature e) (PeerData e) deriving stock (Generic) newtype KnownPeer e = KnownPeer (PeerData e) @@ -44,15 +53,35 @@ newtype instance SessionKey e (PeerHandshake e) = PeerHandshakeKey (Peer e) deriving stock (Generic, Typeable) -type instance SessionData e (PeerHandshake e) = (PingNonce, PeerData e) +type instance SessionData e (PeerHandshake e) = PingNonce + + + +sendPing :: 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) + ) + => Peer e -> m () + +sendPing pip = do + nonce <- newNonce @(PeerHandshake e) + update nonce (PeerHandshakeKey pip) id + liftIO $ print $ "sendPing" <+> pretty pip <+> pretty (AsBase58 nonce) + request pip (PeerPing @e nonce) peerHandShakeProto :: forall e m . ( MonadIO m , Response e (PeerHandshake e) m , Sessions e (PeerHandshake e) m + , Sessions e (KnownPeer e) m , HasNonces (PeerHandshake e) m , Nonce (PeerHandshake e) ~ PingNonce , Signatures e + , Pretty (Peer e) , HasCredentials e m + , EventEmitter e (PeerHandshake e) m ) => PeerHandshake e -> m () @@ -61,34 +90,60 @@ peerHandShakeProto = PeerPing nonce -> do pip <- thatPeer proto -- TODO: взять свои ключи + creds <- getCredentials @e + liftIO $ print $ "PING" <+> pretty pip <+> pretty (AsBase58 nonce) + -- TODO: подписать нонс + let sign = makeSign @e (view peerSignSk creds) nonce + -- TODO: отправить обратно вместе с публичным ключом - -- - pure () - -- TODO: sign nonce - -- se <- find @e (PeerHandshakeKey pip) id - -- let signed = undefined - -- TODO: answer - -- response (PeerPong @e signed) + response (PeerPong @e sign (PeerData (view peerSignPk creds))) - PeerPong d sign -> do - pure () + PeerPong sign d -> do + pip <- thatPeer proto - -- se' <- find @e (PeerHandshakeKey pip) id - -- maybe1 se' (pure ()) $ \se -> do + se' <- find @e (PeerHandshakeKey pip) id - -- TODO: get peer data - -- TODO: check signature + maybe1 se' (pure ()) $ \nonce -> do + liftIO $ print $ pretty "PONG" <+> pretty (AsBase58 nonce) - -- ok <- undefined signed + let pk = view peerSignKey d - -- when ok $ do - -- TODO: add peer to authorized peers - -- pure () + let signed = verifySign @e pk sign nonce + + liftIO $ print $ "SIGNED: " <+> pretty signed + + expire (PeerHandshakeKey pip) + + update (KnownPeer d) (KnownPeerKey pip) id + + emit KnownPeerEventKey (KnownPeerEvent pip d) where proto = Proxy @(PeerHandshake e) + +data instance EventKey e (PeerHandshake e) = + KnownPeerEventKey + deriving stock (Typeable, Eq,Generic) + +data instance Event e (PeerHandshake e) = + KnownPeerEvent (Peer e) (PeerData e) + deriving stock (Typeable) + +instance Typeable (KnownPeer e) => Hashable (EventKey e (KnownPeer e)) where + hashWithSalt salt _ = hashWithSalt salt (someTypeRep p) + where + p = Proxy @(KnownPeer e) + +instance EventType ( Event e ( PeerHandshake e) ) where + isPersistent = True + +instance Expires (EventKey e (PeerHandshake e)) where + expiresIn _ = Nothing + +instance Hashable (Peer e) => Hashable (EventKey e (PeerHandshake e)) + deriving instance Eq (Peer e) => Eq (SessionKey e (KnownPeer e)) instance Hashable (Peer e) => Hashable (SessionKey e (KnownPeer e)) diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index dfe0c38c..d7819178 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -1,13 +1,16 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# Language TemplateHaskell #-} {-# Language AllowAmbiguousTypes #-} +{-# Language UndecidableInstances #-} module Main where import HBS2.Actors.Peer +import HBS2.Base58 import HBS2.Clock import HBS2.Defaults import HBS2.Events import HBS2.Hash +import HBS2.Net.Auth.Credentials import HBS2.Net.IP.Addr import HBS2.Net.Messaging.UDP import HBS2.Net.PeerLocator @@ -18,17 +21,18 @@ import HBS2.Net.Proto.Sessions import HBS2.OrDie import HBS2.Prelude.Plated import HBS2.Storage.Simple -import HBS2.Net.Auth.Credentials import RPC import BlockDownload +import Data.Function import Control.Concurrent.Async import Control.Concurrent.STM import Control.Exception as Exception import Control.Monad.Reader import Data.ByteString.Lazy (ByteString) import Data.ByteString.Lazy qualified as LBS +import Data.List qualified as L import Data.Text (Text) import Lens.Micro.Platform import Network.Socket @@ -160,12 +164,28 @@ instance (Sessions e p m ) => Sessions e p (CredentialsM e m) where update d k f = lift (update d k f) expire k = lift (expire k) +-- instance (Monad m, HasProtocol e p, HasThatPeer e p m) => Response e p (CredentialsM e m) where + instance Monad m => HasCredentials e (CredentialsM e m) where getCredentials = ask instance Monad m => HasCredentials e (ResponseM e (CredentialsM e m)) where getCredentials = lift getCredentials +instance (Monad m, HasThatPeer e p m) => HasThatPeer e p (CredentialsM e m) where + thatPeer = lift . thatPeer + +instance ( EventEmitter e p m + ) => EventEmitter e p (CredentialsM e m) where + + emit k d = lift $ emit k d + +instance ( Monad m + , Response e p m + ) => Response e p (CredentialsM e m) where + + response = lift . response + runPeer :: () => PeerOpts -> IO () runPeer opts = Exception.handle myException $ do @@ -225,6 +245,11 @@ runPeer opts = Exception.handle myException $ do addPeers @UDP pl ps + subscribe @UDP KnownPeerEventKey $ \(KnownPeerEvent p d) -> do + addPeers pl [p] + debug $ "Got authorized peer!" <+> pretty p + <+> pretty (AsBase58 (view peerSignKey d)) + as <- liftIO $ async $ withPeerM env blockDownloadLoop rpc <- liftIO $ async $ withPeerM env $ forever $ do @@ -233,9 +258,9 @@ runPeer opts = Exception.handle myException $ do POKE -> debug "on poke: alive and kicking!" PING s -> do - debug $ "ping" <> pretty s - -- pip <- parseAddr s - pure () + debug $ "ping" <+> pretty s + pip <- fromPeerAddr @UDP s + sendPing pip ANNOUNCE h -> do debug $ "got announce rpc" <+> pretty h @@ -251,14 +276,10 @@ runPeer opts = Exception.handle myException $ do [ makeResponse (blockSizeProto blk dontHandle) , makeResponse (blockChunksProto adapter) , makeResponse blockAnnounceProto + , makeResponse (withCredentials pc . peerHandShakeProto) ] - poo <- liftIO $ async $ withPeerM env $ withCredentials pc $ do - runProto @UDP - [ makeResponse peerHandShakeProto - ] - - void $ liftIO $ waitAnyCatchCancel [me,poo,as] + void $ liftIO $ waitAnyCatchCancel [me,as] let pokeAction _ = do liftIO $ atomically $ writeTQueue rpcQ POKE @@ -300,7 +321,8 @@ runPeer opts = Exception.handle myException $ do withRPC :: String -> RPC UDP -> IO () withRPC saddr cmd = do - rpc' <- headMay <$> parseAddr (fromString saddr) <&> fmap (PeerUDP . addrAddress) + as <- parseAddr (fromString saddr) <&> fmap (PeerUDP . addrAddress) + let rpc' = headMay $ L.sortBy (compare `on` addrPriority) as rpc <- pure rpc' `orDie` "Can't parse RPC endpoing" @@ -320,6 +342,8 @@ withRPC saddr cmd = do case cmd of RPCAnnounce{} -> pause @'Seconds 0.1 >> liftIO exitSuccess + RPCPing{} -> pause @'Seconds 0.1 >> liftIO exitSuccess + _ -> pure () void $ liftIO $ waitAnyCatchCancel [proto] diff --git a/hbs2/Main.hs b/hbs2/Main.hs index 1f92e8a1..1494ebd7 100644 --- a/hbs2/Main.hs +++ b/hbs2/Main.hs @@ -1,17 +1,17 @@ module Main where -import HBS2.Storage.Simple -import HBS2.Storage.Simple.Extra -import HBS2.Prelude -import HBS2.Prelude.Plated -import HBS2.Merkle -import HBS2.Data.Types +import HBS2.Base58 import HBS2.Data.Detect +import HBS2.Data.Types import HBS2.Defaults +import HBS2.Merkle import HBS2.Net.Auth.Credentials import HBS2.Net.Messaging.UDP (UDP) import HBS2.Net.Proto.Definition() import HBS2.Net.Proto.Types +import HBS2.Prelude.Plated +import HBS2.Storage.Simple +import HBS2.Storage.Simple.Extra import Data.ByteString.Lazy (ByteString)