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

7 files changed, 83 insertions, 25 deletions

diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs
index 54c90536f..c27519825 100644
--- a/Remote/GCrypt.hs
+++ b/Remote/GCrypt.hs
@@ -10,7 +10,8 @@ module Remote.GCrypt (
 	chainGen,
 	getGCryptUUID,
 	coreGCryptId,
-	setupRepo
+	setupRepo,
+	accessShellConfig,
 ) where
 
 import qualified Data.Map as M
@@ -265,17 +266,19 @@ setupRepo gcryptid r
 
 	denyNonFastForwards = "receive.denyNonFastForwards"
 
-isShell :: Remote -> Bool
-isShell r = case method of
+accessShell :: Remote -> Bool
+accessShell = accessShellConfig . gitconfig
+
+accessShellConfig :: RemoteGitConfig -> Bool
+accessShellConfig c = case method of
 	AccessShell -> True
 	_ -> False
   where
-	method = toAccessMethod $ fromMaybe "" $
-		remoteAnnexGCrypt $ gitconfig r
+	method = toAccessMethod $ fromMaybe "" $ remoteAnnexGCrypt c
 
 shellOrRsync :: Remote -> Annex a -> Annex a -> Annex a
 shellOrRsync r ashell arsync
-	| isShell r = ashell
+	| accessShell r = ashell
 	| otherwise = arsync
 
 {- Configure gcrypt to use the same list of keyids that
@@ -319,7 +322,7 @@ store r rsyncopts
 			let destdir = parentDir $ gCryptLocation r k
 			Remote.Directory.finalizeStoreGeneric tmpdir destdir
 			return True
-	| Git.repoIsSsh (repo r) = if isShell r
+	| Git.repoIsSsh (repo r) = if accessShell r
 		then fileStorer $ \k f p -> Ssh.rsyncHelper (Just p)
 			=<< Ssh.rsyncParamsRemote False r Upload k f Nothing
 		else fileStorer $ Remote.Rsync.store rsyncopts
@@ -330,7 +333,7 @@ retrieve r rsyncopts
 	| not $ Git.repoIsUrl (repo r) = byteRetriever $ \k sink ->
 		guardUsable (repo r) (return False) $
 			sink =<< liftIO (L.readFile $ gCryptLocation r k)
-	| Git.repoIsSsh (repo r) = if isShell r
+	| Git.repoIsSsh (repo r) = if accessShell r
 		then fileRetriever $ \f k p ->
 			unlessM (Ssh.rsyncHelper (Just p) =<< Ssh.rsyncParamsRemote False r Download k f Nothing) $
 				error "rsync failed"
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
diff --git a/debian/changelog b/debian/changelog
index d26360ede..098b50781 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -38,6 +38,8 @@ git-annex (5.2015022) UNRELEASED; urgency=medium
   * fromkey --force: Skip test that the key has its content in the annex.
   * fromkey: Add stdin mode.
   * registerurl: New plumbing command for mass-adding urls to keys.
+  * remotedaemon: Fixed support for notifications of changes to gcrypt
+    remotes, which was never tested and didn't quite work before.
 
  -- Joey Hess <id@joeyh.name>  Thu, 19 Feb 2015 14:16:03 -0400
 
diff --git a/doc/forum/Verification/comment_4_eb4d936a9bd577f58483b278ae5dc5f6._comment b/doc/forum/Verification/comment_4_eb4d936a9bd577f58483b278ae5dc5f6._comment
new file mode 100644
index 000000000..f1d04e83f
--- /dev/null
+++ b/doc/forum/Verification/comment_4_eb4d936a9bd577f58483b278ae5dc5f6._comment
@@ -0,0 +1,15 @@
+[[!comment format=mdwn
+ username="joey"
+ subject="""comment 4"""
+ date="2015-03-16T18:36:45Z"
+ content="""
+You can use `git annex fsck` to verify your repository contents.
+If you want to verify a local repository, the best thing to do is
+to run `git annex fsck` there. If you cannot do that, you can use
+`git annex fsck --from remoterepo --fast` to verify a remote. If you leave
+off the --fast it will download all file contents to completely verify
+them.
+
+I suggest you read git-annex's documentation, there is plenty of it about
+using git-annex fsck to verify repositories.
+"""]]
diff --git a/doc/forum/Verification/comment_5_c327c72ceced27920681d5f93bc256c8._comment b/doc/forum/Verification/comment_5_c327c72ceced27920681d5f93bc256c8._comment
new file mode 100644
index 000000000..e07a57254
--- /dev/null
+++ b/doc/forum/Verification/comment_5_c327c72ceced27920681d5f93bc256c8._comment
@@ -0,0 +1,9 @@
+[[!comment format=mdwn
+ username="joey"
+ subject="""comment 5"""
+ date="2015-03-16T18:39:01Z"
+ content="""
+The lack of "live messaging" for gcrypt repos is a bug. I'm fixing
+it now and the next version of git-annex will have remotedaemon
+properly supporting gcrypt repos.
+"""]]