make getViaTmpFrom no longer update location log

All callers adjusted to update it themselves.

In Command.ReKey, and Command.SetKey, the cleanup action already did,
so it was updating the log twice before.

This fixes a bug when annex.stalldetection is set, as now
Command.Transferrer can skip updating the location log, and let it be
updated by the calling process.

Annex/Content.hs

@@ -227,12 +227,7 @@ getViaTmpFromDisk rsp v key af action = checkallowed $ do
 		else verification
 	if ok
 		then ifM (verifyKeyContent rsp v verification' key tmpfile)
-			( ifM (pruneTmpWorkDirBefore tmpfile (moveAnnex key af))
-				( do
-					logStatus key InfoPresent
-					return True
-				, return False
-				)
+			( pruneTmpWorkDirBefore tmpfile (moveAnnex key af)
 			, do
 				warning "verification of content failed"
 				-- The bad content is not retained, because

Annex/Transfer.hs

@@ -30,6 +30,7 @@ import Annex.Notification as X
 import Annex.Content
 import Annex.Perms
 import Annex.Action
+import Logs.Location
 import Utility.Metered
 import Utility.ThreadScheduler
 import Annex.LockPool
@@ -68,7 +69,7 @@ alwaysUpload u key f d a _witness = guardHaveUUID u $
 
 -- Download, supporting stall detection.
 download :: Remote -> Key -> AssociatedFile -> RetryDecider -> NotifyWitness -> Annex Bool
-download r key f d witness = stallDetection r >>= \case
+download r key f d witness = logStatusAfter key $ stallDetection r >>= \case
 	Nothing -> getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) key f $ \dest ->
 		download' (Remote.uuid r) key f d (go dest) witness
 	Just sd -> runTransferrer sd r key f d Download witness

Command/Multicast.hs

@@ -16,6 +16,7 @@ import Annex.WorkTree
 import Annex.Content
 import Annex.UUID
 import Annex.Perms
+import Logs.Location
 import Utility.FileMode
 #ifndef mingw32_HOST_OS
 import Creds
@@ -212,7 +213,7 @@ storeReceived f = do
 		Nothing -> do
 			warning $ "Received a file " ++ f ++ " that is not a git-annex key. Deleting this file."
 			liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f)
-		Just k -> void $
+		Just k -> void $ logStatusAfter k $
 			getViaTmpFromDisk RetrievalVerifiableKeysSecure AlwaysVerify k (AssociatedFile Nothing) $ \dest -> unVerified $
 				liftIO $ catchBoolIO $ do
 					rename f (fromRawFilePath dest)

Command/RecvKey.hs

@@ -13,6 +13,7 @@ import Annex.Action
 import Annex
 import Utility.Rsync
 import Types.Transfer
+import Logs.Location
 import Command.SendKey (fieldTransfer)
 import qualified CmdLine.GitAnnexShell.Fields as Fields
 
@@ -35,6 +36,7 @@ start (_, key) = fieldTransfer Download key $ \_p -> do
 	let rsp = RetrievalAllKeysSecure
 	ifM (getViaTmp rsp verify key (AssociatedFile Nothing) go)
 		( do
+			logStatus key InfoPresent
 			-- forcibly quit after receiving one key,
 			-- and shutdown cleanly
 			_ <- shutdown True

Command/TestRemote.hs

@@ -294,7 +294,7 @@ test runannex mkr mkk =
 		Just b -> case Types.Backend.verifyKeyContent b of
 			Nothing -> return True
 			Just verifier -> verifier k (serializeKey' k)
-	get r k = getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) $ \dest ->
+	get r k = logStatusAfter k $ getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) $ \dest ->
 		tryNonAsync (Remote.retrieveKeyFile r k (AssociatedFile Nothing) (fromRawFilePath dest) nullMeterUpdate) >>= \case
 			Right v -> return (True, v)
 			Left _ -> return (False, UnVerified)
@@ -368,13 +368,13 @@ testUnavailable runannex mkr mkk =
 	, check (`notElem` [Right True, Right False]) "checkPresent" $ \r k ->
 		Remote.checkPresent r k
 	, check (== Right False) "retrieveKeyFile" $ \r k ->
-		getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) $ \dest ->
+		logStatusAfter k $ getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) $ \dest ->
 			tryNonAsync (Remote.retrieveKeyFile r k (AssociatedFile Nothing) (fromRawFilePath dest) nullMeterUpdate) >>= \case
 				Right v -> return (True, v)
 				Left _ -> return (False, UnVerified)
 	, check (== Right False) "retrieveKeyFileCheap" $ \r k -> case Remote.retrieveKeyFileCheap r of
 		Nothing -> return False
-		Just a -> getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) $ \dest -> 
+		Just a -> logStatusAfter k $ getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) $ \dest -> 
 			unVerified $ isRight
 				<$> tryNonAsync (a k (AssociatedFile Nothing) (fromRawFilePath dest))
 	]

Command/TransferKey.hs

@@ -63,7 +63,7 @@ toPerform key file remote = go Upload file $
 fromPerform :: Key -> AssociatedFile -> Remote -> CommandPerform
 fromPerform key file remote = go Upload file $
 	download' (uuid remote) key file stdRetry $ \p ->
-		getViaTmp (retrievalSecurityPolicy remote) (RemoteVerify remote) key file $ \t ->
+		logStatusAfter key $ getViaTmp (retrievalSecurityPolicy remote) (RemoteVerify remote) key file $ \t ->
 			tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p) >>= \case
 				Right v -> return (True, v)	
 				Left e -> do

Command/TransferKeys.hs

@@ -50,7 +50,7 @@ start = do
 						return True
 		| otherwise = notifyTransfer direction file $
 			download' (Remote.uuid remote) key file stdRetry $ \p ->
-				getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file $ \t -> do
+				logStatusAfter key $ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file $ \t -> do
 					r <- tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p) >>= \case
 						Left e -> do
 							warning (show e)

Command/Transferrer.hs

@@ -45,14 +45,14 @@ start = do
 	runner (UploadRequest _ key (TransferAssociatedFile file)) remote =
 		-- This is called by eg, Annex.Transfer.upload,
 		-- so caller is responsible for doing notification,
-		-- and for retrying.
+		-- and for retrying, and updating location log.
 		upload' (Remote.uuid remote) key file noRetry
 			(Remote.action . Remote.storeKey remote key file)
 			noNotification
 	runner (DownloadRequest _ key (TransferAssociatedFile file)) remote =
 		-- This is called by eg, Annex.Transfer.download
 		-- so caller is responsible for doing notification
-		-- and for retrying.
+		-- and for retrying, and updating location log.
 		let go p = getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file $ \t -> do
 			Remote.verifiedAction (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p)
 		in download' (Remote.uuid remote) key file noRetry go 
@@ -70,7 +70,7 @@ start = do
 	runner (AssistantDownloadRequest _ key (TransferAssociatedFile file)) remote =
 		notifyTransfer Download file $
 			download' (Remote.uuid remote) key file stdRetry $ \p ->
-				getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file $ \t -> do
+				logStatusAfter key $ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file $ \t -> do
 					r <- tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p) >>= \case
 						Left e -> do
 							warning (show e)

Logs/Location.hs

@@ -16,6 +16,7 @@
 module Logs.Location (
 	LogStatus(..),
 	logStatus,
+	logStatusAfter,
 	logChange,
 	loggedLocations,
 	loggedLocationsHistorical,
@@ -48,6 +49,16 @@ logStatus key s = do
 	u <- getUUID
 	logChange key u s
 
+{- Run an action that gets the content of a key, and update the log
+ - when it succeeds. -}
+logStatusAfter :: Key -> Annex Bool -> Annex Bool
+logStatusAfter key a = ifM a 
+	( do
+		logStatus key InfoPresent
+		return True
+	, return False
+	)
+
 {- Log a change in the presence of a key's value in a repository. -}
 logChange :: Key -> UUID -> LogStatus -> Annex ()
 logChange = logChange' logNow

P2P/Annex.hs

@@ -76,7 +76,7 @@ runLocal runst runner a = case a of
 		v <- tryNonAsync $ do
 			let runtransfer ti = 
 				Right <$> transfer download' k af (\p ->
-					getViaTmp rsp DefaultVerify k af $ \tmp ->
+					logStatusAfter k $ getViaTmp rsp DefaultVerify k af $ \tmp ->
 						storefile (fromRawFilePath tmp) o l getb validitycheck p ti)
 			let fallback = return $ Left $
 				ProtoFailureMessage "transfer already in progress, or unable to take transfer lock"

Remote/Git.hs

@@ -690,7 +690,7 @@ copyToRemote' repo r st@(State connpool duc _ _ _) key file meterupdate
 				copier <- mkCopier hardlink st params
 				let verify = Annex.Content.RemoteVerify r
 				let rsp = RetrievalAllKeysSecure
-				res <- Annex.Content.getViaTmp rsp verify key file $ \dest ->
+				res <- logStatusAfter key $ Annex.Content.getViaTmp rsp verify key file $ \dest ->
 					metered (Just (combineMeterUpdate meterupdate p)) key $ \_ p' -> 
 						copier object (fromRawFilePath dest) p' (liftIO checksuccessio)
 				Annex.Content.saveState True

doc/todo/stalldetection_breaks_move.mdwn

@@ -1,6 +1,9 @@
-Setting annex.stalldetection can break move, which complains it cannot find
-enough copies to drop.
+Setting annex.stalldetection can break sync when it does a move,
+which complains it cannot find enough copies to drop.
+(Seems that git-annex move does work ok.)
 
 The problem is that the transferrer process updates the location log, but
 the parent process doesn't see the update in time. So, the location log
 update needs to move to the parent process. --[[Joey]]
+
+> [[fixed|done]] --[[Joey]]