unify batch mode with non-batch by using AnnexedFileSeeker

CmdLine/Action.hs

@@ -43,9 +43,6 @@ performCommandAction Command { cmdcheck = c, cmdname = name } seek cont = do
 commandActions :: [CommandStart] -> Annex ()
 commandActions = mapM_ commandAction
 
-commandAction' :: (a -> b -> CommandStart) -> a -> b -> Annex ()
-commandAction' start a b = commandAction $ start a b
-
 {- Runs one of the actions needed to perform a command.
  - Individual actions can fail without stopping the whole command,
  - including by throwing non-async exceptions.

CmdLine/Batch.hs

@@ -1,6 +1,6 @@
 {- git-annex batch commands
  -
- - Copyright 2015 Joey Hess <id@joeyh.name>
+ - Copyright 2015-2020 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
@@ -11,10 +11,13 @@ import Annex.Common
 import Types.Command
 import CmdLine.Action
 import CmdLine.GitAnnex.Options
+import CmdLine.Seek
 import Options.Applicative
 import Limit
 import Types.FileMatcher
 import Annex.BranchState
+import Annex.WorkTree
+import Annex.Content
 
 data BatchMode = Batch BatchFormat | NoBatch
 
@@ -110,12 +113,22 @@ batchStart fmt a = batchInput fmt (Right <$$> liftIO . relPathCwdToFile) $
 
 -- Like batchStart, but checks the file matching options
 -- and skips non-matching files.
-batchFilesMatching :: BatchFormat -> (FilePath -> CommandStart) -> Annex ()
+batchFilesMatching :: BatchFormat -> (RawFilePath -> CommandStart) -> Annex ()
 batchFilesMatching fmt a = do
 	matcher <- getMatcher
 	batchStart fmt $ \f ->
 		let f' = toRawFilePath f
 		in ifM (matcher $ MatchingFile $ FileInfo f' f')
-			( a f
+			( a f'
 			, return Nothing
 			)
+
+batchAnnexedFilesMatching :: BatchFormat -> AnnexedFileSeeker -> Annex ()
+batchAnnexedFilesMatching fmt seeker = batchFilesMatching fmt $
+	whenAnnexed $ \f k -> case checkContentPresent seeker of
+		Just v -> do
+			present <- inAnnex k
+			if (present == v)
+				then startAction seeker f k
+				else return Nothing
+		Nothing -> startAction seeker f k

CmdLine/Seek.hs

@@ -44,12 +44,13 @@ import qualified Annex.BranchState
 import qualified Database.Keys
 import qualified Utility.RawFilePath as R
 import Utility.Tuple
+import CmdLine.Action
 
 import Control.Concurrent.Async
 import System.Posix.Types
 
 data AnnexedFileSeeker = AnnexedFileSeeker
-	{ seekAction :: RawFilePath -> Key -> CommandSeek
+	{ startAction :: RawFilePath -> Key -> CommandStart
 	, checkContentPresent :: Maybe Bool
 	, usesLocationLog :: Bool
 	}
@@ -305,7 +306,8 @@ seekFilteredKeys seeker listfs = do
 		Just (f, content) -> do
 			case parseLinkTargetOrPointerLazy =<< content of
 				Just k -> checkpresence k $
-					seekAction seeker f k
+					commandAction $
+						startAction seeker f k
 				Nothing -> noop
 			finisher oreader
 		Nothing -> return ()
@@ -313,7 +315,7 @@ seekFilteredKeys seeker listfs = do
 	precachefinisher lreader = liftIO lreader >>= \case
 		Just ((logf, f, k), logcontent) -> do
 			maybe noop (Annex.BranchState.setCache logf) logcontent
-			seekAction seeker f k
+			commandAction $ startAction seeker f k
 			precachefinisher lreader
 		Nothing -> return ()
 	

Command/Add.hs

@@ -80,7 +80,7 @@ seek o = startConcurrency commandStages $ do
 		Batch fmt
 			| updateOnly o ->
 				giveup "--update --batch is not supported"
-			| otherwise -> batchFilesMatching fmt (gofile . toRawFilePath)
+			| otherwise -> batchFilesMatching fmt gofile
 		NoBatch -> do
 			-- Avoid git ls-files complaining about files that
 			-- are not known to git yet, since this will add

Command/Copy.hs

@@ -45,23 +45,22 @@ instance DeferredParseClass CopyOptions where
 
 seek :: CopyOptions -> CommandSeek
 seek o = startConcurrency commandStages $ do
-	let go = start o
-	let seeker = AnnexedFileSeeker
-		{ seekAction = commandAction' go
-		, checkContentPresent = Nothing
-		, usesLocationLog = False
-		}
 	case batchOption o of
-		Batch fmt -> batchFilesMatching fmt
-			(whenAnnexed go . toRawFilePath)
 		NoBatch -> withKeyOptions
 			(keyOptions o) (autoMode o)
 			(commandAction . Command.Move.startKey (fromToOptions o) Command.Move.RemoveNever)
 			(withFilesInGitAnnex ww seeker)
 			=<< workTreeItems ww (copyFiles o)
+		Batch fmt -> batchAnnexedFilesMatching fmt seeker
   where
 	ww = WarnUnmatchLsFiles
 	
+	seeker = AnnexedFileSeeker
+		{ startAction = start o
+		, checkContentPresent = Nothing
+		, usesLocationLog = False
+		}
+
 {- A copy is just a move that does not delete the source file.
  - However, auto mode avoids unnecessary copies, and avoids getting or
  - sending non-preferred content. -}

Command/Drop.hs

@@ -54,18 +54,16 @@ parseDropFromOption = parseRemoteOption <$> strOption
 seek :: DropOptions -> CommandSeek
 seek o = startConcurrency commandStages $
 	case batchOption o of
-		Batch fmt -> batchFilesMatching fmt
+		Batch fmt -> batchAnnexedFilesMatching fmt seeker
-			(whenAnnexed go . toRawFilePath)
 		NoBatch -> withKeyOptions (keyOptions o) (autoMode o)
 			(commandAction . startKeys o)
 			(withFilesInGitAnnex ww seeker)
 			=<< workTreeItems ww (dropFiles o)
   where
-	go = start o
 	ww = WarnUnmatchLsFiles
 
 	seeker = AnnexedFileSeeker
-		{ seekAction = commandAction' go
+		{ startAction = start o
 		, checkContentPresent = Nothing
 		, usesLocationLog = False
 		}

Command/Find.hs

@@ -18,7 +18,6 @@ import Types.Key
 import Git.FilePath
 import qualified Utility.Format
 import Utility.DataUnits
-import Annex.Content
 
 cmd :: Command
 cmd = notBareRepo $ withGlobalOptions [annexedMatchingOptions] $ mkCommand $
@@ -54,11 +53,10 @@ parseFormatOption =
 		)
 
 seek :: FindOptions -> CommandSeek
-seek o = case batchOption o of
+seek o = do
-	NoBatch -> do
 	islimited <- limited
 	let seeker = AnnexedFileSeeker
-			{ seekAction = commandAction' go
+		{ startAction = start o
 		-- only files with content present are shown, unless
 		-- the user has requested others via a limit
 		, checkContentPresent = if islimited
@@ -66,15 +64,13 @@ seek o = case batchOption o of
 			else Just True
 		, usesLocationLog = False
 		}
-		withKeyOptions (keyOptions o) False
+	case batchOption o of
+		NoBatch -> withKeyOptions (keyOptions o) False
 			(commandAction . startKeys o)
 			(withFilesInGitAnnex ww seeker)
 			=<< workTreeItems ww (findThese o)
-	Batch fmt -> batchFilesMatching fmt
+		Batch fmt -> batchAnnexedFilesMatching fmt seeker
-		(whenAnnexed gobatch . toRawFilePath)
   where
-	go = start o
-	gobatch f k = stopUnless (limited <||> inAnnex k) (go f k)
 	ww = WarnUnmatchLsFiles
 
 start :: FindOptions -> RawFilePath -> Key -> CommandStart

Command/Fix.hs

@@ -36,7 +36,7 @@ seek ps = unlessM crippledFileSystem $
   where
 	ww = WarnUnmatchLsFiles
 	seeker = AnnexedFileSeeker
-		{ seekAction = commandAction' (start FixAll)
+		{ startAction = start FixAll
 		, checkContentPresent = Nothing
 		, usesLocationLog = False
 		}

Command/Fsck.hs

@@ -93,7 +93,7 @@ seek o = startConcurrency commandStages $ do
 	checkDeadRepo u
 	i <- prepIncremental u (incrementalOpt o)
 	let seeker = AnnexedFileSeeker
-		{ seekAction = commandAction' (start from i)
+		{ startAction = start from i
 		, checkContentPresent = Nothing
 		, usesLocationLog = True
 		}

Command/Get.hs

@@ -40,19 +40,17 @@ optParser desc = GetOptions
 seek :: GetOptions -> CommandSeek
 seek o = startConcurrency downloadStages $ do
 	from <- maybe (pure Nothing) (Just <$$> getParsed) (getFrom o)
-	let go = start o from
 	let seeker = AnnexedFileSeeker
-		{ seekAction = commandAction' go
+		{ startAction = start o from
 		, checkContentPresent = Just False
 		, usesLocationLog = True
 		}
 	case batchOption o of
-		Batch fmt -> batchFilesMatching fmt
-			(whenAnnexed go . toRawFilePath)
 		NoBatch -> withKeyOptions (keyOptions o) (autoMode o)
 			(commandAction . startKeys from)
 			(withFilesInGitAnnex ww seeker)
 			=<< workTreeItems ww (getFiles o)
+		Batch fmt -> batchAnnexedFilesMatching fmt seeker
   where
 	ww = WarnUnmatchLsFiles
 

Command/Inprogress.hs

@@ -39,7 +39,7 @@ seek o = do
 		_ -> do
 			let s = S.fromList ts
 			let seeker = AnnexedFileSeeker
-				{ seekAction = commandAction' (start s)
+				{ startAction = start s
 				, checkContentPresent = Nothing
 				, usesLocationLog = False
 				}

Command/List.hs

@@ -45,7 +45,7 @@ seek o = do
 	list <- getList o
 	printHeader list
 	let seeker = AnnexedFileSeeker
-		{ seekAction = commandAction' (start list)
+		{ startAction = start list
 		, checkContentPresent = Nothing
 		, usesLocationLog = True
 		}

Command/Lock.hs

@@ -32,7 +32,7 @@ seek ps = withFilesInGitAnnex ww seeker =<< workTreeItems ww ps
   where
 	ww = WarnUnmatchLsFiles
 	seeker = AnnexedFileSeeker
-		{ seekAction = commandAction' start
+		{ startAction = start
 		, checkContentPresent = Nothing
 		, usesLocationLog = False
 		}

Command/Log.hs

@@ -86,7 +86,7 @@ seek o = do
 	zone <- liftIO getCurrentTimeZone
 	let outputter = mkOutputter m zone o
 	let seeker = AnnexedFileSeeker
-		{ seekAction = commandAction' (start o outputter)
+		{ startAction = start o outputter
 		, checkContentPresent = Nothing
 		-- the way this uses the location log would not be helped
 		-- by precaching the current value

Command/MetaData.hs

@@ -77,7 +77,7 @@ seek o = case batchOption o of
 		c <- liftIO currentVectorClock
 		let ww = WarnUnmatchLsFiles
 		let seeker = AnnexedFileSeeker
-			{ seekAction = commandAction' (start c o)
+			{ startAction = start c o
 			, checkContentPresent = Nothing
 			, usesLocationLog = False
 			}

Command/Migrate.hs

@@ -30,7 +30,7 @@ seek = withFilesInGitAnnex ww seeker <=< workTreeItems ww
   where
 	ww = WarnUnmatchLsFiles
 	seeker = AnnexedFileSeeker
-		{ seekAction = commandAction' start
+		{ startAction = start
 		, checkContentPresent = Nothing
 		, usesLocationLog = False
 		}

Command/Mirror.hs

@@ -52,7 +52,7 @@ seek o = startConcurrency stages $
 		ToRemote _ -> commandStages
 	ww = WarnUnmatchLsFiles
 	seeker = AnnexedFileSeeker
-		{ seekAction = commandAction' (start o)
+		{ startAction = start o
 		, checkContentPresent = Nothing
 		, usesLocationLog = False
 		}

Command/Move.hs

@@ -55,19 +55,17 @@ data RemoveWhen = RemoveSafe | RemoveNever
 
 seek :: MoveOptions -> CommandSeek
 seek o = startConcurrency stages $ do
-	let go = start (fromToOptions o) (removeWhen o)
 	let seeker = AnnexedFileSeeker
-		{ seekAction = commandAction' go
+		{ startAction = start (fromToOptions o) (removeWhen o)
 		, checkContentPresent = Nothing
 		, usesLocationLog = False
 		}
 	case batchOption o of
-		Batch fmt -> batchFilesMatching fmt
-			(whenAnnexed go . toRawFilePath)
 		NoBatch -> withKeyOptions (keyOptions o) False
 			(commandAction . startKey (fromToOptions o) (removeWhen o))
 			(withFilesInGitAnnex ww seeker)
 			=<< workTreeItems ww (moveFiles o)
+		Batch fmt -> batchAnnexedFilesMatching fmt seeker
   where
 	stages = case fromToOptions o of
 		Right (FromRemote _) -> downloadStages

Command/Sync.hs

@@ -646,7 +646,7 @@ seekSyncContent o rs currbranch = do
 				seekworktree mvar l (const noop)
 				pure Nothing
 	withKeyOptions' (keyOptions o) False
-		(return (gokey mvar bloom))
+		(return (commandAction . gokey mvar bloom))
 		(const noop)
 		[]
 	waitForAllRunningCommandActions
@@ -654,7 +654,7 @@ seekSyncContent o rs currbranch = do
   where
 	seekworktree mvar l bloomfeeder = do
 		let seeker = AnnexedFileSeeker
-			{ seekAction = gofile bloomfeeder mvar
+			{ startAction = gofile bloomfeeder mvar
 			, checkContentPresent = Nothing
 			, usesLocationLog = True
 			}
@@ -662,7 +662,7 @@ seekSyncContent o rs currbranch = do
 			seekHelper fst3 ww LsFiles.inRepoDetails l
 
 	seekincludinghidden origbranch mvar l bloomfeeder =
-		seekFiltered (\f -> ifAnnexed f (gofile bloomfeeder mvar f) noop) $
+		seekFiltered (\f -> ifAnnexed f (commandAction . gofile bloomfeeder mvar f) noop) $
 			seekHelper id ww (LsFiles.inRepoOrBranch origbranch) l 
 
 	ww = WarnUnmatchLsFiles
@@ -677,7 +677,7 @@ seekSyncContent o rs currbranch = do
 		-- Run syncFile as a command action so file transfers run
 		-- concurrently.
 		let ai = OnlyActionOn k (ActionItemKey k)
-		commandAction $ startingNoMessage ai $ do
+		startingNoMessage ai $ do
 			whenM (syncFile ebloom rs af k) $
 				void $ liftIO $ tryPutMVar mvar ()
 			next $ return True

Command/Unannex.hs

@@ -28,7 +28,7 @@ seek ps = withFilesInGitAnnex ww seeker =<< workTreeItems ww ps
 
 seeker :: AnnexedFileSeeker
 seeker = AnnexedFileSeeker
-	{ seekAction = commandAction' start
+	{ startAction = start
 	, checkContentPresent = Just True
 	, usesLocationLog = False
 	}

Command/Unlock.hs

@@ -31,7 +31,7 @@ seek ps = withFilesInGitAnnex ww seeker =<< workTreeItems ww ps
   where
 	ww = WarnUnmatchLsFiles
 	seeker = AnnexedFileSeeker
-		{ seekAction = commandAction' start
+		{ startAction = start
 		, checkContentPresent = Nothing
 		, usesLocationLog = False
 		}

Command/Whereis.hs

@@ -51,20 +51,18 @@ parseFormatOption = option (Utility.Format.gen <$> str)
 seek :: WhereisOptions -> CommandSeek
 seek o = do
 	m <- remoteMap id
-	let go = start o m
-	case batchOption o of
-		Batch fmt -> batchFilesMatching fmt
-			(whenAnnexed go . toRawFilePath)
-		NoBatch -> do
 	let seeker = AnnexedFileSeeker
-				{ seekAction = commandAction' go
+		{ startAction = start o m
 		, checkContentPresent = Nothing
 		, usesLocationLog = True
 		}
+	case batchOption o of
+		NoBatch -> do
 			withKeyOptions (keyOptions o) False
 				(commandAction . startKeys o m)
 				(withFilesInGitAnnex ww seeker)
 				=<< workTreeItems ww (whereisFiles o)
+		Batch fmt -> batchAnnexedFilesMatching fmt seeker
   where
 	ww = WarnUnmatchLsFiles
 

doc/todo/precache_logs_for_speed_with_cat-file_--buffer.mdwn

@@ -37,9 +37,6 @@ and precache them.
 > > > Still todo:
 > > > 
 > > > * move, copy, drop, and mirror were left not using the location log caching yet
-> > > * find has a bit of ugliness around batch mode, and this shows it
-> > >   would be worth making the batch mode take the same AnnexedFileSeeker,
-> > >   to reunify the batch and non-batch code
 > > > * get is left with an unncessary inAnnex check so could be sped up
 > > >   a little bit more. Above improvements to batch mode would allow
 > > >   fixing this.