summaryrefslogtreecommitdiff
path: root/main
diff options
context:
space:
mode:
Diffstat (limited to 'main')
-rw-r--r--main/Main.hs10
-rw-r--r--main/Test.hs25
2 files changed, 34 insertions, 1 deletions
diff --git a/main/Main.hs b/main/Main.hs
index 0857191..44e2f7b 100644
--- a/main/Main.hs
+++ b/main/Main.hs
@@ -281,7 +281,9 @@ interactiveLoop st opts = runInputT inputSettings $ do
{ ciServer = server
, ciLine = line
, ciPrint = extPrintLn
- , ciPeers = liftIO $ readMVar peers
+ , ciPeers = liftIO $ modifyMVar peers $ \ps -> do
+ ps' <- filterM (fmap not . isPeerDropped . fst) ps
+ return (ps', ps')
, ciContextOptions = liftIO $ readMVar contextOptions
, ciSetContextOptions = \ctxs -> liftIO $ modifyMVar_ contextOptions $ const $ return ctxs
}
@@ -372,6 +374,7 @@ commands =
[ ("history", cmdHistory)
, ("peers", cmdPeers)
, ("peer-add", cmdPeerAdd)
+ , ("peer-drop", cmdPeerDrop)
, ("send", cmdSend)
, ("update-identity", cmdUpdateIdentity)
, ("attach", cmdAttach)
@@ -423,6 +426,11 @@ cmdPeerAdd = void $ do
addr:_ <- liftIO $ getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just hostname) (Just port)
liftIO $ serverPeer server (addrAddress addr)
+cmdPeerDrop :: Command
+cmdPeerDrop = do
+ dropPeer =<< getSelectedPeer
+ modify $ \s -> s { csContext = NoContext }
+
showPeer :: PeerIdentity -> PeerAddress -> String
showPeer pidentity paddr =
let name = case pidentity of
diff --git a/main/Test.hs b/main/Test.hs
index d16e141..cdc337e 100644
--- a/main/Test.hs
+++ b/main/Test.hs
@@ -246,6 +246,8 @@ commands = map (T.pack *** id)
, ("start-server", cmdStartServer)
, ("stop-server", cmdStopServer)
, ("peer-add", cmdPeerAdd)
+ , ("peer-drop", cmdPeerDrop)
+ , ("peer-list", cmdPeerList)
, ("test-message-send", cmdTestMessageSend)
, ("shared-state-get", cmdSharedStateGet)
, ("shared-state-wait", cmdSharedStateWait)
@@ -410,6 +412,29 @@ cmdPeerAdd = do
addr:_ <- liftIO $ getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just host) (Just port)
void $ liftIO $ serverPeer rsServer (addrAddress addr)
+cmdPeerDrop :: Command
+cmdPeerDrop = do
+ [spidx] <- asks tiParams
+ peer <- getPeer spidx
+ liftIO $ dropPeer peer
+
+cmdPeerList :: Command
+cmdPeerList = do
+ Just RunningServer {..} <- gets tsServer
+ peers <- liftIO $ getCurrentPeerList rsServer
+ tpeers <- liftIO $ readMVar rsPeers
+ forM_ peers $ \peer -> do
+ Just (n, _) <- return $ find ((peer==).snd) . snd $ tpeers
+ mbpid <- peerIdentity peer
+ cmdOut $ unwords $ concat
+ [ [ "peer-list-item", show n ]
+ , [ "addr", show (peerAddress peer) ]
+ , case mbpid of PeerIdentityFull pid -> ("id":) $ map (maybe "<unnamed>" T.unpack . idName) (unfoldOwners pid)
+ _ -> []
+ ]
+ cmdOut "peer-list-done"
+
+
cmdTestMessageSend :: Command
cmdTestMessageSend = do
[spidx, tref] <- asks tiParams