assistant: Now detects immediately when other repositories push 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.

(untested)

This commit was sponsored by Geog Wechslberger.

Assistant.hs

@@ -21,6 +21,7 @@ import Assistant.Threads.Pusher
 import Assistant.Threads.Merger
 import Assistant.Threads.TransferWatcher
 import Assistant.Threads.Transferrer
+import Assistant.Threads.RemoteControl
 import Assistant.Threads.SanityChecker
 import Assistant.Threads.Cronner
 import Assistant.Threads.ProblemFixer
@@ -147,6 +148,7 @@ startDaemon assistant foreground startdelay cannotrun listenhost startbrowser =
 				, assist $ transferWatcherThread
 				, assist $ transferPollerThread
 				, assist $ transfererThread
+				, assist $ remoteControlThread
 				, assist $ daemonStatusThread
 				, assist $ sanityCheckerDailyThread urlrenderer
 				, assist $ sanityCheckerHourlyThread

Assistant/Alert.hs

@@ -16,6 +16,7 @@ import qualified Remote
 import Utility.Tense
 import Logs.Transfer
 import Types.Distribution
+import Git.Types (RemoteName)
 
 import Data.String
 import qualified Data.Text as T
@@ -117,11 +118,14 @@ commitAlert :: Alert
 commitAlert = activityAlert Nothing
 	[Tensed "Committing" "Committed", "changes to git"]
 
-showRemotes :: [Remote] -> TenseChunk
-showRemotes = UnTensed . T.intercalate ", " . map (T.pack . Remote.name)
+showRemotes :: [RemoteName] -> TenseChunk
+showRemotes = UnTensed . T.intercalate ", " . map T.pack
 
 syncAlert :: [Remote] -> Alert
-syncAlert rs = baseActivityAlert
+syncAlert = syncAlert' . map Remote.name
+
+syncAlert' :: [RemoteName] -> Alert
+syncAlert' rs = baseActivityAlert
 	{ alertName = Just SyncAlert
 	, alertHeader = Just $ tenseWords
 		[Tensed "Syncing" "Synced", "with", showRemotes rs]
@@ -130,7 +134,12 @@ syncAlert rs = baseActivityAlert
 	}
 
 syncResultAlert :: [Remote] -> [Remote] -> Alert
-syncResultAlert succeeded failed = makeAlertFiller (not $ null succeeded) $
+syncResultAlert succeeded failed = syncResultAlert'
+	(map Remote.name succeeded)
+	(map Remote.name failed)
+
+syncResultAlert' :: [RemoteName] -> [RemoteName] -> Alert
+syncResultAlert' succeeded failed = makeAlertFiller (not $ null succeeded) $
 	baseActivityAlert
 		{ alertName = Just SyncAlert
 		, alertHeader = Just $ tenseWords msg

Assistant/Monad.hs

@@ -43,6 +43,7 @@ import Assistant.Types.RepoProblem
 import Assistant.Types.Buddies
 import Assistant.Types.NetMessager
 import Assistant.Types.ThreadName
+import Assistant.Types.RemoteControl
 
 newtype Assistant a = Assistant { mkAssistant :: ReaderT AssistantData IO a }
 	deriving (
@@ -68,6 +69,7 @@ data AssistantData = AssistantData
 	, branchChangeHandle :: BranchChangeHandle
 	, buddyList :: BuddyList
 	, netMessager :: NetMessager
+	, remoteControl :: RemoteControl
 	}
 
 newAssistantData :: ThreadState -> DaemonStatusHandle -> IO AssistantData
@@ -86,6 +88,7 @@ newAssistantData st dstatus = AssistantData
 	<*> newBranchChangeHandle
 	<*> newBuddyList
 	<*> newNetMessager
+	<*> newRemoteControl
 
 runAssistant :: AssistantData -> Assistant a -> IO a
 runAssistant d a = runReaderT (mkAssistant a) d

Assistant/RemoteControl.hs

@@ -0,0 +1,21 @@
+{- git-annex assistant RemoteDaemon control
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.RemoteControl (
+	sendRemoteControl,
+	RemoteDaemon.Consumed(..)
+) where
+
+import Assistant.Common
+import qualified RemoteDaemon.Types as RemoteDaemon
+
+import Control.Concurrent
+
+sendRemoteControl :: RemoteDaemon.Consumed -> Assistant ()
+sendRemoteControl msg = do
+	clicker <- getAssistant remoteControl
+	liftIO $ writeChan clicker msg

Assistant/Sync.hs

@@ -15,6 +15,7 @@ import Assistant.Alert
 import Assistant.Alert.Utility
 import Assistant.DaemonStatus
 import Assistant.ScanRemotes
+import Assistant.RemoteControl
 import qualified Command.Sync
 import Utility.Parallel
 import qualified Git
@@ -258,6 +259,7 @@ changeSyncable Nothing enable = do
 changeSyncable (Just r) True = do
 	liftAnnex $ changeSyncFlag r True
 	syncRemote r
+	sendRemoteControl RELOAD
 changeSyncable (Just r) False = do
 	liftAnnex $ changeSyncFlag r False
 	updateSyncRemotes

Assistant/Threads/NetWatcher.hs

@@ -15,6 +15,7 @@ import Assistant.Sync
 import Utility.ThreadScheduler
 import qualified Types.Remote as Remote
 import Assistant.DaemonStatus
+import Assistant.RemoteControl
 import Utility.NotificationBroadcaster
 
 #if WITH_DBUS
@@ -44,8 +45,9 @@ netWatcherThread = thread noop
  - while (despite the local network staying up), are synced with
  - periodically.
  -
- - Note that it does not call notifyNetMessagerRestart, because
- - it doesn't know that the network has changed.
+ - Note that it does not call notifyNetMessagerRestart, or
+ - signal the RemoteControl, because it doesn't know that the
+ - network has changed.
  -}
 netWatcherFallbackThread :: NamedThread
 netWatcherFallbackThread = namedThread "NetWatcherFallback" $
@@ -69,8 +71,10 @@ dbusThread = do
 		)
 	handleconn = do
 		debug ["detected network connection"]
+		sendRemoteControl PAUSE
 		notifyNetMessagerRestart
 		handleConnection
+		sendRemoteControl RESUME
 	onerr e _ = do
 		liftAnnex $
 			warning $ "lost dbus connection; falling back to polling (" ++ show e ++ ")"

Assistant/Threads/RemoteControl.hs

@@ -0,0 +1,80 @@
+{- git-annex assistant communication with remotedaemon
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.Threads.RemoteControl where
+
+import Assistant.Common
+import RemoteDaemon.Types
+import Config.Files
+import Utility.Batch
+import Utility.SimpleProtocol
+import Assistant.Alert
+import Assistant.Alert.Utility
+import Assistant.DaemonStatus
+
+import Control.Concurrent
+import Control.Concurrent.Async
+import System.Process (std_in, std_out)
+import qualified Data.Map as M
+
+remoteControlThread :: NamedThread
+remoteControlThread = namedThread "RemoteControl" $ do
+	program <- liftIO readProgramFile
+	(cmd, params) <- liftIO $ toBatchCommand
+		(program, [Param "remotedaemon"])
+	let p = proc cmd (toCommand params)
+	(Just toh, Just fromh, _, pid) <- liftIO $ createProcess p
+		{ std_in = CreatePipe
+		, std_out = CreatePipe
+		}
+	
+	controller <- asIO $ remoteControllerThread toh
+	responder <- asIO $ remoteResponderThread fromh
+
+	-- run controller and responder until the remotedaemon dies
+	liftIO $ do
+		void $ controller `concurrently` responder
+		forceSuccessProcess p pid
+
+-- feed from the remoteControl channel into the remotedaemon
+remoteControllerThread :: Handle -> Assistant ()
+remoteControllerThread toh = do
+	clicker <- getAssistant remoteControl
+	liftIO $ forever $ do
+		msg <- readChan clicker
+		hPutStrLn toh $ unwords $ formatMessage msg
+		hFlush toh
+
+-- read status messages emitted by the remotedaemon and handle them
+remoteResponderThread :: Handle -> Assistant ()
+remoteResponderThread fromh = go M.empty
+  where
+	go syncalerts = do
+		l <- liftIO $ hGetLine fromh
+		case parseMessage l of
+			Just (CONNECTED _rn) -> do
+				go syncalerts
+			Just (DISCONNECTED _rn) -> do
+				go syncalerts
+			Just (SYNCING rn)
+				| M.member rn syncalerts -> go syncalerts
+				| otherwise -> do
+					i <- addAlert $ syncAlert' [rn]
+					go (M.insert rn i syncalerts)
+			Just (DONESYNCING status rn) ->
+				case M.lookup rn syncalerts of
+					Nothing -> go syncalerts
+					Just i -> do
+						let (succeeded, failed) = if status
+							then ([rn], [])
+							else ([], [rn])
+						updateAlertMap $ mergeAlert i $
+							syncResultAlert' succeeded failed
+						go (M.delete rn syncalerts)
+			Nothing -> do
+				debug ["protocol error from remotedaemon: ", l]
+				go syncalerts

Assistant/Types/RemoteControl.hs

@@ -0,0 +1,16 @@
+{- git-annex assistant RemoteDaemon control
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.Types.RemoteControl where
+
+import qualified RemoteDaemon.Types as RemoteDaemon
+import Control.Concurrent
+
+type RemoteControl = Chan RemoteDaemon.Consumed
+
+newRemoteControl :: IO RemoteControl
+newRemoteControl = newChan

debian/changelog

@@ -2,6 +2,10 @@ git-annex (5.20140406) UNRELEASED; urgency=medium
 
   * importfeed: Filename template can now contain an itempubdate variable.
     Needs feed 0.3.9.2.
+  * assistant: Now detects immediately when other repositories push
+    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.
 
  -- Joey Hess <joeyh@debian.org>  Mon, 07 Apr 2014 16:22:02 -0400
 

doc/design/assistant/telehash.mdwn

@@ -83,7 +83,7 @@ Advantages:
   exchange protocols implemented in such a daemon to allow SSH-less
   transfers.
 * Security holes in telehash would not need to compromise the entire
-  git-annex. gathd could be sandboxed in one way or another.
+  git-annex. daemon could be sandboxed in one way or another.
 
 Disadvantages:
 

doc/design/git-remote-daemon.mdwn

@@ -167,6 +167,8 @@ TODO:
   reconnect, but needs to avoid bad behavior (ie, constant reconnect
   attempts.)
 * Detect if old system had a too old git-annex-shell and avoid bad behavior
+* CONNECTED and DISCONNECTED are not wired into any webapp UI; could be
+  used to show an icon when a ssh remote is available
 
 ## telehash