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

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

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
+	liftIO $ void $ tryNonAsync $ controller `concurrently` responder
-		void $ controller `concurrently` responder
+	debug ["remotedaemon exited"]
-		forceSuccessProcess p pid
+	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
+			Just (CONNECTED uri) -> changeconnected S.insert uri
-				cont
+			Just (DISCONNECTED uri) -> changeconnected S.delete uri
-			Just (DISCONNECTED _uri) -> do
-				cont
 			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)

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 }

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

Assistant/WebApp/RepoList.hs

@@ -33,9 +33,10 @@ import qualified Data.Text as T
 import Data.Function
 import Control.Concurrent
 
-type RepoList = [(RepoDesc, RepoId, Actions)]
+type RepoList = [(RepoDesc, RepoId, CurrentlyConnected, Actions)]
 
 type RepoDesc = String
+type CurrentlyConnected = Bool
 
 {- Actions that can be performed on a repo in the list. -}
 data Actions
@@ -192,13 +193,19 @@ repoList reposelector
 	  where
 	  	getconfig k = M.lookup k =<< M.lookup u m
 		val iscloud r = Just (iscloud, (RepoUUID u, DisabledRepoActions $ r u))
-	list l = liftAnnex $
+	list l = do
+		cc <- currentlyConnectedRemotes <$> liftAssistant getDaemonStatus
 		forM (nubBy ((==) `on` fst) l) $ \(repoid, actions) ->
-			(,,)
+			(,,,)
-				<$> describeRepoId repoid
+				<$> liftAnnex (describeRepoId repoid)
 				<*> pure repoid
+				<*> pure (getCurrentlyConnected repoid cc)
 				<*> pure actions
 
+getCurrentlyConnected :: RepoId -> S.Set UUID -> CurrentlyConnected
+getCurrentlyConnected (RepoUUID u) cc = S.member u cc
+getCurrentlyConnected _ _ = False
+
 getEnableSyncR :: RepoId -> Handler ()
 getEnableSyncR = flipSync True
 

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
 

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 
 

templates/repolist.hamlet

@@ -11,7 +11,7 @@
         Repositories
   <table .table .table-condensed>
     <tbody #costsortable>
-      $forall (name, repoid, actions) <- repolist
+      $forall (name, repoid, currentlyconnected, actions) <- repolist
         <tr .repoline ##{show repoid}>
           <td .handle>
             <a .btn .btn-mini .disabled>
@@ -26,10 +26,17 @@
                 <i .icon-trash></i> cleaning out..
               $else
                 <a href="@{syncToggleLink actions}">
-                  $if notSyncing actions
+                  $if currentlyconnected
-                    <i .icon-ban-circle></i> syncing disabled
+                    <i .icon-signal></i> #
                   $else
-                    <i .icon-refresh></i> syncing enabled #
+                    $if notSyncing actions
+                      <i .icon-ban-circle></i> #
+                    $else
+                      <i .icon-refresh></i> #
+                  $if notSyncing actions
+                    syncing disabled
+                  $else
+                    syncing enabled #
                       $if lacksUUID repoid
                         (metadata only)
           <td .draghide>