peers handshake somehow works

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
+

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
 

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)
 

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)

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: отправить обратно вместе с публичным ключом
-      --
+      response (PeerPong @e sign (PeerData (view peerSignPk creds)))
-      pure ()
-      -- TODO: sign nonce
-      -- se <- find @e (PeerHandshakeKey pip) id
-      -- let signed = undefined
-      -- TODO: answer
-      -- response (PeerPong @e signed)
 
-    PeerPong d sign -> do
+    PeerPong sign d -> do
-      pure ()
+      pip <- thatPeer proto
 
-      -- se' <- find @e (PeerHandshakeKey pip) id
+      se' <- find @e (PeerHandshakeKey pip) id
-      -- maybe1 se' (pure ()) $ \se -> do
 
-      -- TODO: get peer data
+      maybe1 se' (pure ()) $ \nonce -> do
-      -- TODO: check signature
+        liftIO $ print $ pretty "PONG" <+> pretty (AsBase58 nonce)
 
-      -- ok <- undefined signed
+        let pk = view peerSignKey d
 
-      -- when ok $ do
+        let signed = verifySign @e pk sign nonce
-        -- TODO: add peer to authorized peers
+
-        -- pure ()
+        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))
 

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
+                            debug $ "ping" <+> pretty s
-                            -- pip <- parseAddr s
+                            pip <- fromPeerAddr @UDP s
-                            pure ()
+                            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
+              void $ liftIO $ waitAnyCatchCancel [me,as]
-                runProto @UDP
-                  [ makeResponse peerHandShakeProto
-                  ]
-
-              void $ liftIO $ waitAnyCatchCancel [me,poo,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]

hbs2/Main.hs

@@ -1,17 +1,17 @@
 module Main where
 
-import HBS2.Storage.Simple
+import HBS2.Base58
-import HBS2.Storage.Simple.Extra
-import HBS2.Prelude
-import HBS2.Prelude.Plated
-import HBS2.Merkle
-import HBS2.Data.Types
 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)