Command to manually add peer

2 files changed, 24 insertions, 0 deletions

diff --git a/src/Main.hs b/src/Main.hs
index 4a2d910..cdaa9ae 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -232,6 +232,7 @@ commands :: [(String, Command)]
 commands =
     [ ("history", cmdHistory)
     , ("peers", cmdPeers)
+    , ("peer-add", cmdPeerAdd)
     , ("send", cmdSend)
     , ("update-identity", cmdUpdateIdentity)
     , ("attach", cmdAttach)
@@ -259,6 +260,16 @@ cmdPeers = do
     forM_ (zip [1..] peers) $ \(i :: Int, (_, name)) -> do
         liftIO $ putStrLn $ show i ++ ": " ++ name
 
+cmdPeerAdd :: Command
+cmdPeerAdd = void $ do
+    server <- asks ciServer
+    (hostname, port) <- (words <$> asks ciLine) >>= \case
+        hostname:p:_ -> return (hostname, p)
+        [hostname] -> return (hostname, show discoveryPort)
+        [] -> throwError "missing peer address"
+    addr:_ <- liftIO $ getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just hostname) (Just port)
+    liftIO $ serverPeer server (addrAddress addr)
+
 showPeer :: PeerIdentity -> PeerAddress -> String
 showPeer pidentity paddr =
     let name = case pidentity of
diff --git a/src/Test.hs b/src/Test.hs
index a7dd730..04a5c9c 100644
--- a/src/Test.hs
+++ b/src/Test.hs
@@ -21,6 +21,8 @@ import Data.Text.Encoding
 import Data.Text.IO qualified as T
 import Data.Typeable
 
+import Network.Socket
+
 import System.IO
 import System.IO.Error
 
@@ -230,6 +232,7 @@ commands = map (T.pack *** id)
     , ("stored-set-list", cmdStoredSetList)
     , ("create-identity", cmdCreateIdentity)
     , ("start-server", cmdStartServer)
+    , ("peer-add", cmdPeerAdd)
     , ("shared-state-get", cmdSharedStateGet)
     , ("shared-state-wait", cmdSharedStateWait)
     , ("watch-local-identity", cmdWatchLocalIdentity)
@@ -342,6 +345,16 @@ cmdStartServer = do
 
     modify $ \s -> s { tsServer = Just server, tsPeers = Just peers }
 
+cmdPeerAdd :: Command
+cmdPeerAdd = do
+    Just server <- gets tsServer
+    host:rest <- map T.unpack <$> asks tiParams
+
+    let port = case rest of [] -> show discoveryPort
+                            (p:_) -> p
+    addr:_ <- liftIO $ getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just host) (Just port)
+    void $ liftIO $ serverPeer server (addrAddress addr)
+
 cmdSharedStateGet :: Command
 cmdSharedStateGet = do
     h <- getHead