webapp: Show a network signal icon next to ssh remotes that it's currently connected with.

4 files changed, 27 insertions, 10 deletions

diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs
index eb842b784..35f8fc856 100644
--- a/Assistant/DaemonStatus.hs
+++ b/Assistant/DaemonStatus.hs
@@ -26,6 +26,7 @@ import Data.Time.Clock.POSIX
 import Data.Time
 import System.Locale
 import qualified Data.Map as M
+import qualified Data.Set as S
 import qualified Data.Text as T
 
 getDaemonStatus :: Assistant DaemonStatus
@@ -78,6 +79,15 @@ updateSyncRemotes = do
 			M.filter $ \alert ->
 				alertName alert /= Just CloudRepoNeededAlert
 
+changeCurrentlyConnected :: (S.Set UUID -> S.Set UUID) -> Assistant ()
+changeCurrentlyConnected sm = do
+	modifyDaemonStatus_ $ \ds -> ds
+		{ currentlyConnectedRemotes = sm (currentlyConnectedRemotes ds)
+		}
+	v <- currentlyConnectedRemotes <$> getDaemonStatus
+	debug [show v]
+	liftIO . sendNotification =<< syncRemotesNotifier <$> getDaemonStatus
+
 updateScheduleLog :: Assistant ()
 updateScheduleLog =
 	liftIO . sendNotification =<< scheduleLogNotifier <$> getDaemonStatus
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 }
diff --git a/Assistant/Types/DaemonStatus.hs b/Assistant/Types/DaemonStatus.hs
index a618c700d..2adad2828 100644
--- a/Assistant/Types/DaemonStatus.hs
+++ b/Assistant/Types/DaemonStatus.hs
@@ -52,6 +52,8 @@ data DaemonStatus = DaemonStatus
 	, syncDataRemotes :: [Remote]
 	-- Are we syncing to any cloud remotes?
 	, syncingToCloudRemote :: Bool
+	-- Set of uuids of remotes that are currently connected.
+	, currentlyConnectedRemotes :: S.Set UUID
 	-- List of uuids of remotes that we may have gotten out of sync with.
 	, desynced :: S.Set UUID
 	-- Pairing request that is in progress.
@@ -104,6 +106,7 @@ newDaemonStatus = DaemonStatus
 	<*> pure []
 	<*> pure False
 	<*> pure S.empty
+	<*> pure S.empty
 	<*> pure Nothing
 	<*> newNotificationBroadcaster
 	<*> newNotificationBroadcaster