remotedaemon: Fixed support for notifications of changes to gcrypt remotes, which was never tested and didn't quite work before.

3 files changed, 46 insertions, 17 deletions

diff --git a/RemoteDaemon/Transport.hs b/RemoteDaemon/Transport.hs
index 8297bb3b0..0e2040d1f 100644
--- a/RemoteDaemon/Transport.hs
+++ b/RemoteDaemon/Transport.hs
@@ -9,6 +9,7 @@ module RemoteDaemon.Transport where
 
 import RemoteDaemon.Types
 import qualified RemoteDaemon.Transport.Ssh
+import qualified RemoteDaemon.Transport.GCrypt
 import qualified Git.GCrypt
 
 import qualified Data.Map as M
@@ -19,5 +20,5 @@ type TransportScheme = String
 remoteTransports :: M.Map TransportScheme Transport
 remoteTransports = M.fromList
 	[ ("ssh:", RemoteDaemon.Transport.Ssh.transport)
-	, (Git.GCrypt.urlScheme, RemoteDaemon.Transport.Ssh.transport)
+	, (Git.GCrypt.urlScheme, RemoteDaemon.Transport.GCrypt.transport)
 	]
diff --git a/RemoteDaemon/Transport/GCrypt.hs b/RemoteDaemon/Transport/GCrypt.hs
new file mode 100644
index 000000000..53bcfec32
--- /dev/null
+++ b/RemoteDaemon/Transport/GCrypt.hs
@@ -0,0 +1,27 @@
+{- git-remote-daemon, gcrypt transport
+ -
+ - Copyright 2015 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module RemoteDaemon.Transport.GCrypt (transport) where
+
+import Common.Annex
+import RemoteDaemon.Types
+import RemoteDaemon.Common
+import RemoteDaemon.Transport.Ssh (transportUsingCmd)
+import Git.GCrypt
+import Remote.Helper.Ssh
+import Remote.GCrypt (accessShellConfig)
+
+transport :: Transport
+transport rr@(RemoteRepo r gc) url h@(TransportHandle g _) ichan ochan
+	| accessShellConfig gc = do
+		r' <- encryptedRemote g r
+		v <- liftAnnex h $ git_annex_shell r' "notifychanges" [] []
+		case v of
+			Nothing -> noop
+			Just (cmd, params) -> 
+				transportUsingCmd cmd params rr url h ichan ochan
+	| otherwise = noop
diff --git a/RemoteDaemon/Transport/Ssh.hs b/RemoteDaemon/Transport/Ssh.hs
index bdf4f54f0..f441913c9 100644
--- a/RemoteDaemon/Transport/Ssh.hs
+++ b/RemoteDaemon/Transport/Ssh.hs
@@ -5,7 +5,7 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
-module RemoteDaemon.Transport.Ssh (transport) where
+module RemoteDaemon.Transport.Ssh (transport, transportUsingCmd) where
 
 import Common.Annex
 import Annex.Ssh
@@ -22,23 +22,24 @@ import Control.Concurrent.STM
 import Control.Concurrent.Async
 
 transport :: Transport
-transport rr@(RemoteRepo r gc) url h@(TransportHandle g s) ichan ochan = do
+transport rr@(RemoteRepo r _) url h ichan ochan = do
+	v <- liftAnnex h $ git_annex_shell r "notifychanges" [] []
+	case v of
+		Nothing -> noop
+		Just (cmd, params) -> transportUsingCmd cmd params rr url h ichan ochan
+
+transportUsingCmd :: FilePath -> [CommandParam] -> Transport
+transportUsingCmd cmd params rr@(RemoteRepo r gc) url h@(TransportHandle g s) ichan ochan = do
 	-- enable ssh connection caching wherever inLocalRepo is called
 	g' <- liftAnnex h $ sshOptionsTo r gc g
-	transport' rr url (TransportHandle g' s) ichan ochan
+	let transporthandle = TransportHandle g' s
+	transportUsingCmd' cmd params rr url transporthandle ichan ochan
 
-transport' :: Transport
-transport' (RemoteRepo r _) url transporthandle ichan ochan = do
-
-	v <- liftAnnex transporthandle $ git_annex_shell r "notifychanges" [] []
-	case v of
-		Nothing -> noop
-		Just (cmd, params) -> robustly 1 $
-			connect cmd (toCommand params)
-  where
-	connect cmd params = do
+transportUsingCmd' :: FilePath -> [CommandParam] -> Transport
+transportUsingCmd' cmd params (RemoteRepo r _) url transporthandle ichan ochan =
+	robustly 1 $ do
 		(Just toh, Just fromh, Just errh, pid) <-
-			createProcess (proc cmd params)
+			createProcess (proc cmd (toCommand params))
 			{ std_in = CreatePipe
 			, std_out = CreatePipe
 			, std_err = CreatePipe
@@ -57,7 +58,7 @@ transport' (RemoteRepo r _) url transporthandle ichan ochan = do
 		void $ waitForProcess pid
 
 		return $ either (either id id) id status
-
+  where
 	send msg = atomically $ writeTChan ochan msg
 
 	fetch = do
@@ -106,7 +107,7 @@ transport' (RemoteRepo r _) url transporthandle ichan ochan = do
 
 data Status = Stopping | ConnectionClosed
 
-{- Make connection robustly, with exponentioal backoff on failure. -}
+{- Make connection robustly, with exponential backoff on failure. -}
 robustly :: Int -> IO Status -> IO ()
 robustly backoff a = caught =<< catchDefaultIO ConnectionClosed a
   where