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.

1 files changed, 80 insertions, 0 deletions

diff --git a/Assistant/Threads/RemoteControl.hs b/Assistant/Threads/RemoteControl.hs
new file mode 100644
index 000000000..b67b0e07f
--- /dev/null
+++ b/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