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.)

Annex/Content.hs

@@ -7,8 +7,8 @@
 
 module Annex.Content (
 	inAnnex,
-	lockExclusive,
+	inAnnexSafe,
-	lockShared,
+	lockContent,
 	calcGitLink,
 	logStatus,
 	getViaTmp,
@@ -36,22 +36,34 @@ import Types.Key
 import Utility.DataUnits
 import Config
 
-{- Checks if a given key is currently present in the gitAnnexLocation. -}
+{- Checks if a given key's content is currently present. -}
 inAnnex :: Key -> Annex Bool
-inAnnex key = do
+inAnnex = inAnnex' doesFileExist
+inAnnex' :: (FilePath -> IO a) -> Key -> Annex a
+inAnnex' a key = do
 	whenM (fromRepo Git.repoIsUrl) $
 		error "inAnnex cannot check remote repo"
-	inRepo $ doesFileExist . gitAnnexLocation key
+	inRepo $ a . gitAnnexLocation key
+
+{- A safer check; the key's content must not only be present, but
+ - is not in the process of being removed. -}
+inAnnexSafe :: Key -> Annex (Maybe Bool)
+inAnnexSafe = inAnnex' $ \f -> do
+	e <- doesFileExist f
+	if e
+		then do
+			locked <- testlock f
+			if locked
+				then return Nothing
+				else return $ Just True
+		else return $ Just False
+	where
+		testlock f = return False -- TODO
 
 {- Content is exclusively locked to indicate that it's in the process of
  - being removed. -}
-lockExclusive :: Key -> Annex a -> Annex a
+lockContent :: Key -> Annex a -> Annex a
-lockExclusive key a = a -- TODO
+lockContent key a = a -- TODO
-
-{- Things that rely on content being present can take a shared lock to
- - avoid it vanishing from under them. -}
-lockShared :: Key -> Annex a -> Annex a
-lockShared key a = a -- TODO
 
 {- Calculates the relative path to use to link a file to a key. -}
 calcGitLink :: FilePath -> Key -> Annex FilePath

Command/Drop.hs

@@ -52,7 +52,7 @@ startRemote file numcopies key remote = do
 	next $ performRemote key numcopies remote
 
 performLocal :: Key -> Maybe Int -> CommandPerform
-performLocal key numcopies = lockExclusive key $ do
+performLocal key numcopies = lockContent key $ do
 	(remotes, trusteduuids) <- Remote.keyPossibilitiesTrusted key
 	untrusteduuids <- trustGet UnTrusted
 	let tocheck = Remote.remotesWithoutUUID remotes (trusteduuids++untrusteduuids)
@@ -64,7 +64,7 @@ performLocal key numcopies = lockExclusive key $ do
 		else stop
 
 performRemote :: Key -> Maybe Int -> Remote.Remote Annex -> CommandPerform
-performRemote key numcopies remote = lockExclusive key $ do
+performRemote key numcopies remote = lockContent key $ do
 	-- Filter the remote it's being dropped from out of the lists of
 	-- places assumed to have the key, and places to check.
 	-- When the local repo has the key, that's one additional copy.
@@ -95,7 +95,7 @@ cleanupRemote key remote ok = do
 	-- better safe than sorry: assume the remote dropped the key
 	-- even if it seemed to fail; the failure could have occurred
 	-- after it really dropped it
-	Remote.remoteHasKey remote key False
+	Remote.logStatus remote key False
 	return ok
 
 {- Checks specified remotes to verify that enough copies of a key exist to

Command/InAnnex.hs

@@ -19,8 +19,9 @@ seek :: [CommandSeek]
 seek = [withKeys start]
 
 start :: Key -> CommandStart
-start key = do
+start key = inAnnexSafe key >>= dispatch
-	present <- inAnnex key
+	where
-	if present
+		dispatch (Just True) = stop
-		then stop
+		dispatch (Just False) = exit 1
-		else liftIO exitFailure
+		dispatch Nothing = exit 100
+		exit n = liftIO $ exitWith $ ExitFailure n

Command/Move.hs

@@ -82,7 +82,7 @@ toPerform dest move key = moveLock move key $ do
 		else Remote.hasKey dest key
 	case isthere of
 		Left err -> do
-			showNote $ show err
+			showNote $ err
 			stop
 		Right False -> do
 			showAction $ "to " ++ Remote.name dest
@@ -96,7 +96,7 @@ toPerform dest move key = moveLock move key $ do
 		Right True -> finish
 	where
 		finish = do
-			Remote.remoteHasKey dest key True
+			Remote.logStatus dest key True
 			if move
 				then do
 					whenM (inAnnex key) $ removeAnnex key
@@ -137,5 +137,5 @@ fromPerform src move key = moveLock move key $ do
 {- Locks a key in order for it to be moved.
  - No lock is needed when a key is being copied. -}
 moveLock :: Bool -> Key -> Annex a -> Annex a
-moveLock True key a = lockExclusive key a
+moveLock True key a = lockContent key a
 moveLock False _ a = a

Remote.hs

@@ -26,7 +26,7 @@ module Remote (
 	showTriedRemotes,
 	showLocations,
 	forceTrust,
-	remoteHasKey
+	logStatus
 ) where
 
 import qualified Data.Map as M
@@ -230,7 +230,7 @@ forceTrust level remotename = do
  - in the local repo, not on the remote. The process of transferring the
  - key to the remote, or removing the key from it *may* log the change
  - on the remote, but this cannot always be relied on. -}
-remoteHasKey :: Remote Annex -> Key -> Bool -> Annex ()
+logStatus :: Remote Annex -> Key -> Bool -> Annex ()
-remoteHasKey remote key present	= logChange key (uuid remote) status
+logStatus remote key present = logChange key (uuid remote) status
 	where
 		status = if present then InfoPresent else InfoMissing

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 ()

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 :: FilePath -> Key -> Annex (Either String Bool)
-checkPresent d k = liftIO $ try $ doesFileExist (dirKey d k)
+checkPresent d k = dispatch <$> check
+	where
+		check = liftIO $ try $ doesFileExist (dirKey d k)
+		dispatch (Left e) = Left $ show e
+		dispatch (Right v) = Right v

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" 
+			onRemote r (check, unknown) "inannex" [Param (show key)]
-				[Param (show key)]
+			where
-			return $ Right inannex
+				check c p = dispatch <$> safeSystem c p
-		checkhttp = Url.exists $ keyUrl r key
+				dispatch ExitSuccess = Right True
-		safely a = liftIO (try a ::IO (Either IOException Bool))
+				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. -}

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

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

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

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

Types/Remote.hs

@@ -9,7 +9,6 @@
 
 module Types.Remote where
 
-import Control.Exception
 import Data.Map as M
 import Data.Ord
 
@@ -46,8 +45,8 @@ data Remote a = Remote {
 	-- removes a key's contents
 	removeKey :: Key -> a Bool,
 	-- Checks if a key is present in the remote; if the remote
-	-- cannot be accessed returns a Left error.
+	-- cannot be accessed returns a Left error message.
-	hasKey :: Key -> a (Either IOException Bool),
+	hasKey :: Key -> a (Either String Bool),
 	-- Some remotes can check hasKey without an expensive network
 	-- operation.
 	hasKeyCheap :: Bool,

doc/bugs/cyclic_drop.mdwn

@@ -16,8 +16,8 @@ content and git-annex should refuse to do anything.
 
 Then when checking inannex, try to take a shared lock. Note that to avoid
 deadlock, this must be a nonblocking lock. If it fails, the status of
-the content is unknown, so inannex should fail. Note that this needs to be
+the content is unknown, so inannex should fail. Note that this failure 
-distinguishable from "not in annex".
+needs to be distinguishable from "not in annex".
 
 > Thinking about these lock files, this would be a lot more files, 
 > and would possibly break some assumptions that everything in
@@ -52,6 +52,11 @@ The movee removes its copy.
 So move --to needs to take the content lock on start. Then the inannex
 will fail.
 
+This is why it's important for inannex to fail in a way that is
+distinguishable from "not in annex". Otherwise, move --to
+would see the cycle as the remote not having content, and try to
+redundantly send it, drop it locally, and still race.
+
 -- 
 
 move --from is similar. Consider a case where both the local and the remote