diff options
| -rw-r--r-- | src/Main.hs | 11 | ||||
| -rw-r--r-- | src/Test.hs | 13 |
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 |