Merge branch 'streamkeys'

Annex/View.hs

@@ -351,7 +351,7 @@ applyView' mkviewedfile getfilemetadata view = do
 	withUpdateIndex viewg $ \uh -> do
 		forM_ l $ \(f, sha, mode) -> do
 			topf <- inRepo (toTopFilePath f)
-			go uh topf sha (toTreeItemType mode) =<< lookupFile f
+			go uh topf sha (toTreeItemType mode) =<< lookupKey f
 		liftIO $ void clean
 		genViewBranch view
   where

Annex/WorkTree.hs

@@ -35,8 +35,8 @@ import Control.Concurrent
  - When in an adjusted branch that may have hidden the file, looks for a
  - pointer to a key in the original branch.
  -}
-lookupFile :: RawFilePath -> Annex (Maybe Key)
+lookupKey :: RawFilePath -> Annex (Maybe Key)
-lookupFile = lookupFile' catkeyfile
+lookupKey = lookupKey' catkeyfile
   where
 	catkeyfile file =
 		ifM (liftIO $ doesFileExist $ fromRawFilePath file)
@@ -44,8 +44,8 @@ lookupFile = lookupFile' catkeyfile
 			, catKeyFileHidden file =<< getCurrentBranch
 			)
 
-lookupFileNotHidden :: RawFilePath -> Annex (Maybe Key)
+lookupKeyNotHidden :: RawFilePath -> Annex (Maybe Key)
-lookupFileNotHidden = lookupFile' catkeyfile
+lookupKeyNotHidden = lookupKey' catkeyfile
   where
 	catkeyfile file =
 		ifM (liftIO $ doesFileExist $ fromRawFilePath file)
@@ -53,8 +53,8 @@ lookupFileNotHidden = lookupFile' catkeyfile
 			, return Nothing
 			)
 
-lookupFile' :: (RawFilePath -> Annex (Maybe Key)) -> RawFilePath -> Annex (Maybe Key)
+lookupKey' :: (RawFilePath -> Annex (Maybe Key)) -> RawFilePath -> Annex (Maybe Key)
-lookupFile' catkeyfile file = isAnnexLink file >>= \case
+lookupKey' catkeyfile file = isAnnexLink file >>= \case
 	Just key -> return (Just key)
 	Nothing -> catkeyfile file
 
@@ -64,7 +64,7 @@ whenAnnexed :: (RawFilePath -> Key -> Annex (Maybe a)) -> RawFilePath -> Annex (
 whenAnnexed a file = ifAnnexed file (a file) (return Nothing)
 
 ifAnnexed :: RawFilePath -> (Key -> Annex a) -> Annex a -> Annex a
-ifAnnexed file yes no = maybe no yes =<< lookupFile file
+ifAnnexed file yes no = maybe no yes =<< lookupKey file
 
 {- Find all unlocked files and update the keys database for them. 
  - 

Assistant/Threads/TransferScanner.hs

@@ -145,7 +145,7 @@ expensiveScan urlrenderer rs = batch <~> do
 		(unwanted', ts) <- maybe
 			(return (unwanted, []))
 			(findtransfers f unwanted)
-				=<< liftAnnex (lookupFile f)
+				=<< liftAnnex (lookupKey f)
 		mapM_ (enqueue f) ts
 
 		{- Delay for a short time to avoid using too much CPU. -}

Assistant/Threads/Watcher.hs

@@ -289,7 +289,7 @@ onAddUnlocked' contentchanged addassociatedfile addlink samefilestatus symlinkss
 onAddSymlink :: Handler
 onAddSymlink file filestatus = unlessIgnored file $ do
 	linktarget <- liftIO (catchMaybeIO $ readSymbolicLink file)
-	kv <- liftAnnex (lookupFile (toRawFilePath file))
+	kv <- liftAnnex (lookupKey (toRawFilePath file))
 	onAddSymlink' linktarget kv file filestatus
 
 onAddSymlink' :: Maybe String -> Maybe Key -> Handler

Build/DistributionUpdate.hs

@@ -128,7 +128,7 @@ makeinfos updated version = do
 	now <- liftIO getCurrentTime
 	liftIO $ putStrLn $ "building info files"
 	forM_ updated $ \(f, bv) -> do
-		v <- lookupFile (toRawFilePath f)
+		v <- lookupKey (toRawFilePath f)
 		case v of
 			Nothing -> noop
 			Just k -> whenM (inAnnex k) $ do

CHANGELOG

@@ -29,6 +29,7 @@ git-annex (8.20200618) UNRELEASED; urgency=medium
     after getting several thousand files.
   * Sped up the --all option by 2x to 16x by using git cat-file --buffer.
     Thanks to Lukey for finding this optimisation.
+  * Sped up seeking for annexed files to operate on by a factor of nearly 2x.
   * fsck: Detect if WORM keys contain a carriage return, and recommend
     upgrading the key. (git-annex could have maybe created such keys back
     in 2013).

CmdLine/Action.hs

@@ -43,6 +43,9 @@ 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/Seek.hs

@@ -19,6 +19,7 @@ import qualified Git
 import qualified Git.Command
 import qualified Git.LsFiles as LsFiles
 import qualified Git.LsTree as LsTree
+import qualified Git.Types as Git
 import Git.FilePath
 import qualified Limit
 import CmdLine.GitAnnex.Options
@@ -29,31 +30,41 @@ import Logs.Transfer
 import Remote.List
 import qualified Remote
 import Annex.CatFile
-import Git.CatFile (catObjectStream)
+import Git.CatFile (catObjectStreamLsTree, catObjectStream)
 import Annex.CurrentBranch
 import Annex.Content
+import Annex.Link
 import Annex.InodeSentinal
+import Annex.Concurrent
 import qualified Annex.Branch
 import qualified Annex.BranchState
 import qualified Database.Keys
 import qualified Utility.RawFilePath as R
+import Utility.Tuple
+
+import Control.Concurrent.Async
+import System.Posix.Types
 
 withFilesInGit :: WarnUnmatchWhen -> (RawFilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek
-withFilesInGit ww a l = seekActions $ prepFiltered a $
+withFilesInGit ww a l = seekFiltered a $
-	seekHelper ww LsFiles.inRepo l
+	seekHelper id ww LsFiles.inRepo l
 
-withFilesInGitNonRecursive :: WarnUnmatchWhen -> String -> (RawFilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek
+withFilesInGitAnnex :: WarnUnmatchWhen -> (RawFilePath -> Key -> CommandSeek) -> [WorkTreeItem] -> CommandSeek
-withFilesInGitNonRecursive ww needforce a l = ifM (Annex.getState Annex.force)
+withFilesInGitAnnex ww a l = seekFilteredKeys a $
-	( withFilesInGit ww a l
+	seekHelper fst3 ww LsFiles.inRepoDetails l
+
+withFilesInGitAnnexNonRecursive :: WarnUnmatchWhen -> String -> (RawFilePath -> Key -> CommandSeek) -> [WorkTreeItem] -> CommandSeek
+withFilesInGitAnnexNonRecursive ww needforce a l = ifM (Annex.getState Annex.force)
+	( withFilesInGitAnnex ww a l
 	, if null l
 		then giveup needforce
-		else seekActions $ prepFiltered a (getfiles [] l)
+		else seekFilteredKeys a (getfiles [] l)
 	)
   where
 	getfiles c [] = return (reverse c)
 	getfiles c ((WorkTreeItem p):ps) = do
 		os <- seekOptions ww
-		(fs, cleanup) <- inRepo $ LsFiles.inRepo os [toRawFilePath p]
+		(fs, cleanup) <- inRepo $ LsFiles.inRepoDetails os [toRawFilePath p]
 		case fs of
 			[f] -> do
 				void $ liftIO $ cleanup
@@ -71,8 +82,8 @@ withFilesNotInGit  a l = go =<< seek
 		g <- gitRepo
 		liftIO $ Git.Command.leaveZombie
 			<$> LsFiles.notInRepo [] force (map (\(WorkTreeItem f) -> toRawFilePath f) l) g
-	go fs = seekActions $ prepFiltered a $
+	go fs = seekFiltered a $
-		return $ concat $ segmentPaths (map (\(WorkTreeItem f) -> toRawFilePath f) l) fs
+		return $ concat $ segmentPaths id (map (\(WorkTreeItem f) -> toRawFilePath f) l) fs
 
 withPathContents :: ((FilePath, FilePath) -> CommandSeek) -> CmdParams -> CommandSeek
 withPathContents a params = do
@@ -94,34 +105,29 @@ withPathContents a params = do
 		}
 
 withWords :: ([String] -> CommandSeek) -> CmdParams -> CommandSeek
-withWords a params = seekActions $ return [a params]
+withWords a params = a params
 
 withStrings :: (String -> CommandSeek) -> CmdParams -> CommandSeek
-withStrings a params = seekActions $ return $ map a params
+withStrings a params = sequence_ $ map a params
 
 withPairs :: ((String, String) -> CommandSeek) -> CmdParams -> CommandSeek
-withPairs a params = seekActions $ return $ map a $ pairs [] params
+withPairs a params = sequence_ $ map a $ pairs [] params
   where
 	pairs c [] = reverse c
 	pairs c (x:y:xs) = pairs ((x,y):c) xs
 	pairs _ _ = giveup "expected pairs"
 
 withFilesToBeCommitted :: (RawFilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek
-withFilesToBeCommitted a l = seekActions $ prepFiltered a $
+withFilesToBeCommitted a l = seekFiltered a $
-	seekHelper WarnUnmatchWorkTreeItems (const LsFiles.stagedNotDeleted) l
+	seekHelper id WarnUnmatchWorkTreeItems (const LsFiles.stagedNotDeleted) l
-
-isOldUnlocked :: RawFilePath -> Annex Bool
-isOldUnlocked f = liftIO (notSymlink f) <&&> 
-	(isJust <$> catKeyFile f <||> isJust <$> catKeyFileHEAD f)
 
 {- unlocked pointer files that are staged, and whose content has not been
  - modified-}
 withUnmodifiedUnlockedPointers :: WarnUnmatchWhen -> (RawFilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek
-withUnmodifiedUnlockedPointers ww a l = seekActions $
+withUnmodifiedUnlockedPointers ww a l = seekFiltered a unlockedfiles
-	prepFiltered a unlockedfiles
   where
 	unlockedfiles = filterM isUnmodifiedUnlocked 
-		=<< seekHelper ww (const LsFiles.typeChangedStaged) l
+		=<< seekHelper id ww (const LsFiles.typeChangedStaged) l
 
 isUnmodifiedUnlocked :: RawFilePath -> Annex Bool
 isUnmodifiedUnlocked f = catKeyFile f >>= \case
@@ -130,11 +136,11 @@ isUnmodifiedUnlocked f = catKeyFile f >>= \case
 
 {- Finds files that may be modified. -}
 withFilesMaybeModified :: WarnUnmatchWhen -> (RawFilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek
-withFilesMaybeModified ww a params = seekActions $
+withFilesMaybeModified ww a params = seekFiltered a $
-	prepFiltered a $ seekHelper ww LsFiles.modified params
+	seekHelper id ww LsFiles.modified params
 
 withKeys :: (Key -> CommandSeek) -> CmdParams -> CommandSeek
-withKeys a l = seekActions $ return $ map (a . parse) l
+withKeys a l = sequence_ $ map (a . parse) l
   where
 	parse p = fromMaybe (giveup "bad key") $ deserializeKey p
 
@@ -224,7 +230,7 @@ withKeyOptions' ko auto mkkeyaction fallbackaction params = do
 						keyaction (k, mkActionItem k)
 					Nothing -> return ()
 				go reader
-		catObjectStream l (isJust . getk . LsTree.file) g go
+		catObjectStreamLsTree l (isJust . getk . LsTree.file) g go
 		liftIO $ void cleanup
 
 	runkeyaction getks = do
@@ -251,23 +257,60 @@ withKeyOptions' ko auto mkkeyaction fallbackaction params = do
 		forM_ ts $ \(t, i) ->
 			keyaction (transferKey t, mkActionItem (t, i))
 
-prepFiltered :: (RawFilePath -> CommandSeek) -> Annex [RawFilePath] -> Annex [CommandSeek]
+seekFiltered :: (RawFilePath -> CommandSeek) -> Annex [RawFilePath] -> Annex ()
-prepFiltered a fs = do
+seekFiltered a fs = do
 	matcher <- Limit.getMatcher
-	map (process matcher) <$> fs
+	sequence_ =<< (map (process matcher) <$> fs)
   where
 	process matcher f =
 		whenM (matcher $ MatchingFile $ FileInfo f f) $ a f
 
-seekActions :: Annex [CommandSeek] -> Annex ()
+-- This is significantly faster than using lookupKey after seekFiltered.
-seekActions gen = sequence_ =<< gen
+seekFilteredKeys :: (RawFilePath -> Key -> CommandSeek) -> Annex [(RawFilePath, Git.Sha, FileMode)] -> Annex ()
+seekFilteredKeys a fs = do
+	g <- Annex.gitRepo
+	matcher <- Limit.getMatcher
+	catObjectStream g $ \feeder closer reader -> do
+		processertid <- liftIO . async =<< forkState
+			(gofeed matcher feeder closer)
+		goread reader
+		join (liftIO (wait processertid))
+  where
+	gofeed matcher feeder closer = do
+		l <- fs
+		forM_ l $ process matcher feeder
+		liftIO closer
 
-seekHelper :: WarnUnmatchWhen -> ([LsFiles.Options] -> [RawFilePath] -> Git.Repo -> IO ([RawFilePath], IO Bool)) -> [WorkTreeItem] -> Annex [RawFilePath]
+	goread reader = liftIO reader >>= \case
-seekHelper ww a l = do
+		Just (f, content) -> do
+			maybe noop (a f) (parseLinkTargetOrPointerLazy =<< content)
+			goread reader
+		Nothing -> return ()
+	
+	feedmatches matcher feeder f sha = 
+		whenM (matcher $ MatchingFile $ FileInfo f f) $
+			liftIO $ feeder (f, sha)
+
+	process matcher feeder (f, sha, mode) = case
+		Git.toTreeItemType mode of
+			Just Git.TreeSymlink -> 
+				feedmatches matcher feeder f sha
+			Just Git.TreeSubmodule -> return ()
+			-- Might be a pointer file, might be other
+			-- file in git, possibly large. Avoid catting
+			-- large files by first looking up the size.
+			Just _ -> catObjectMetaData sha >>= \case
+				Just (_, sz, _) | sz <= maxPointerSz -> 
+					feedmatches matcher feeder f sha
+				_ -> return ()
+			Nothing -> return ()
+
+seekHelper :: (a -> RawFilePath) -> WarnUnmatchWhen -> ([LsFiles.Options] -> [RawFilePath] -> Git.Repo -> IO ([a], IO Bool)) -> [WorkTreeItem] -> Annex [a]
+seekHelper c ww a l = do
 	os <- seekOptions ww
 	inRepo $ \g ->
 		concat . concat <$> forM (segmentXargsOrdered l')
-			(runSegmentPaths (\fs -> Git.Command.leaveZombie <$> a os fs g) . map toRawFilePath)
+			(runSegmentPaths c (\fs -> Git.Command.leaveZombie <$> a os fs g) . map toRawFilePath)
   where
 	l' = map (\(WorkTreeItem f) -> f) l
 

Command/Copy.hs

@@ -45,13 +45,14 @@ instance DeferredParseClass CopyOptions where
 
 seek :: CopyOptions -> CommandSeek
 seek o = startConcurrency commandStages $ do
-	let go = whenAnnexed $ start o
+	let go = start o
 	case batchOption o of
-		Batch fmt -> batchFilesMatching fmt (go . toRawFilePath)
+		Batch fmt -> batchFilesMatching fmt
+			(whenAnnexed go . toRawFilePath)
 		NoBatch -> withKeyOptions
 			(keyOptions o) (autoMode o)
 			(commandAction . Command.Move.startKey (fromToOptions o) Command.Move.RemoveNever)
-			(withFilesInGit ww $ commandAction . go)
+			(withFilesInGitAnnex ww (commandAction' go))
 			=<< workTreeItems ww (copyFiles o)
   where
 	ww = WarnUnmatchLsFiles

Command/Drop.hs

@@ -54,13 +54,14 @@ parseDropFromOption = parseRemoteOption <$> strOption
 seek :: DropOptions -> CommandSeek
 seek o = startConcurrency commandStages $
 	case batchOption o of
-		Batch fmt -> batchFilesMatching fmt (go . toRawFilePath)
+		Batch fmt -> batchFilesMatching fmt
+			(whenAnnexed go . toRawFilePath)
 		NoBatch -> withKeyOptions (keyOptions o) (autoMode o)
 			(commandAction . startKeys o)
-			(withFilesInGit ww (commandAction . go))
+			(withFilesInGitAnnex ww (commandAction' go))
 			=<< workTreeItems ww (dropFiles o)
   where
-	go = whenAnnexed $ start o
+	go = start o
 	ww = WarnUnmatchLsFiles
 
 start :: DropOptions -> RawFilePath -> Key -> CommandStart

Command/Export.hs

@@ -200,7 +200,7 @@ changeExport r db (PreferredFiltered new) = do
 	mapdiff a oldtreesha newtreesha = do
 		(diff, cleanup) <- inRepo $
 			Git.DiffTree.diffTreeRecursive oldtreesha newtreesha
-		seekActions $ pure $ map a diff
+		sequence_ $ map a diff
 		void $ liftIO cleanup
 
 -- Map of old and new filenames for each changed ExportKey in a diff.

Command/Find.hs

@@ -57,11 +57,12 @@ seek :: FindOptions -> CommandSeek
 seek o = case batchOption o of
 	NoBatch -> withKeyOptions (keyOptions o) False
 		(commandAction . startKeys o)
-		(withFilesInGit ww (commandAction . go))
+		(withFilesInGitAnnex ww (commandAction' go))
 		=<< workTreeItems ww (findThese o)
-	Batch fmt -> batchFilesMatching fmt (go . toRawFilePath)
+	Batch fmt -> batchFilesMatching fmt
+		(whenAnnexed go . toRawFilePath)
   where
-	go = whenAnnexed $ start o
+	go = start o
 	ww = WarnUnmatchLsFiles
 
 -- only files inAnnex are shown, unless the user has requested

Command/Fix.hs

@@ -31,9 +31,8 @@ cmd = noCommit $ withGlobalOptions [annexedMatchingOptions] $
 		paramPaths (withParams seek)
 
 seek :: CmdParams -> CommandSeek
-seek ps = unlessM crippledFileSystem $ do 
+seek ps = unlessM crippledFileSystem $
-	withFilesInGit ww
+	withFilesInGitAnnex ww (commandAction' (start FixAll))
-		(commandAction . (whenAnnexed $ start FixAll))
 		=<< workTreeItems ww ps
   where
 	ww = WarnUnmatchLsFiles

Command/FromKey.hs

@@ -84,7 +84,7 @@ keyOpt s = case parseURI s of
 		Nothing -> giveup $ "bad key/url " ++ s
 
 perform :: Key -> FilePath -> CommandPerform
-perform key file = lookupFileNotHidden (toRawFilePath file) >>= \case
+perform key file = lookupKeyNotHidden (toRawFilePath file) >>= \case
 	Nothing -> ifM (liftIO $ doesFileExist file)
 		( hasothercontent
 		, do

Command/Get.hs

@@ -40,12 +40,13 @@ optParser desc = GetOptions
 seek :: GetOptions -> CommandSeek
 seek o = startConcurrency downloadStages $ do
 	from <- maybe (pure Nothing) (Just <$$> getParsed) (getFrom o)
-	let go = whenAnnexed $ start o from
+	let go = start o from
 	case batchOption o of
-		Batch fmt -> batchFilesMatching fmt (go . toRawFilePath)
+		Batch fmt -> batchFilesMatching fmt
+			(whenAnnexed go . toRawFilePath)
 		NoBatch -> withKeyOptions (keyOptions o) (autoMode o)
 			(commandAction . startKeys from)
-			(withFilesInGit ww (commandAction . go))
+			(withFilesInGitAnnex ww (commandAction' go))
 			=<< workTreeItems ww (getFiles o)
   where
 	ww = WarnUnmatchLsFiles

Command/Inprogress.hs

@@ -38,8 +38,8 @@ seek o = do
 			| otherwise -> commandAction stop
 		_ -> do
 			let s = S.fromList ts
-			withFilesInGit ww
+			withFilesInGitAnnex ww
-				(commandAction . (whenAnnexed (start s)))
+				(commandAction' (start s))
 				=<< workTreeItems ww (inprogressFiles o)
   where
 	ww = WarnUnmatchLsFiles

Command/List.hs

@@ -44,7 +44,7 @@ seek :: ListOptions -> CommandSeek
 seek o = do
 	list <- getList o
 	printHeader list
-	withFilesInGit ww (commandAction . (whenAnnexed $ start list))
+	withFilesInGitAnnex ww (commandAction' (start list))
 		=<< workTreeItems ww (listThese o)
   where
 	ww = WarnUnmatchLsFiles

Command/Lock.hs

@@ -8,7 +8,6 @@
 module Command.Lock where
 
 import Command
-import qualified Annex.Queue
 import qualified Annex
 import Annex.Content
 import Annex.Link
@@ -31,12 +30,12 @@ cmd = withGlobalOptions [jsonOptions, annexedMatchingOptions] $
 seek :: CmdParams -> CommandSeek
 seek ps = do
 	l <- workTreeItems ww ps
-	withFilesInGit ww (commandAction . (whenAnnexed startNew)) l
+	withFilesInGitAnnex ww (commandAction' start) l
   where
 	ww = WarnUnmatchLsFiles
 
-startNew :: RawFilePath -> Key -> CommandStart
+start :: RawFilePath -> Key -> CommandStart
-startNew file key = ifM (isJust <$> isAnnexLink file)
+start file key = ifM (isJust <$> isAnnexLink file)
 	( stop
 	, starting "lock" (mkActionItem (key, file)) $
 		go =<< liftIO (isPointerFile file)
@@ -53,14 +52,14 @@ startNew file key = ifM (isJust <$> isAnnexLink file)
 				, errorModified
 				)
 			)
-	cont = performNew file key
+	cont = perform file key
 
-performNew :: RawFilePath -> Key -> CommandPerform
+perform :: RawFilePath -> Key -> CommandPerform
-performNew file key = do
+perform file key = do
 	lockdown =<< calcRepo (gitAnnexLocation key)
 	addLink (fromRawFilePath file) key
 		=<< withTSDelta (liftIO . genInodeCache file)
-	next $ cleanupNew file key
+	next $ cleanup file key
   where
 	lockdown obj = do
 		ifM (isUnmodified key obj)
@@ -96,22 +95,10 @@ performNew file key = do
 
 	lostcontent = logStatus key InfoMissing
 
-cleanupNew :: RawFilePath -> Key -> CommandCleanup
+cleanup :: RawFilePath -> Key -> CommandCleanup
-cleanupNew file key = do
+cleanup file key = do
 	Database.Keys.removeAssociatedFile key =<< inRepo (toTopFilePath file)
 	return True
 
-startOld :: RawFilePath -> CommandStart
-startOld file = do
-	unlessM (Annex.getState Annex.force)
-		errorModified
-	starting "lock" (ActionItemWorkTreeFile file) $
-		performOld file
-
-performOld :: RawFilePath -> CommandPerform
-performOld file = do
-	Annex.Queue.addCommand "checkout" [Param "--"] [fromRawFilePath file]
-	next $ return True
-
 errorModified :: a
 errorModified =  giveup "Locking this file would discard any changes you have made to it. Use 'git annex add' to stage your changes. (Or, use --force to override)"

Command/Log.hs

@@ -86,8 +86,8 @@ seek o = do
 	zone <- liftIO getCurrentTimeZone
 	let outputter = mkOutputter m zone o
 	case (logFiles o, allOption o) of
-		(fs, False) -> withFilesInGit ww
+		(fs, False) -> withFilesInGitAnnex ww
-			(commandAction . (whenAnnexed $ start o outputter)) 
+			(commandAction' (start o outputter))
 			=<< workTreeItems ww fs
 		([], True) -> commandAction (startAll o outputter)
 		(_, True) -> giveup "Cannot specify both files and --all"

Command/MetaData.hs

@@ -77,13 +77,13 @@ seek o = case batchOption o of
 		c <- liftIO currentVectorClock
 		let ww = WarnUnmatchLsFiles
 		let seeker = case getSet o of
-			Get _ -> withFilesInGit ww
+			Get _ -> withFilesInGitAnnex ww
-			GetAll -> withFilesInGit ww
+			GetAll -> withFilesInGitAnnex ww
-			Set _ -> withFilesInGitNonRecursive ww
+			Set _ -> withFilesInGitAnnexNonRecursive ww
 				"Not recursively setting metadata. Use --force to do that."
 		withKeyOptions (keyOptions o) False
 			(commandAction . startKeys c o)
-			(seeker (commandAction . (whenAnnexed (start c o))))
+			(seeker (commandAction' (start c o)))
 			=<< workTreeItems ww (forFiles o)
 	Batch fmt -> withMessageState $ \s -> case outputType s of
 		JSONOutput _ -> ifM limited
@@ -168,7 +168,7 @@ parseJSONInput i = case eitherDecode (BU.fromString i) of
 startBatch :: (Either RawFilePath Key, MetaData) -> CommandStart
 startBatch (i, (MetaData m)) = case i of
 	Left f -> do
-		mk <- lookupFile f
+		mk <- lookupKey f
 		case mk of
 			Just k -> go k (mkActionItem (k, AssociatedFile (Just f)))
 			Nothing -> giveup $ "not an annexed file: " ++ fromRawFilePath f

Command/Migrate.hs

@@ -26,7 +26,7 @@ cmd = withGlobalOptions [annexedMatchingOptions] $
 		paramPaths (withParams seek)
 
 seek :: CmdParams -> CommandSeek
-seek = withFilesInGit ww (commandAction . (whenAnnexed start))
+seek = withFilesInGitAnnex ww (commandAction' start)
 	<=< workTreeItems ww
   where
 	ww = WarnUnmatchLsFiles

Command/Mirror.hs

@@ -44,7 +44,7 @@ seek :: MirrorOptions -> CommandSeek
 seek o = startConcurrency stages $ 
 	withKeyOptions (keyOptions o) False
 		(commandAction . startKey o (AssociatedFile Nothing))
-		(withFilesInGit ww (commandAction . (whenAnnexed $ start o)))
+		(withFilesInGitAnnex ww (commandAction' (start o)))
 		=<< workTreeItems ww (mirrorFiles o)
   where
 	stages = case fromToOptions o of

Command/Move.hs

@@ -55,12 +55,13 @@ data RemoveWhen = RemoveSafe | RemoveNever
 
 seek :: MoveOptions -> CommandSeek
 seek o = startConcurrency stages $ do
-	let go = whenAnnexed $ start (fromToOptions o) (removeWhen o)
+	let go = start (fromToOptions o) (removeWhen o)
 	case batchOption o of
-		Batch fmt -> batchFilesMatching fmt (go . toRawFilePath)
+		Batch fmt -> batchFilesMatching fmt
+			(whenAnnexed go . toRawFilePath)
 		NoBatch -> withKeyOptions (keyOptions o) False
 			(commandAction . startKey (fromToOptions o) (removeWhen o))
-			(withFilesInGit ww (commandAction . go))
+			(withFilesInGitAnnex ww (commandAction' go))
 			=<< workTreeItems ww (moveFiles o)
   where
 	stages = case fromToOptions o of

Command/Multicast.hs

@@ -130,13 +130,13 @@ send ups fs = do
 	starting "sending files" (ActionItemOther Nothing) $
 		withTmpFile "send" $ \t h -> do
 			let ww = WarnUnmatchLsFiles
-			fs' <- seekHelper ww LsFiles.inRepo
+			fs' <- seekHelper id ww LsFiles.inRepo
 				=<< workTreeItems ww fs
 			matcher <- Limit.getMatcher
 			let addlist f o = whenM (matcher $ MatchingFile $ FileInfo f f) $
 				liftIO $ hPutStrLn h o
 			forM_ fs' $ \f -> do
-				mk <- lookupFile f
+				mk <- lookupKey f
 				case mk of
 					Nothing -> noop
 					Just k -> withObjectLoc k $

Command/Sync.hs

@@ -652,11 +652,11 @@ seekSyncContent o rs currbranch = do
 	liftIO $ not <$> isEmptyMVar mvar
   where
 	seekworktree mvar l bloomfeeder = 
-		seekHelper ww LsFiles.inRepo l
+		seekHelper id ww LsFiles.inRepo l
 			>>= gofiles bloomfeeder mvar
 
 	seekincludinghidden origbranch mvar l bloomfeeder = 
-		seekHelper ww (LsFiles.inRepoOrBranch origbranch) l 
+		seekHelper id ww (LsFiles.inRepoOrBranch origbranch) l 
 			>>= gofiles bloomfeeder mvar
 
 	ww = WarnUnmatchLsFiles

Command/TestRemote.hs

@@ -439,7 +439,7 @@ randKey sz = withTmpFile "randkey" $ \f h -> do
 	return k
 
 getReadonlyKey :: Remote -> FilePath -> Annex Key
-getReadonlyKey r f = lookupFile (toRawFilePath f) >>= \case
+getReadonlyKey r f = lookupKey (toRawFilePath f) >>= \case
 	Nothing -> giveup $ f ++ " is not an annexed file"
 	Just k -> do
 		unlessM (inAnnex k) $

Command/Unannex.hs

@@ -23,7 +23,7 @@ cmd = withGlobalOptions [annexedMatchingOptions] $
 		paramPaths (withParams seek)
 
 seek :: CmdParams -> CommandSeek
-seek ps = (withFilesInGit ww $ commandAction . whenAnnexed start)
+seek ps = (withFilesInGitAnnex ww (commandAction' start))
 	=<< workTreeItems ww ps
   where
 	ww = WarnUnmatchLsFiles

Command/Uninit.hs

@@ -44,7 +44,7 @@ seek ps = do
 	l <- workTreeItems ww ps
 	withFilesNotInGit (commandAction . whenAnnexed (startCheckIncomplete . fromRawFilePath)) l
 	Annex.changeState $ \s -> s { Annex.fast = True }
-	withFilesInGit ww (commandAction . whenAnnexed Command.Unannex.start) l
+	withFilesInGitAnnex ww (commandAction' Command.Unannex.start) l
 	finish
   where
 	ww = WarnUnmatchLsFiles

Command/Unlock.hs

@@ -27,7 +27,7 @@ mkcmd n d = withGlobalOptions [jsonOptions, annexedMatchingOptions] $
 	command n SectionCommon d paramPaths (withParams seek)
 
 seek :: CmdParams -> CommandSeek
-seek ps = withFilesInGit ww (commandAction . whenAnnexed start)
+seek ps = withFilesInGitAnnex ww (commandAction' start)
 	=<< workTreeItems ww ps
   where
 	ww = WarnUnmatchLsFiles

Command/Unused.hs

@@ -215,7 +215,7 @@ withKeysReferenced' mdir initial a = do
 		Just dir -> inRepo $ LsFiles.inRepo [] [toRawFilePath dir]
 	go v [] = return v
 	go v (f:fs) = do
-		mk <- lookupFile f
+		mk <- lookupKey f
 		case mk of
 			Nothing -> go v fs
 			Just k -> do

Command/Whereis.hs

@@ -51,13 +51,14 @@ parseFormatOption = option (Utility.Format.gen <$> str)
 seek :: WhereisOptions -> CommandSeek
 seek o = do
 	m <- remoteMap id
-	let go = whenAnnexed $ start o m
+	let go = start o m
 	case batchOption o of
-		Batch fmt -> batchFilesMatching fmt (go . toRawFilePath)
+		Batch fmt -> batchFilesMatching fmt
+			(whenAnnexed go . toRawFilePath)
 		NoBatch -> 
 			withKeyOptions (keyOptions o) False
 				(commandAction . startKeys o m)
-				(withFilesInGit ww (commandAction . go))
+				(withFilesInGitAnnex ww (commandAction' go))
 				=<< workTreeItems ww (whereisFiles o)
   where
 	ww = WarnUnmatchLsFiles

Git/CatFile.hs

@@ -20,8 +20,9 @@ module Git.CatFile (
 	catObject,
 	catObjectDetails,
 	catObjectMetaData,
+	catObjectStreamLsTree,
 	catObjectStream,
-	catObjectStream',
+	catObjectMetaDataStream,
 ) where
 
 import System.IO
@@ -289,18 +290,18 @@ parseCommit b = Commit
  - While this could be made more polymorhpic, specialization is important
  - to its performance.
  -}
-catObjectStream
+catObjectStreamLsTree
 	:: (MonadMask m, MonadIO m)
 	=> [LsTree.TreeItem]
 	-> (LsTree.TreeItem -> Bool)
 	-> Repo
 	-> (IO (Maybe (TopFilePath, Maybe L.ByteString)) -> m ())
 	-> m ()
-catObjectStream l want repo reader = withCatObjectStream repo $
+catObjectStreamLsTree l want repo reader = withCatFileStream False repo $
 	\c hin hout -> bracketIO
 		(async $ feeder c hin)
 		cancel
-		(const (reader (catObjectReader c hout)))
+		(const (reader (catObjectReader readObjectContent c hout)))
   where
 	feeder c h = do
 		forM_ l $ \ti ->
@@ -311,7 +312,7 @@ catObjectStream l want repo reader = withCatObjectStream repo $
 				S8.hPutStrLn h (fromRef' sha)
 		hClose h
 
-catObjectStream'
+catObjectStream
 	:: (MonadMask m, MonadIO m)
 	=> Repo
 	-> (
@@ -321,41 +322,70 @@ catObjectStream'
 	    -> m ()
 	   )
 	-> m ()
-catObjectStream' repo a = withCatObjectStream repo go
+catObjectStream repo a = withCatFileStream False repo go
   where
 	go c hin hout = a
 		(feeder c hin)
 		(hClose hin)
-		(catObjectReader c hout)
+		(catObjectReader readObjectContent c hout)
 	feeder c h (v, ref) = do
 		liftIO $ writeChan c (ref, v)
 		S8.hPutStrLn h (fromRef' ref)
 
-catObjectReader :: Chan (Ref, a) -> Handle -> IO (Maybe (a, Maybe L.ByteString))
+catObjectMetaDataStream
-catObjectReader c h = ifM (hIsEOF h)
+	:: (MonadMask m, MonadIO m)
+	=> Repo
+	-> (
+	    ((v, Ref) -> IO ()) -- ^ call to feed values in
+	    -> IO () -- call once all values are fed in
+	    -> IO (Maybe (v, Maybe (Sha, FileSize, ObjectType))) -- call to read results
+	    -> m ()
+	   )
+	-> m ()
+catObjectMetaDataStream repo a = withCatFileStream True repo go
+  where
+	go c hin hout = a
+		(feeder c hin)
+		(hClose hin)
+		(catObjectReader (\_h r -> pure (conv r)) c hout)
+	
+	feeder c h (v, ref) = do
+		liftIO $ writeChan c (ref, v)
+		S8.hPutStrLn h (fromRef' ref)
+	
+	conv (ParsedResp sha ty sz) = (sha, sz, ty)
+	conv DNE = error "internal"
+
+catObjectReader
+	:: (Handle -> ParsedResp -> IO t)
+	-> Chan (Ref, a)
+	-> Handle
+	-> IO (Maybe (a, Maybe t))
+catObjectReader getv c h = ifM (hIsEOF h)
 	( return Nothing
 	, do
 		(ref, f) <- liftIO $ readChan c
 		resp <- S8.hGetLine h
 		case parseResp ref resp of
 			Just r@(ParsedResp {}) -> do
-				content <- readObjectContent h r
+				v <- getv h r
-				return (Just (f, Just content))
+				return (Just (f, Just v))
 			Just DNE -> return (Just (f, Nothing))
 			Nothing -> error $ "unknown response from git cat-file " ++ show resp
 	)
 
-withCatObjectStream
+withCatFileStream
 	:: (MonadMask m, MonadIO m)
-	=> Repo
+	=> Bool
+	-> Repo
 	-> (Chan a -> Handle -> Handle -> m ())
 	-> m ()
-withCatObjectStream repo reader = assertLocal repo $
+withCatFileStream check repo reader = assertLocal repo $
 	bracketIO start stop $ \(c, hin, hout, _) -> reader c hin hout
   where
 	params = 
 		[ Param "cat-file"
-		, Param ("--batch=" ++ batchFormat)
+		, Param ("--batch" ++ (if check then "-check" else "") ++ "=" ++ batchFormat)
 		, Param "--buffer"
 		]
 

Limit.hs

@@ -372,7 +372,7 @@ addAccessedWithin duration = do
 	secs = fromIntegral (durationSeconds duration)
 
 lookupFileKey :: FileInfo -> Annex (Maybe Key)
-lookupFileKey = lookupFile . currFile
+lookupFileKey = lookupKey . currFile
 
 checkKey :: (Key -> Annex Bool) -> MatchInfo -> Annex Bool
 checkKey a (MatchingFile fi) = lookupFileKey fi >>= maybe (return False) a

Test.hs

@@ -704,7 +704,7 @@ test_lock_force = intmpclonerepo $ do
 	git_annex "get" [annexedfile] @? "get of file failed"
 	git_annex "unlock" [annexedfile] @? "unlock failed"
 	annexeval $ do
-		Just k <- Annex.WorkTree.lookupFile (toRawFilePath annexedfile)
+		Just k <- Annex.WorkTree.lookupKey (toRawFilePath annexedfile)
 		Database.Keys.removeInodeCaches k
 		Database.Keys.closeDb
 		liftIO . nukeFile =<< Annex.fromRepo Annex.Locations.gitAnnexKeysDbIndexCache
@@ -1680,7 +1680,7 @@ test_crypto = do
 			(c,k) <- annexeval $ do
 				uuid <- Remote.nameToUUID "foo"
 				rs <- Logs.Remote.readRemoteLog
-				Just k <- Annex.WorkTree.lookupFile (toRawFilePath annexedfile)
+				Just k <- Annex.WorkTree.lookupKey (toRawFilePath annexedfile)
 				return (fromJust $ M.lookup uuid rs, k)
 			let key = if scheme `elem` ["hybrid","pubkey"]
 					then Just $ Utility.Gpg.KeyIds [Utility.Gpg.testKeyId]

Test/Framework.hs

@@ -316,7 +316,7 @@ checkdangling f = ifM (annexeval Config.crippledFileSystem)
 checklocationlog :: FilePath -> Bool -> Assertion
 checklocationlog f expected = do
 	thisuuid <- annexeval Annex.UUID.getUUID
-	r <- annexeval $ Annex.WorkTree.lookupFile (toRawFilePath f)
+	r <- annexeval $ Annex.WorkTree.lookupKey (toRawFilePath f)
 	case r of
 		Just k -> do
 			uuids <- annexeval $ Remote.keyLocations k
@@ -327,7 +327,7 @@ checklocationlog f expected = do
 checkbackend :: FilePath -> Types.Backend -> Assertion
 checkbackend file expected = do
 	b <- annexeval $ maybe (return Nothing) (Backend.getBackend file) 
-		=<< Annex.WorkTree.lookupFile (toRawFilePath file)
+		=<< Annex.WorkTree.lookupKey (toRawFilePath file)
 	assertEqual ("backend for " ++ file) (Just expected) b
 
 checkispointerfile :: FilePath -> Assertion

Upgrade/V0.hs

@@ -31,8 +31,8 @@ keyFile0 :: Key -> FilePath
 keyFile0 = Upgrade.V1.keyFile1
 fileKey0 :: FilePath -> Key
 fileKey0 = Upgrade.V1.fileKey1
-lookupFile0 :: FilePath -> Annex (Maybe (Key, Backend))
+lookupKey0 :: FilePath -> Annex (Maybe (Key, Backend))
-lookupFile0 = Upgrade.V1.lookupFile1
+lookupKey0 = Upgrade.V1.lookupKey1
 
 getKeysPresent0 :: FilePath -> Annex [Key]
 getKeysPresent0 dir = ifM (liftIO $ doesDirectoryExist dir)

Upgrade/V1.hs

@@ -90,7 +90,7 @@ updateSymlinks = do
 	void $ liftIO cleanup
   where
 	fixlink f = do
-		r <- lookupFile1 f
+		r <- lookupKey1 f
 		case r of
 			Nothing -> noop
 			Just (k, _) -> do
@@ -191,8 +191,8 @@ readLog1 :: FilePath -> IO [LogLine]
 readLog1 file = catchDefaultIO [] $
 	parseLog . encodeBL <$> readFileStrict file
 
-lookupFile1 :: FilePath -> Annex (Maybe (Key, Backend))
+lookupKey1 :: FilePath -> Annex (Maybe (Key, Backend))
-lookupFile1 file = do
+lookupKey1 file = do
 	tl <- liftIO $ tryIO getsymlink
 	case tl of
 		Left _ -> return Nothing

Upgrade/V5.hs

@@ -115,7 +115,7 @@ upgradeDirectWorkTree = do
 	void $ liftIO clean
   where
 	go (f, _sha, mode) | isSymLink mode = do
-		-- Cannot use lookupFile here, as we're in between direct
+		-- Cannot use lookupKey here, as we're in between direct
 		-- mode and v6.
 		mk <- catKeyFile f
 		case mk of

Utility/Path.hs

@@ -214,22 +214,23 @@ prop_relPathDirToFile_regressionTest = same_dir_shortcurcuits_at_difference
  - we stop preserving ordering at that point. Presumably a user passing
  - that many paths in doesn't care too much about order of the later ones.
  -}
-segmentPaths :: [RawFilePath] -> [RawFilePath] -> [[RawFilePath]]
+segmentPaths :: (a -> RawFilePath) -> [RawFilePath] -> [a] -> [[a]]
-segmentPaths [] new = [new]
+segmentPaths _ [] new = [new]
-segmentPaths [_] new = [new] -- optimisation
+segmentPaths _ [_] new = [new] -- optimisation
-segmentPaths (l:ls) new = found : segmentPaths ls rest
+segmentPaths c (l:ls) new = found : segmentPaths c ls rest
   where
 	(found, rest) = if length ls < 100
 		then partition inl new
 		else break (not . inl) new
-	inl f = fromRawFilePath l `dirContains` fromRawFilePath f
+	inl f = l' `dirContains` fromRawFilePath (c f)
+	l' = fromRawFilePath l
 
 {- This assumes that it's cheaper to call segmentPaths on the result,
  - than it would be to run the action separately with each path. In
  - the case of git file list commands, that assumption tends to hold.
  -}
-runSegmentPaths :: ([RawFilePath] -> IO [RawFilePath]) -> [RawFilePath] -> IO [[RawFilePath]]
+runSegmentPaths :: (a -> RawFilePath) -> ([RawFilePath] -> IO [a]) -> [RawFilePath] -> IO [[a]]
-runSegmentPaths a paths = segmentPaths paths <$> a paths
+runSegmentPaths c a paths = segmentPaths c paths <$> a paths
 
 {- Converts paths in the home directory to use ~/ -}
 relHome :: FilePath -> IO String