wip

hbs2-core/hbs2-core.cabal

@@ -118,6 +118,7 @@ library
                     , filepath
                     , hashable
                     , interpolatedstring-perl6
+                    , iproute
                     , memory
                     , microlens-platform
                     , mtl

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

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

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

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)
 

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