From 58622b632656fc63a04841509eb1429d4a63a396 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Thu, 2 Feb 2023 17:08:39 +0300 Subject: [PATCH] wip --- hbs2-core/hbs2-core.cabal | 1 + hbs2-core/lib/HBS2/Net/IP/Addr.hs | 37 +++++++++++++++++++++-- hbs2-core/lib/HBS2/Net/Messaging/UDP.hs | 14 ++++++++- hbs2-core/lib/HBS2/Net/Proto/Types.hs | 7 +++++ hbs2-peer/app/PeerMain.hs | 40 ++++++++++++++++++------- hbs2-peer/app/RPC.hs | 27 ++++++++++------- 6 files changed, 100 insertions(+), 26 deletions(-) diff --git a/hbs2-core/hbs2-core.cabal b/hbs2-core/hbs2-core.cabal index e8240993..050268f0 100644 --- a/hbs2-core/hbs2-core.cabal +++ b/hbs2-core/hbs2-core.cabal @@ -118,6 +118,7 @@ library , filepath , hashable , interpolatedstring-perl6 + , iproute , memory , microlens-platform , mtl diff --git a/hbs2-core/lib/HBS2/Net/IP/Addr.hs b/hbs2-core/lib/HBS2/Net/IP/Addr.hs index f554df1e..0afdc6fa 100644 --- a/hbs2-core/lib/HBS2/Net/IP/Addr.hs +++ b/hbs2-core/lib/HBS2/Net/IP/Addr.hs @@ -1,7 +1,14 @@ -module HBS2.Net.IP.Addr (parseAddr, getHostPort, Pretty) where +{-# OPTIONS_GHC -fno-warn-orphans #-} +module HBS2.Net.IP.Addr + ( parseAddr + , getHostPort + , Pretty + , IPAddrPort(..) + ) where -import HBS2.Prelude +import HBS2.Prelude.Plated +import Codec.Serialise (Serialise(..)) import Control.Applicative import Control.Monad import Control.Monad.Trans.Maybe @@ -9,16 +16,40 @@ import Data.Attoparsec.Text as Atto import Data.Char import Data.Function import Data.Functor +import Data.IP import Data.Maybe import Data.Text qualified as Text import Data.Text (Text) -import Network.Socket import Network.SockAddr +import Network.Socket +import Data.Word (Word16) import Prettyprinter instance Pretty SockAddr where pretty sa = pretty (show sa) +instance Serialise IP +instance Serialise IPv4 +instance Serialise IPv6 + +newtype IPAddrPort e = + IPAddrPort (IP, Word16) + deriving (Generic) + +instance Serialise (IPAddrPort e) + +instance Pretty (IPAddrPort e) where + pretty (IPAddrPort (ip,p)) = pretty (show pip) <> colon <> pretty p + where + pip = case ip of + i4@(IPv4{}) -> pretty (show i4) + i6@(IPv6{}) -> brackets $ pretty (show i6) + +instance IsString (IPAddrPort e) where + fromString s = IPAddrPort (read h, fromIntegral p) + where + (h,p) = fromMaybe (error "no parse IPAddrPort") (getHostPort (Text.pack s)) + getHostPort :: Text -> Maybe (String, PortNumber) getHostPort s = parseOnly p s & either (const Nothing) Just where diff --git a/hbs2-core/lib/HBS2/Net/Messaging/UDP.hs b/hbs2-core/lib/HBS2/Net/Messaging/UDP.hs index ffd69e54..64c7bbb4 100644 --- a/hbs2-core/lib/HBS2/Net/Messaging/UDP.hs +++ b/hbs2-core/lib/HBS2/Net/Messaging/UDP.hs @@ -1,7 +1,6 @@ {-# Language TemplateHaskell #-} module HBS2.Net.Messaging.UDP where -import HBS2.Prelude import HBS2.Clock import HBS2.Defaults import HBS2.Net.IP.Addr @@ -31,10 +30,14 @@ 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 +-- FIXME: #ASAP change SockAddr to PeerAddr !!! instance HasPeer UDP where newtype instance Peer UDP = PeerUDP @@ -53,6 +56,15 @@ instance Pretty (Peer UDP) where makeLenses 'PeerUDP + +instance MonadIO m => IsPeerAddr UDP m where + type instance PeerAddr UDP = IPAddrPort UDP + toPeerAddr p = pure $ fromString $ show $ pretty p + + fromPeerAddr iap = do + ai <- liftIO $ parseAddr $ fromString (show (pretty iap)) + pure $ PeerUDP $ addrAddress (head ai) -- FIXME: errors?! + -- One address - one peer - one messaging data MessagingUDP = MessagingUDP diff --git a/hbs2-core/lib/HBS2/Net/Proto/Types.hs b/hbs2-core/lib/HBS2/Net/Proto/Types.hs index a2f982c1..33344b76 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/Types.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/Types.hs @@ -62,12 +62,19 @@ data WithCookie e p = WithCookie (Cookie e) p class (Hashable (Peer e), Eq (Peer e)) => HasPeer e where data family (Peer e) :: Type +class Monad m => IsPeerAddr e m where + type family PeerAddr e :: Type + + toPeerAddr :: Peer e -> m (PeerAddr e) + fromPeerAddr :: PeerAddr e -> m (Peer e) + class (Monad m, HasProtocol e p) => HasThatPeer e p (m :: Type -> Type) where thatPeer :: Proxy p -> m (Peer e) class (MonadIO m, HasProtocol e p) => HasDeferred e p m | p -> e where deferred :: Proxy p -> m () -> m () + class ( MonadIO m , HasProtocol e p , HasThatPeer e p m diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index d820ae14..dfe0c38c 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -29,13 +29,14 @@ import Control.Exception as Exception import Control.Monad.Reader import Data.ByteString.Lazy (ByteString) import Data.ByteString.Lazy qualified as LBS +import Data.Text (Text) import Lens.Micro.Platform +import Network.Socket import Options.Applicative import Prettyprinter import System.Directory import System.Exit import System.IO -import Network.Socket debug :: (MonadIO m) => Doc ann -> m () debug p = liftIO $ hPrint stderr p @@ -53,8 +54,9 @@ defLocalMulticast :: String defLocalMulticast = "239.192.152.145:10153" data RPCCommand = - PING + POKE | ANNOUNCE (Hash HbSync) + | PING (PeerAddr UDP) data PeerOpts = PeerOpts @@ -80,8 +82,9 @@ main = join . customExecParser (prefs showHelpOnError) $ where parser :: Parser (IO ()) parser = hsubparser ( command "run" (info pRun (progDesc "run peer")) - <> command "ping" (info pPing (progDesc "ping peer via rpc")) + <> command "poke" (info pPoke (progDesc "poke peer by rpc")) <> command "announce" (info pAnnounce (progDesc "announce block")) + <> command "ping" (info pPing (progDesc "ping another peer")) ) common = do @@ -112,15 +115,19 @@ main = join . customExecParser (prefs showHelpOnError) $ <> value defRpcUDP ) - pPing = do + pPoke = do rpc <- pRpcCommon - pure $ runRpcCommand rpc PING + pure $ runRpcCommand rpc POKE pAnnounce = do rpc <- pRpcCommon h <- strArgument ( metavar "HASH" ) pure $ runRpcCommand rpc (ANNOUNCE h) + pPing = do + rpc <- pRpcCommon + h <- strArgument ( metavar "ADDR" ) + pure $ runRpcCommand rpc (PING h) myException :: SomeException -> IO () myException e = die ( show e ) >> exitFailure @@ -223,7 +230,12 @@ runPeer opts = Exception.handle myException $ do rpc <- liftIO $ async $ withPeerM env $ forever $ do cmd <- liftIO $ atomically $ readTQueue rpcQ case cmd of - PING -> debug "got ping" + POKE -> debug "on poke: alive and kicking!" + + PING s -> do + debug $ "ping" <> pretty s + -- pip <- parseAddr s + pure () ANNOUNCE h -> do debug $ "got announce rpc" <+> pretty h @@ -248,15 +260,19 @@ runPeer opts = Exception.handle myException $ do void $ liftIO $ waitAnyCatchCancel [me,poo,as] - let pingAction _ = do - liftIO $ atomically $ writeTQueue rpcQ PING + let pokeAction _ = do + liftIO $ atomically $ writeTQueue rpcQ POKE let annAction h = do liftIO $ atomically $ writeTQueue rpcQ (ANNOUNCE h) - let arpc = RpcAdapter pingAction + let pingAction pa = do + liftIO $ atomically $ writeTQueue rpcQ (PING pa) + + let arpc = RpcAdapter pokeAction dontHandle annAction + pingAction rpc <- async $ runRPC udp1 do runProto @UDP @@ -312,11 +328,13 @@ withRPC saddr cmd = do where adapter = RpcAdapter dontHandle - (const $ debug "pong" >> liftIO exitSuccess) + (const $ debug "alive-and-kicking" >> liftIO exitSuccess) (const $ liftIO exitSuccess) + (const $ debug "wat?") runRpcCommand :: String -> RPCCommand -> IO () runRpcCommand saddr = \case - PING -> withRPC saddr (RPCPing @UDP) + POKE -> withRPC saddr (RPCPoke @UDP) + PING s -> withRPC saddr (RPCPing s) ANNOUNCE h -> withRPC saddr (RPCAnnounce @UDP h) diff --git a/hbs2-peer/app/RPC.hs b/hbs2-peer/app/RPC.hs index 2d51e0c0..53372de4 100644 --- a/hbs2-peer/app/RPC.hs +++ b/hbs2-peer/app/RPC.hs @@ -1,4 +1,5 @@ {-# Language TemplateHaskell #-} +{-# Language UndecidableInstances #-} module RPC where @@ -17,17 +18,19 @@ import Control.Monad.Reader import Data.ByteString.Lazy (ByteString) import Codec.Serialise (serialise, deserialiseOrFail,Serialise) import Lens.Micro.Platform +import Data.Text (Text) import Prettyprinter data RPC e = - RPCPing - | RPCPong + RPCPoke + | RPCPing (PeerAddr e) + | RPCPokeAnswer | RPCAnnounce (Hash HbSync) - deriving stock (Eq,Generic,Show) + deriving stock (Generic) -instance Serialise (RPC e) +instance Serialise (PeerAddr e) => Serialise (RPC e) instance HasProtocol UDP (RPC UDP) where type instance ProtocolId (RPC UDP) = 0xFFFFFFE0 @@ -46,9 +49,10 @@ makeLenses 'RPCEnv data RpcAdapter e m = RpcAdapter - { rpcOnPing :: RPC e -> m () - , rpcOnPong :: RPC e -> m () - , rpcOnAnnounce :: Hash HbSync -> m () + { rpcOnPoke :: RPC e -> m () + , rpcOnPokeAnswer :: RPC e -> m () + , rpcOnAnnounce :: Hash HbSync -> m () + , rpcOnPing :: PeerAddr e -> m () } newtype RpcM m a = RpcM { fromRpcM :: ReaderT RPCEnv m a } @@ -81,12 +85,13 @@ instance Monad m => HasOwnPeer UDP (RpcM m) where rpcHandler :: forall e m . ( MonadIO m , Response e (RPC e) m , HasProtocol e (RPC e) + , IsPeerAddr e m ) => RpcAdapter e m -> RPC e -> m () rpcHandler adapter = \case - p@RPCPing{} -> rpcOnPing adapter p >> response (RPCPong @e) - p@RPCPong{} -> rpcOnPong adapter p - (RPCAnnounce h) -> rpcOnAnnounce adapter h - + p@RPCPoke{} -> rpcOnPoke adapter p >> response (RPCPokeAnswer @e) + p@RPCPokeAnswer{} -> rpcOnPokeAnswer adapter p + (RPCAnnounce h) -> rpcOnAnnounce adapter h + (RPCPing pa) -> rpcOnPing adapter pa