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

6 files changed, 29 insertions, 12 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
diff --git a/debian/changelog b/debian/changelog
index fcbef3fce..bd908fa6c 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -6,6 +6,8 @@ git-annex (5.20140406) UNRELEASED; urgency=medium
     changes to a ssh remote, and pulls.
     XMPP is no longer needed in this configuration!
     Requires the remote server have git-annex-shell with notifychanges support.
+  * webapp: Show a network signal icon next to ssh remotes that
+    it's currently connected with.
 
  -- Joey Hess <joeyh@debian.org>  Mon, 07 Apr 2014 16:22:02 -0400
 
diff --git a/doc/design/git-remote-daemon.mdwn b/doc/design/git-remote-daemon.mdwn
index b81a5f33a..ca3a59fce 100644
--- a/doc/design/git-remote-daemon.mdwn
+++ b/doc/design/git-remote-daemon.mdwn
@@ -170,8 +170,6 @@ TODO:
 * Remote system might not be available. Find a smart way to detect it,
   ideally w/o generating network traffic. One way might be to check
   if the ssh connection caching control socket exists, for example.
-* CONNECTED and DISCONNECTED are not wired into any webapp UI; could be
-  used to show an icon when a ssh remote is available
 
 ## telehash