safer inannex checking

git-annex-shell inannex now returns always 0, 1, or 100 (the last when
it's unclear if content is currently in the index due to it currently being
moved or dropped).

(Actual locking code still not yet written.)

7 files changed, 45 insertions, 19 deletions

diff --git a/Remote/Bup.hs b/Remote/Bup.hs
index b8d7cd317..866d4b42d 100644
--- a/Remote/Bup.hs
+++ b/Remote/Bup.hs
@@ -139,17 +139,21 @@ remove _ = do
  - in a bup repository. One way it to check if the git repository has
  - a branch matching the name (as created by bup split -n).
  -}
-checkPresent :: Git.Repo -> Git.Repo -> Key -> Annex (Either IOException Bool)
+checkPresent :: Git.Repo -> Git.Repo -> Key -> Annex (Either String Bool)
 checkPresent r bupr k
 	| Git.repoIsUrl bupr = do
 		showAction $ "checking " ++ Git.repoDescribe r
 		ok <- onBupRemote bupr boolSystem "git" params
 		return $ Right ok
-	| otherwise = liftIO $ try $ boolSystem "git" $ Git.gitCommandLine params bupr
+	| otherwise = dispatch <$> localcheck
 	where
 		params = 
 			[ Params "show-ref --quiet --verify"
 			, Param $ "refs/heads/" ++ show k]
+		localcheck = liftIO $ try $
+			boolSystem "git" $ Git.gitCommandLine params bupr
+		dispatch (Left e) = Left $ show e
+		dispatch (Right v) = Right v
 
 {- Store UUID in the annex.uuid setting of the bup repository. -}
 storeBupUUID :: UUID -> BupRepo -> Annex ()
diff --git a/Remote/Directory.hs b/Remote/Directory.hs
index 8e306e228..6d3a5da7d 100644
--- a/Remote/Directory.hs
+++ b/Remote/Directory.hs
@@ -114,5 +114,9 @@ remove d k = liftIO $ catchBool $ do
 		file = dirKey d k
 		dir = parentDir file
 
-checkPresent :: FilePath -> Key -> Annex (Either IOException Bool)
-checkPresent d k = liftIO $ try $ doesFileExist (dirKey d k)
+checkPresent :: FilePath -> Key -> Annex (Either String Bool)
+checkPresent d k = dispatch <$> check
+	where
+		check = liftIO $ try $ doesFileExist (dirKey d k)
+		dispatch (Left e) = Left $ show e
+		dispatch (Right v) = Right v
diff --git a/Remote/Git.hs b/Remote/Git.hs
index 75f0ac757..b63a8f124 100644
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -125,22 +125,38 @@ tryGitConfigRead r
 				else old : exchange ls new
 
 {- Checks if a given remote has the content for a key inAnnex.
- - If the remote cannot be accessed, returns a Left error.
+ - If the remote cannot be accessed, or if it cannot determine
+ - whether it has the content, returns a Left error message.
  -}
-inAnnex :: Git.Repo -> Key -> Annex (Either IOException Bool)
+inAnnex :: Git.Repo -> Key -> Annex (Either String Bool)
 inAnnex r key
-	| Git.repoIsHttp r = safely checkhttp
+	| Git.repoIsHttp r = checkhttp
 	| Git.repoIsUrl r = checkremote
-	| otherwise = safely checklocal
+	| otherwise = checklocal
 	where
-		checklocal = onLocal r $ Annex.Content.inAnnex key
+		checkhttp = dispatch <$> check
+			where
+				check = safely $ Url.exists $ keyUrl r key
+				dispatch (Left e) = Left $ show e
+				dispatch (Right v) = Right v
 		checkremote = do
 			showAction $ "checking " ++ Git.repoDescribe r
-			inannex <- onRemote r (boolSystem, False) "inannex" 
-				[Param (show key)]
-			return $ Right inannex
-		checkhttp = Url.exists $ keyUrl r key
-		safely a = liftIO (try a ::IO (Either IOException Bool))
+			onRemote r (check, unknown) "inannex" [Param (show key)]
+			where
+				check c p = dispatch <$> safeSystem c p
+				dispatch ExitSuccess = Right True
+				dispatch (ExitFailure 1) = Right False
+				dispatch _ = unknown
+		checklocal = dispatch <$> check
+			where
+				check = safely $ onLocal r $
+					Annex.Content.inAnnexSafe key
+				dispatch (Left e) = Left $ show e
+				dispatch (Right (Just b)) = Right b
+				dispatch (Right Nothing) = unknown
+		safely :: IO a -> Annex (Either IOException a)
+		safely a = liftIO $ try a
+		unknown = Left $ "unable to check " ++ Git.repoDescribe r
 
 {- Runs an action on a local repository inexpensively, by making an annex
  - monad using that repository. -}
diff --git a/Remote/Hook.hs b/Remote/Hook.hs
index 06568a3cb..9f9250e41 100644
--- a/Remote/Hook.hs
+++ b/Remote/Hook.hs
@@ -119,14 +119,16 @@ retrieveEncrypted h (cipher, enck) f = withTmp enck $ \tmp ->
 remove :: String -> Key -> Annex Bool
 remove h k = runHook h "remove" k Nothing $ return True
 
-checkPresent :: Git.Repo -> String -> Key -> Annex (Either IOException Bool)
+checkPresent :: Git.Repo -> String -> Key -> Annex (Either String Bool)
 checkPresent r h k = do
 	showAction $ "checking " ++ Git.repoDescribe r
 	v <- lookupHook h "checkpresent"
-	liftIO (try (check v) ::IO (Either IOException Bool))
+	dispatch <$> liftIO (try (check v) ::IO (Either IOException Bool))
 	where
 		findkey s = show k `elem` lines s
 		env = hookEnv k Nothing
+		dispatch (Left e) = Left $ show e
+		dispatch (Right v) = Right v
 		check Nothing = error "checkpresent hook misconfigured"
 		check (Just hook) = do
 			(frompipe, topipe) <- createPipe
diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs
index 0dfad7293..54834be13 100644
--- a/Remote/Rsync.hs
+++ b/Remote/Rsync.hs
@@ -128,7 +128,7 @@ remove o k = withRsyncScratchDir $ \tmp -> do
 		, Param $ rsyncKeyDir o k
 		]
 
-checkPresent :: Git.Repo -> RsyncOpts -> Key -> Annex (Either IOException Bool)
+checkPresent :: Git.Repo -> RsyncOpts -> Key -> Annex (Either String Bool)
 checkPresent r o k = do
 	showAction $ "checking " ++ Git.repoDescribe r
 	-- note: Does not currently differnetiate between rsync failing
diff --git a/Remote/S3real.hs b/Remote/S3real.hs
index b201b5aad..29117b3a4 100644
--- a/Remote/S3real.hs
+++ b/Remote/S3real.hs
@@ -172,7 +172,7 @@ remove r k = s3Action r False $ \(conn, bucket) -> do
 	res <- liftIO $ deleteObject conn $ bucketKey r bucket k
 	s3Bool res
 
-checkPresent :: Remote Annex -> Key -> Annex (Either IOException Bool)
+checkPresent :: Remote Annex -> Key -> Annex (Either String Bool)
 checkPresent r k = s3Action r noconn $ \(conn, bucket) -> do
 	showAction $ "checking " ++ name r
 	res <- liftIO $ getObjectInfo conn $ bucketKey r bucket k
diff --git a/Remote/Web.hs b/Remote/Web.hs
index da7f38472..64fcd51aa 100644
--- a/Remote/Web.hs
+++ b/Remote/Web.hs
@@ -64,7 +64,7 @@ dropKey _ = do
 	warning "removal from web not supported"
 	return False
 
-checkKey :: Key -> Annex (Either IOException Bool)
+checkKey :: Key -> Annex (Either String Bool)
 checkKey key = do
 	us <- getUrls key
 	if null us