add remote fsck interface

Currently only implemented for local git remotes. May try to add support
to git-annex-shell for ssh remotes later. Could concevably also be
supported by some special remote, although that seems unlikely.

Cronner user this when available, and when not falls back to
fsck --fast --from remote

git annex fsck --from does not itself use this interface.
To do so, I would need to pass --fast and all other options that influence
fsck on to the git annex fsck that it runs inside the remote. And that
seems like a lot of work for a result that would be no better than
cd remote; git annex fsck
This may need to be revisited if git-annex-shell gets support, since it
may be the case that the user cannot ssh to the server to run git-annex
fsck there, but can run git-annex-shell there.

This commit was sponsored by Damien Diederen.

10 files changed, 25 insertions, 0 deletions

diff --git a/Remote/Bup.hs b/Remote/Bup.hs
index 1acb35c82..d2c3038af 100644
--- a/Remote/Bup.hs
+++ b/Remote/Bup.hs
@@ -63,6 +63,7 @@ gen r u c gc = do
 		, hasKey = checkPresent r bupr'
 		, hasKeyCheap = bupLocal buprepo
 		, whereisKey = Nothing
+		, remoteFsck = Nothing
 		, config = c
 		, repo = r
 		, gitconfig = gc
diff --git a/Remote/Directory.hs b/Remote/Directory.hs
index a4bd22829..1a4dbf45c 100644
--- a/Remote/Directory.hs
+++ b/Remote/Directory.hs
@@ -54,6 +54,7 @@ gen r u c gc = do
 			hasKey = checkPresent dir chunksize,
 			hasKeyCheap = True,
 			whereisKey = Nothing,
+			remoteFsck = Nothing,
 			config = M.empty,
 			repo = r,
 			gitconfig = gc,
diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs
index 8ba640bac..89d2c431f 100644
--- a/Remote/GCrypt.hs
+++ b/Remote/GCrypt.hs
@@ -107,6 +107,7 @@ gen' r u c gc = do
 		, hasKey = checkPresent this rsyncopts
 		, hasKeyCheap = repoCheap r
 		, whereisKey = Nothing
+		, remoteFsck = Nothing
 		, config = M.empty
 		, localpath = localpathCalc r
 		, repo = r
diff --git a/Remote/Git.hs b/Remote/Git.hs
index 4cdedd064..be63de804 100644
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -42,10 +42,12 @@ import Utility.Metered
 #ifndef mingw32_HOST_OS
 import Utility.CopyFile
 #endif
+import Utility.Batch
 import Remote.Helper.Git
 import Remote.Helper.Messages
 import qualified Remote.Helper.Ssh as Ssh
 import qualified Remote.GCrypt
+import Config.Files
 
 import Control.Concurrent
 import Control.Concurrent.MSampleVar
@@ -111,6 +113,9 @@ gen r u c gc
 			, hasKey = inAnnex r
 			, hasKeyCheap = repoCheap r
 			, whereisKey = Nothing
+			, remoteFsck = if Git.repoIsUrl r
+				then Nothing
+				else Just $ fsckOnRemote r
 			, config = M.empty
 			, localpath = localpathCalc r
 			, repo = r
@@ -396,6 +401,17 @@ copyToRemote r key file p
 							(\d -> rsyncOrCopyFile params object d p)
 			)
 
+fsckOnRemote :: Git.Repo -> [CommandParam] -> Annex (IO Bool)
+fsckOnRemote r params
+	| Git.repoIsUrl r = return $ do
+		program <- readProgramFile
+		batchCommand program $ Param "fsck" : params
+	| otherwise = do
+		s <- Ssh.git_annex_shell r "fsck" params []
+		return $ case s of
+			Nothing -> return False
+			Just (c, ps) -> batchCommand c ps
+
 {- Runs an action on a local repository inexpensively, by making an annex
  - monad using that repository. -}
 onLocal :: Git.Repo -> Annex a -> IO a
diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs
index 3726c7083..5cd224d19 100644
--- a/Remote/Glacier.hs
+++ b/Remote/Glacier.hs
@@ -59,6 +59,7 @@ gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost
 			hasKey = checkPresent this,
 			hasKeyCheap = False,
 			whereisKey = Nothing,
+			remoteFsck = Nothing,
 			config = c,
 			repo = r,
 			gitconfig = gc,
diff --git a/Remote/Hook.hs b/Remote/Hook.hs
index 21d02c19d..88c70e0cf 100644
--- a/Remote/Hook.hs
+++ b/Remote/Hook.hs
@@ -52,6 +52,7 @@ gen r u c gc = do
 			hasKey = checkPresent r hooktype,
 			hasKeyCheap = False,
 			whereisKey = Nothing,
+			remoteFsck = Nothing,
 			config = M.empty,
 			localpath = Nothing,
 			repo = r,
diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs
index 673f7661f..b0ef318d3 100644
--- a/Remote/Rsync.hs
+++ b/Remote/Rsync.hs
@@ -79,6 +79,7 @@ gen r u c gc = do
 			, hasKey = checkPresent r o
 			, hasKeyCheap = False
 			, whereisKey = Nothing
+			, remoteFsck = Nothing
 			, config = M.empty
 			, repo = r
 			, gitconfig = gc
diff --git a/Remote/S3.hs b/Remote/S3.hs
index 67d87df50..e9c62eb25 100644
--- a/Remote/S3.hs
+++ b/Remote/S3.hs
@@ -62,6 +62,7 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
 			hasKey = checkPresent this,
 			hasKeyCheap = False,
 			whereisKey = Nothing,
+			remoteFsck = Nothing,
 			config = c,
 			repo = r,
 			gitconfig = gc,
diff --git a/Remote/Web.hs b/Remote/Web.hs
index ce420b24d..23de73c27 100644
--- a/Remote/Web.hs
+++ b/Remote/Web.hs
@@ -56,6 +56,7 @@ gen r _ _ gc =
 		hasKey = checkKey,
 		hasKeyCheap = False,
 		whereisKey = Just getUrls,
+		remoteFsck = Nothing,
 		config = M.empty,
 		gitconfig = gc,
 		localpath = Nothing,
diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs
index ef4a5ed58..c65118efb 100644
--- a/Remote/WebDAV.hs
+++ b/Remote/WebDAV.hs
@@ -65,6 +65,7 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
 			hasKey = checkPresent this,
 			hasKeyCheap = False,
 			whereisKey = Nothing,
+			remoteFsck = Nothing,
 			config = c,
 			repo = r,
 			gitconfig = gc,