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.

diff --git a/Annex/Content.hs b/Annex/Content.hs
index a7535da1cd03e975e80c8e81f09ab1d7658e8891..12af39618c0be59a69d2e359c51c55a9e26cb0e7 100644 (file)
--- a/Annex/Content.hs
+++ b/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

diff --git a/Annex/Transfer.hs b/Annex/Transfer.hs
index ba2044e2fb42b382f044d64eee6c697d2772d7e0..e02896d27b1813dc3e891fb1c2ebdcac3e1f2bcc 100644 (file)
--- a/Annex/Transfer.hs
+++ b/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

diff --git a/Command/Multicast.hs b/Command/Multicast.hs
index 06599202e6a16d9cfd03afa412a2dcd386dd746c..ffd6c332b5b8fb306071e49a861d7985e2666ac2 100644 (file)
--- a/Command/Multicast.hs
+++ b/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)

diff --git a/Command/RecvKey.hs b/Command/RecvKey.hs
index df81ecc99ddc5854ac6b70b9918ef68a057517f0..2b49ca84a655dc51f369b7caf789b6a84c179fb1 100644 (file)
--- a/Command/RecvKey.hs
+++ b/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

diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs
index 0f15ae6b41544619e6ea8d35c608e7de0f62102d..674415c275b5800ca1d2d28a3e3fe6ea52522b2b 100644 (file)
--- a/Command/TestRemote.hs
+++ b/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))
        ]

diff --git a/Command/TransferKey.hs b/Command/TransferKey.hs
index d6d660a39c515a6ac056ce4120352a4d2ae1948c..eb3edb7f49913f5a333024c9af770e48c2a3cfd5 100644 (file)
--- a/Command/TransferKey.hs
+++ b/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

diff --git a/Command/TransferKeys.hs b/Command/TransferKeys.hs
index aba5feabaad878795bed15fee930b9d31d89c386..78ba717361036c5e5336fc45e35cb376f8623818 100644 (file)
--- a/Command/TransferKeys.hs
+++ b/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)

diff --git a/Command/Transferrer.hs b/Command/Transferrer.hs
index 410a4de6561ecaece2eb085951a0bf1cea3e346a..9376aefecf14b21eb879b66ceae42216c06e0260 100644 (file)
--- a/Command/Transferrer.hs
+++ b/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)

diff --git a/Logs/Location.hs b/Logs/Location.hs
index 560fbeec239b50af64c0900518b38cb45aa16872..57a89e241e03b9ebeb53659c1f82d38729ec9721 100644 (file)
--- a/Logs/Location.hs
+++ b/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

diff --git a/P2P/Annex.hs b/P2P/Annex.hs
index 8cf858fead981b1ea168f5bd7235ded31cb95244..4c117bed2bb2cbfe55039ba9c7305618a6e2a4bb 100644 (file)
--- a/P2P/Annex.hs
+++ b/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"

diff --git a/Remote/Git.hs b/Remote/Git.hs
index 0a44f6854837f59761b9d4b3c0609072785b6428..b790915a33965950278de4e176a83d75cd2ce998 100644 (file)
--- a/Remote/Git.hs
+++ b/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

diff --git a/doc/todo/stalldetection_breaks_move.mdwn b/doc/todo/stalldetection_breaks_move.mdwn
index 536cd4202eccb2332a3941739e4aa2585b1b873d..d3cd728cddd20e41319b4abf29dde6554de809a1 100644 (file)
--- a/doc/todo/stalldetection_breaks_move.mdwn
+++ b/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]]