From b7feceff3dfd4ed7c8889036cd43f06642a449da Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Wed, 9 Apr 2014 15:26:41 -0400
Subject: webapp: Show a network signal icon next to ssh remotes that it's
 currently connected with.

---
 Assistant/Threads/RemoteControl.hs | 23 +++++++++++++----------
 Assistant/Threads/XMPPClient.hs    |  1 +
 2 files changed, 14 insertions(+), 10 deletions(-)

(limited to 'Assistant/Threads')

diff --git a/Assistant/Threads/RemoteControl.hs b/Assistant/Threads/RemoteControl.hs
index d33a4858d..a886caeb9 100644
--- a/Assistant/Threads/RemoteControl.hs
+++ b/Assistant/Threads/RemoteControl.hs
@@ -23,8 +23,9 @@ import qualified Types.Remote as Remote
 import Control.Concurrent
 import Control.Concurrent.Async
 import System.Process (std_in, std_out)
-import qualified Data.Map as M
 import Network.URI
+import qualified Data.Map as M
+import qualified Data.Set as S
 
 remoteControlThread :: NamedThread
 remoteControlThread = namedThread "RemoteControl" $ do
@@ -43,9 +44,9 @@ remoteControlThread = namedThread "RemoteControl" $ do
 	responder <- asIO $ remoteResponderThread fromh urimap
 
 	-- run controller and responder until the remotedaemon dies
-	liftIO $ do
-		void $ controller `concurrently` responder
-		forceSuccessProcess p pid
+	liftIO $ void $ tryNonAsync $ controller `concurrently` responder
+	debug ["remotedaemon exited"]
+	liftIO $ forceSuccessProcess p pid
 
 -- feed from the remoteControl channel into the remotedaemon
 remoteControllerThread :: Handle -> Assistant ()
@@ -61,14 +62,10 @@ remoteResponderThread :: Handle -> MVar (M.Map URI Remote) -> Assistant ()
 remoteResponderThread fromh urimap = go M.empty
   where
 	go syncalerts = do
-		let cont = go syncalerts
-		let withr uri = withRemote uri urimap cont
 		l <- liftIO $ hGetLine fromh
 		case parseMessage l of
-			Just (CONNECTED _uri) -> do
-				cont
-			Just (DISCONNECTED _uri) -> do
-				cont
+			Just (CONNECTED uri) -> changeconnected S.insert uri
+			Just (DISCONNECTED uri) -> changeconnected S.delete uri
 			Just (SYNCING uri) -> withr uri $ \r ->
 				if M.member (Remote.uuid r) syncalerts
 					then go syncalerts
@@ -92,6 +89,12 @@ remoteResponderThread fromh urimap = go M.empty
 			Nothing -> do
 				debug ["protocol error from remotedaemon: ", l]
 				cont
+	  where
+		cont = go syncalerts
+		withr uri = withRemote uri urimap cont
+		changeconnected sm uri = withr uri $ \r -> do
+			changeCurrentlyConnected $ sm $ Remote.uuid r
+			cont
 
 getURIMap :: Annex (M.Map URI Remote)
 getURIMap = Remote.remoteMap' id (mkk . Git.location . Remote.repo)
diff --git a/Assistant/Threads/XMPPClient.hs b/Assistant/Threads/XMPPClient.hs
index ab4de9257..d23f695f6 100644
--- a/Assistant/Threads/XMPPClient.hs
+++ b/Assistant/Threads/XMPPClient.hs
@@ -67,6 +67,7 @@ xmppClient urlrenderer d creds =
 		 - is not retained. -}
 		liftAssistant $
 			updateBuddyList (const noBuddies) <<~ buddyList
+		liftAssistant $ 
 		void client
 		liftAssistant $ modifyDaemonStatus_ $ \s -> s
 			{ xmppClientID = Nothing }
-- 
cgit v1.2.3