much better command action handling for sync --content

5 files changed, 69 insertions, 62 deletions

diff --git a/Annex/Drop.hs b/Annex/Drop.hs
index 3e915c315..6386f11bb 100644
--- a/Annex/Drop.hs
+++ b/Annex/Drop.hs
@@ -18,6 +18,7 @@ import Annex.Wanted
 import Annex.Exception
 import Config
 import Annex.Content.Direct
+import RunCommand
 
 import qualified Data.Set as S
 import System.Log.Logger (debugM)
@@ -27,29 +28,24 @@ type Reason = String
 {- Drop a key from local and/or remote when allowed by the preferred content
  - and numcopies settings.
  -
- - The Remote list can include other remotes that do not have the content.
+ - The UUIDs are ones where the content is believed to be present.
+ - The Remote list can include other remotes that do not have the content;
+ - only ones that match the UUIDs will be dropped from.
+ - If allowed to drop fromhere, that drop will be tried first.
  -
  - A remote can be specified that is known to have the key. This can be
  - used an an optimisation when eg, a key has just been uploaded to a
  - remote.
- -}
-handleDrops :: Reason -> [Remote] -> Bool -> Key -> AssociatedFile -> Maybe Remote -> Annex ()
-handleDrops _ _ _ _ Nothing _ = noop
-handleDrops reason rs fromhere key f knownpresentremote = do
-	locs <- loggedLocations key
-	handleDropsFrom locs rs reason fromhere key f knownpresentremote
-
-{- The UUIDs are ones where the content is believed to be present.
- - The Remote list can include other remotes that do not have the content;
- - only ones that match the UUIDs will be dropped from.
- - If allowed to drop fromhere, that drop will be tried first.
  -
  - In direct mode, all associated files are checked, and only if all
  - of them are unwanted are they dropped.
+ -
+ - The runner is used to run commands, and so can be either callCommand
+ - or commandAction.
  -}
-handleDropsFrom :: [UUID] -> [Remote] -> Reason -> Bool -> Key -> AssociatedFile -> Maybe Remote -> Annex ()
-handleDropsFrom _ _ _ _ _ Nothing _ = noop
-handleDropsFrom locs rs reason fromhere key (Just afile) knownpresentremote = do
+handleDropsFrom :: [UUID] -> [Remote] -> Reason -> Bool -> Key -> AssociatedFile -> Maybe Remote -> CommandActionRunner -> Annex ()
+handleDropsFrom _ _ _ _ _ Nothing _ _ = noop
+handleDropsFrom locs rs reason fromhere key (Just afile) knownpresentremote runner = do
 	fs <- ifM isDirect
 		( do
 			l <- associatedFilesRelative key
@@ -92,7 +88,7 @@ handleDropsFrom locs rs reason fromhere key (Just afile) knownpresentremote = do
 
 	checkdrop fs n@(have, numcopies, _untrusted) u a =
 		ifM (allM (wantDrop True u . Just) fs)
-			( ifM (safely $ callCommand $ a (Just numcopies))
+			( ifM (safely $ runner $ a (Just numcopies))
 				( do
 					liftIO $ debugM "drop" $ unwords
 						[ "dropped"
@@ -113,6 +109,7 @@ handleDropsFrom locs rs reason fromhere key (Just afile) knownpresentremote = do
 	dropr fs r n  = checkdrop fs n (Just $ Remote.uuid r) $ \numcopies ->
 		Command.Drop.startRemote (Just afile) numcopies key r
 
+	slocs = S.fromList locs
+	
 	safely a = either (const False) id <$> tryAnnex a
 
-	slocs = S.fromList locs
diff --git a/Assistant/Drop.hs b/Assistant/Drop.hs
index 03ab5ab2c..3020b0f4f 100644
--- a/Assistant/Drop.hs
+++ b/Assistant/Drop.hs
@@ -14,6 +14,7 @@ import Assistant.Common
 import Assistant.DaemonStatus
 import Annex.Drop (handleDropsFrom, Reason)
 import Logs.Location
+import RunCommand
 
 {- Drop from local and/or remote when allowed by the preferred content and
  - numcopies settings. -}
@@ -22,4 +23,4 @@ handleDrops _ _ _ Nothing _ = noop
 handleDrops reason fromhere key f knownpresentremote = do
 	syncrs <- syncDataRemotes <$> getDaemonStatus
 	locs <- liftAnnex $ loggedLocations key
-	liftAnnex $ handleDropsFrom locs syncrs reason fromhere key f knownpresentremote
+	liftAnnex $ handleDropsFrom locs syncrs reason fromhere key f knownpresentremote callCommand
diff --git a/Assistant/Threads/TransferScanner.hs b/Assistant/Threads/TransferScanner.hs
index b00195789..60f6dc28b 100644
--- a/Assistant/Threads/TransferScanner.hs
+++ b/Assistant/Threads/TransferScanner.hs
@@ -29,6 +29,7 @@ import qualified Git.LsFiles as LsFiles
 import qualified Backend
 import Annex.Content
 import Annex.Wanted
+import RunCommand
 
 import qualified Data.Set as S
 
@@ -158,7 +159,7 @@ expensiveScan urlrenderer rs = unless onlyweb $ batch <~> do
 		present <- liftAnnex $ inAnnex key
 		liftAnnex $ handleDropsFrom locs syncrs
 			"expensive scan found too many copies of object"
-			present key (Just f) Nothing
+			present key (Just f) Nothing callCommand
 		liftAnnex $ do
 			let slocs = S.fromList locs
 			let use a = return $ mapMaybe (a key slocs) syncrs
diff --git a/Command/Sync.hs b/Command/Sync.hs
index 25e54a56b..9db3c7ad7 100644
--- a/Command/Sync.hs
+++ b/Command/Sync.hs
@@ -79,14 +79,18 @@ seek rs = do
 
 	-- Syncing involves many actions, any of which can independently
 	-- fail, without preventing the others from running.
-	seekActions $ return [ commit ]
-	seekActions $ return [ withbranch mergeLocal ]
-	seekActions $ return $ map (withbranch . pullRemote) gitremotes
-	seekActions $ return [ mergeAnnex ]
+	seekActions $ return $ concat
+		[ [ commit ]
+		, [ withbranch mergeLocal ]
+		, map (withbranch . pullRemote) gitremotes
+		,  [ mergeAnnex ]
+		]
 	whenM (Annex.getFlag $ Option.name contentOption) $
-		withFilesInGit (whenAnnexed $ syncContent remotes) []
-	seekActions $ return $ [ withbranch pushLocal ]
-	seekActions $ return $ map (withbranch . pushRemote) gitremotes
+		seekSyncContent remotes
+	seekActions $ return $ concat
+		[ [ withbranch pushLocal ]
+		, map (withbranch . pushRemote) gitremotes
+		]
 
 {- Merging may delete the current directory, so go to the top
  - of the repo. This also means that sync always acts on all files in the
@@ -494,29 +498,24 @@ newer remote b = do
  - Drop it from each remote that has it, where it's not preferred content
  - (honoring numcopies).
  -}
-syncContent :: [Remote] -> FilePath -> (Key, Backend) -> CommandStart
-syncContent rs f (k, _) = do
+seekSyncContent :: [Remote] -> Annex ()
+seekSyncContent rs = mapM_ go =<< seekHelper LsFiles.inRepo []
+  where
+	go f = ifAnnexed f (syncFile rs f) noop
+
+syncFile :: [Remote] -> FilePath -> (Key, Backend) -> Annex ()
+syncFile rs f (k, _) = do
 	locs <- loggedLocations k
 	let (have, lack) = partition (\r -> Remote.uuid r `elem` locs) rs
-	
-	getresults <- sequence =<< handleget have
-	(putresults, putrs) <- unzip <$> (sequence =<< handleput lack)
-
-	let locs' = catMaybes putrs ++ locs
-	handleDropsFrom locs' rs "unwanted" True k (Just f) Nothing
-
-	let results = getresults ++ putresults
-	if null results
-		then stop
-		else do
-			showStart "sync" f
-			next $ next $ return $ all id results
-  where
-	run a = do
-		r <- a
-		showEndResult r
-		return r
 
+	sequence_ =<< handleget have
+	putrs <- catMaybes . snd . unzip <$> (sequence =<< handleput lack)
+
+	-- Using callCommand rather than commandAction for drops,
+	-- because a failure to drop does not mean the sync failed.
+	handleDropsFrom (putrs ++ locs) rs "unwanted" True k (Just f)
+		Nothing callCommand
+  where
   	wantget have = allM id 
 		[ pure (not $ null have)
 		, not <$> inAnnex k
@@ -526,9 +525,9 @@ syncContent rs f (k, _) = do
 		( return [ get have ]
 		, return []
 		)
-	get have = do
+	get have = commandAction $ do
 		showStart "get" f
-		run $ getViaTmp k $ \dest -> getKeyFile' k (Just f) dest have
+		next $ next $ getViaTmp k $ \dest -> getKeyFile' k (Just f) dest have
 
 	wantput r
 		| Remote.readonly r || remoteAnnexReadOnly (Types.Remote.gitconfig r) = return False
@@ -538,10 +537,13 @@ syncContent rs f (k, _) = do
 		, return []
 		)
 	put dest = do
-		showStart "copy" f
-		showAction $ "to " ++ Remote.name dest
-		ok <- run $ upload (Remote.uuid dest) k (Just f) noRetry $
-			Remote.storeKey dest k (Just f)
-		when ok $
-			Remote.logStatus dest k InfoPresent
+		ok <- commandAction $ do
+			showStart "copy" f
+			showAction $ "to " ++ Remote.name dest
+			next $ next $ do
+				ok <- upload (Remote.uuid dest) k (Just f) noRetry $
+					Remote.storeKey dest k (Just f)
+				when ok $
+					Remote.logStatus dest k InfoPresent
+				return ok
 		return (ok, if ok then Just (Remote.uuid dest) else Nothing)
diff --git a/RunCommand.hs b/RunCommand.hs
index 32a9c7d48..937686d97 100644
--- a/RunCommand.hs
+++ b/RunCommand.hs
@@ -15,6 +15,8 @@ import Types.Command
 import qualified Annex.Queue
 import Annex.Exception
 
+type CommandActionRunner = CommandStart -> CommandCleanup
+
 {- Runs a command, starting with the check stage, and then
  - the seek stage. Finishes by printing the number of commandActions that
  - failed. -}
@@ -34,25 +36,29 @@ performCommand Command { cmdseek = seek, cmdcheck = c, cmdname = name } params =
  - command).
  - 
  - This should only be run in the seek stage. -}
-commandAction :: CommandStart -> Annex ()
+commandAction :: CommandActionRunner
 commandAction a = handle =<< tryAnnexIO go
   where
 	go = do
 		Annex.Queue.flushWhenFull
 		callCommand a
-	handle (Right True) = noop
+	handle (Right True) = return True
 	handle (Right False) = incerr
 	handle (Left err) = do
 		showErr err
 		showEndFail
 		incerr
-	incerr = Annex.changeState $ \s -> 
-		let ! c = Annex.errcounter s + 1 
-		    ! s' = s { Annex.errcounter = c }
-		in s'
+	incerr = do
+		Annex.changeState $ \s -> 
+			let ! c = Annex.errcounter s + 1 
+			    ! s' = s { Annex.errcounter = c }
+			in s'
+		return False
 
-{- Runs a single command action through the start, perform and cleanup stages -}
-callCommand :: CommandStart -> CommandCleanup
+{- Runs a single command action through the start, perform and cleanup
+ - stages, without catching errors. Useful if one command wants to run
+ - part of another command. -}
+callCommand :: CommandActionRunner
 callCommand = start
   where
 	start   = stage $ maybe skip perform