Manual peer drop

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