mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

add SeekInput (not yet used)

Browse source 
No behavior changes (hopefully), just adding SeekInput and plumbing it
through to the JSON display code for later use.

Over the course of 2 grueling days.

withFilesNotInGit reimplemented in terms of seekHelper
should be the only possible behavior change. It seems to test as
behaving the same.

Note that seekHelper dummies up the SeekInput in the case where
segmentPaths' gives up on sorting the expanded paths because there are
too many input paths. When SeekInput later gets exposed as a json field,
that will result in it being a little bit wrong in the case where
100 or more paths are passed to a git-annex command. I think this is a
subtle enough problem to not matter. If it does turn out to be a
problem, fixing it would require splitting up the input
parameters into groups of < 100, which would make git ls-files run
perhaps more than is necessary. May want to revisit this, because that
fix seems fairly low-impact.
This commit is contained in:
Joey Hess 2020-09-14 16:49:33 -04:00
parent a1accac084
commit 3a05d53761
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
88 changed files with 561 additions and 405 deletions
Download patch file Download diff file Expand all files Collapse all files

39
CmdLine/Batch.hs
View file

@ -42,7 +42,7 @@ parseBatchOption = go
-- In batch mode, one line at a time is read, parsed, and a reply output to
-- stdout. In non batch mode, the command's parameters are parsed and
-- a reply output for each.
batchable :: (opts -> String -> Annex Bool) -> Parser opts -> CmdParamsDesc -> CommandParser
batchable :: (opts -> SeekInput -> String -> Annex Bool) -> Parser opts -> CmdParamsDesc -> CommandParser
batchable handler parser paramdesc = batchseeker <$> batchparser
where
batchparser = (,,)
@ -51,12 +51,12 @@ batchable handler parser paramdesc = batchseeker <$> batchparser
<*> cmdParams paramdesc
batchseeker (opts, NoBatch, params) =
mapM_ (go NoBatch opts) params
mapM_ (\p -> go NoBatch opts (SeekInput [p], p)) params
batchseeker (opts, batchmode@(Batch fmt), _) =
batchInput fmt (pure . Right) (go batchmode opts)
go batchmode opts p =
unlessM (handler opts p) $
go batchmode opts (si, p) =
unlessM (handler opts si p) $
batchBadInput batchmode
-- bad input is indicated by an empty line in batch mode. In non batch
@ -72,12 +72,12 @@ batchBadInput (Batch _) = liftIO $ putStrLn ""
-- be converted to relative. Normally, filename parameters are passed
-- through git ls-files, which makes them relative, but batch mode does
-- not use that, and absolute worktree files are likely to cause breakage.
batchInput :: BatchFormat -> (String -> Annex (Either String a)) -> (a -> Annex ()) -> Annex ()
batchInput :: BatchFormat -> (String -> Annex (Either String v)) -> ((SeekInput, v) -> Annex ()) -> Annex ()
batchInput fmt parser a = go =<< batchLines fmt
where
go [] = return ()
go (l:rest) = do
either parseerr a =<< parser l
either parseerr (\v -> a (SeekInput [l], v)) =<< parser l
go rest
parseerr s = giveup $ "Batch input parse failure: " ++ s
@ -107,28 +107,29 @@ batchCommandAction a = maybe (batchBadInput (Batch BatchLine)) (const noop)
-- Absolute filepaths are converted to relative.
--
-- File matching options are not checked.
batchStart :: BatchFormat -> (FilePath -> CommandStart) -> Annex ()
batchStart :: BatchFormat -> (SeekInput -> FilePath -> CommandStart) -> Annex ()
batchStart fmt a = batchInput fmt (Right <$$> liftIO . relPathCwdToFile) $
batchCommandAction . a
batchCommandAction . uncurry a
-- Like batchStart, but checks the file matching options
-- and skips non-matching files.
batchFilesMatching :: BatchFormat -> (RawFilePath -> CommandStart) -> Annex ()
batchFilesMatching :: BatchFormat -> ((SeekInput, RawFilePath) -> CommandStart) -> Annex ()
batchFilesMatching fmt a = do
matcher <- getMatcher
batchStart fmt $ \f ->
batchStart fmt $ \si f ->
let f' = toRawFilePath f
in ifM (matcher $ MatchingFile $ FileInfo f' f')
( a f'
( a (si, 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
batchAnnexedFilesMatching fmt seeker = batchFilesMatching fmt $ \(si, bf) ->
flip whenAnnexed bf $ \f k ->
case checkContentPresent seeker of
Just v -> do
present <- inAnnex k
if present == v
then startAction seeker si f k
else return Nothing
Nothing -> startAction seeker si f k

97
CmdLine/Seek.hs
View file

@ -50,7 +50,7 @@ import Control.Concurrent.Async
import System.Posix.Types
data AnnexedFileSeeker = AnnexedFileSeeker
{ startAction :: RawFilePath -> Key -> CommandStart
{ startAction :: SeekInput -> RawFilePath -> Key -> CommandStart
, checkContentPresent :: Maybe Bool
, usesLocationLog :: Bool
}
@ -74,25 +74,18 @@ withFilesInGitAnnexNonRecursive ww needforce a (WorkTreeItems l) = ifM (Annex.ge
case fs of
[f] -> do
void $ liftIO $ cleanup
getfiles (f:c) ps
getfiles ((SeekInput [p], f):c) ps
[] -> do
void $ liftIO $ cleanup
getfiles c ps
_ -> giveup needforce
withFilesInGitAnnexNonRecursive _ _ _ NoWorkTreeItems = noop
withFilesNotInGit :: (RawFilePath -> CommandSeek) -> WorkTreeItems -> CommandSeek
withFilesNotInGit a (WorkTreeItems l) = go =<< seek
where
seek = do
force <- Annex.getState Annex.force
g <- gitRepo
liftIO $ Git.Command.leaveZombie
<$> LsFiles.notInRepo [] force l' g
go fs = seekFiltered a $
return $ concat $ segmentPaths id l' fs
l' = map toRawFilePath l
withFilesNotInGit _ NoWorkTreeItems = noop
withFilesNotInGit :: WarnUnmatchWhen -> ((SeekInput, RawFilePath) -> CommandSeek) -> WorkTreeItems -> CommandSeek
withFilesNotInGit ww a l = do
force <- Annex.getState Annex.force
seekFiltered a $
seekHelper id ww (const $ LsFiles.notInRepo [] force) l
withPathContents :: ((FilePath, FilePath) -> CommandSeek) -> CmdParams -> CommandSeek
withPathContents a params = do
@ -119,23 +112,24 @@ withWords a params = a params
withStrings :: (String -> CommandSeek) -> CmdParams -> CommandSeek
withStrings a params = sequence_ $ map a params
withPairs :: ((String, String) -> CommandSeek) -> CmdParams -> CommandSeek
withPairs a params = sequence_ $ map a $ pairs [] params
withPairs :: ((SeekInput, (String, String)) -> CommandSeek) -> CmdParams -> CommandSeek
withPairs a params = sequence_ $
map (\p@(x,y) -> a (SeekInput [x,y], p)) (pairs [] params)
where
pairs c [] = reverse c
pairs c (x:y:xs) = pairs ((x,y):c) xs
pairs _ _ = giveup "expected pairs"
withFilesToBeCommitted :: (RawFilePath -> CommandSeek) -> WorkTreeItems -> CommandSeek
withFilesToBeCommitted :: ((SeekInput, RawFilePath) -> CommandSeek) -> WorkTreeItems -> CommandSeek
withFilesToBeCommitted a l = seekFiltered a $
seekHelper id WarnUnmatchWorkTreeItems (const LsFiles.stagedNotDeleted) l
{- unlocked pointer files that are staged, and whose content has not been
- modified-}
withUnmodifiedUnlockedPointers :: WarnUnmatchWhen -> (RawFilePath -> CommandSeek) -> WorkTreeItems -> CommandSeek
withUnmodifiedUnlockedPointers :: WarnUnmatchWhen -> ((SeekInput, RawFilePath) -> CommandSeek) -> WorkTreeItems -> CommandSeek
withUnmodifiedUnlockedPointers ww a l = seekFiltered a unlockedfiles
where
unlockedfiles = filterM isUnmodifiedUnlocked
unlockedfiles = filterM (isUnmodifiedUnlocked . snd)
=<< seekHelper id ww (const LsFiles.typeChangedStaged) l
isUnmodifiedUnlocked :: RawFilePath -> Annex Bool
@ -144,12 +138,12 @@ isUnmodifiedUnlocked f = catKeyFile f >>= \case
Just k -> sameInodeCache f =<< Database.Keys.getInodeCaches k
{- Finds files that may be modified. -}
withFilesMaybeModified :: WarnUnmatchWhen -> (RawFilePath -> CommandSeek) -> WorkTreeItems -> CommandSeek
withFilesMaybeModified :: WarnUnmatchWhen -> ((SeekInput, RawFilePath) -> CommandSeek) -> WorkTreeItems -> CommandSeek
withFilesMaybeModified ww a params = seekFiltered a $
seekHelper id ww LsFiles.modified params
withKeys :: (Key -> CommandSeek) -> CmdParams -> CommandSeek
withKeys a l = sequence_ $ map (a . parse) l
withKeys :: ((SeekInput, Key) -> CommandSeek) -> CmdParams -> CommandSeek
withKeys a ls = sequence_ $ map (\l -> a (SeekInput [l], parse l)) ls
where
parse p = fromMaybe (giveup "bad key") $ deserializeKey p
@ -170,7 +164,7 @@ withKeyOptions
:: Maybe KeyOptions
-> Bool
-> AnnexedFileSeeker
-> ((Key, ActionItem) -> CommandSeek)
-> ((SeekInput, Key, ActionItem) -> CommandSeek)
-> (WorkTreeItems -> CommandSeek)
-> WorkTreeItems
-> CommandSeek
@ -178,7 +172,7 @@ withKeyOptions ko auto seeker keyaction = withKeyOptions' ko auto mkkeyaction
where
mkkeyaction = do
matcher <- Limit.getMatcher
return $ \v@(k, ai) -> checkseeker k $
return $ \v@(_si, k, ai) -> checkseeker k $
let i = case ai of
ActionItemBranchFilePath (BranchFilePath _ topf) _ ->
MatchingKey k (AssociatedFile $ Just $ getTopFilePath topf)
@ -194,7 +188,7 @@ withKeyOptions ko auto seeker keyaction = withKeyOptions' ko auto mkkeyaction
withKeyOptions'
:: Maybe KeyOptions
-> Bool
-> Annex ((Key, ActionItem) -> Annex ())
-> Annex ((SeekInput, Key, ActionItem) -> Annex ())
-> (WorkTreeItems -> CommandSeek)
-> WorkTreeItems
-> CommandSeek
@ -245,7 +239,7 @@ withKeyOptions' ko auto mkkeyaction fallbackaction worktreeitems = do
Nothing -> return ()
Just ((k, f), content) -> do
maybe noop (Annex.BranchState.setCache f) content
keyaction (k, mkActionItem k)
keyaction (SeekInput [], k, mkActionItem k)
go reader
catObjectStreamLsTree l (getk . getTopFilePath . LsTree.file) g go
liftIO $ void cleanup
@ -253,7 +247,7 @@ withKeyOptions' ko auto mkkeyaction fallbackaction worktreeitems = do
runkeyaction getks = do
keyaction <- mkkeyaction
ks <- getks
forM_ ks $ \k -> keyaction (k, mkActionItem k)
forM_ ks $ \k -> keyaction (SeekInput [], k, mkActionItem k)
runbranchkeys bs = do
keyaction <- mkkeyaction
@ -263,7 +257,7 @@ withKeyOptions' ko auto mkkeyaction fallbackaction worktreeitems = do
Nothing -> noop
Just k ->
let bfp = mkActionItem (BranchFilePath b (LsTree.file i), k)
in keyaction (k, bfp)
in keyaction (SeekInput [], k, bfp)
unlessM (liftIO cleanup) $
error ("git ls-tree " ++ Git.fromRef b ++ " failed")
@ -272,21 +266,21 @@ withKeyOptions' ko auto mkkeyaction fallbackaction worktreeitems = do
rs <- remoteList
ts <- concat <$> mapM (getFailedTransfers . Remote.uuid) rs
forM_ ts $ \(t, i) ->
keyaction (transferKey t, mkActionItem (t, i))
keyaction (SeekInput [], transferKey t, mkActionItem (t, i))
seekFiltered :: (RawFilePath -> CommandSeek) -> Annex [RawFilePath] -> Annex ()
seekFiltered :: ((SeekInput, RawFilePath) -> CommandSeek) -> Annex [(SeekInput, RawFilePath)] -> Annex ()
seekFiltered a fs = do
matcher <- Limit.getMatcher
sequence_ =<< (map (process matcher) <$> fs)
where
process matcher f =
whenM (matcher $ MatchingFile $ FileInfo f f) $ a f
process matcher v@(_si, f) =
whenM (matcher $ MatchingFile $ FileInfo f f) (a v)
-- This is significantly faster than using lookupKey after seekFiltered,
-- because of the way data is streamed through git cat-file.
--
-- It can also precache location logs using the same efficient streaming.
seekFilteredKeys :: AnnexedFileSeeker -> Annex [(RawFilePath, Git.Sha, FileMode)] -> Annex ()
seekFilteredKeys :: AnnexedFileSeeker -> Annex [(SeekInput, (RawFilePath, Git.Sha, FileMode))] -> Annex ()
seekFilteredKeys seeker listfs = do
g <- Annex.gitRepo
matcher <- Limit.getMatcher
@ -317,38 +311,38 @@ seekFilteredKeys seeker listfs = do
Nothing -> cont
finisher oreader = liftIO oreader >>= \case
Just (f, content) -> do
Just ((si, f), content) -> do
case parseLinkTargetOrPointerLazy =<< content of
Just k -> checkpresence k $
commandAction $
startAction seeker f k
startAction seeker si f k
Nothing -> noop
finisher oreader
Nothing -> return ()
precachefinisher lreader = liftIO lreader >>= \case
Just ((logf, f, k), logcontent) -> do
Just ((logf, (si, f), k), logcontent) -> do
maybe noop (Annex.BranchState.setCache logf) logcontent
commandAction $ startAction seeker f k
commandAction $ startAction seeker si f k
precachefinisher lreader
Nothing -> return ()
precacher config oreader lfeeder lcloser = liftIO oreader >>= \case
Just (f, content) -> do
Just ((si, f), content) -> do
case parseLinkTargetOrPointerLazy =<< content of
Just k -> checkpresence k $
let logf = locationLogFile config k
ref = Git.Ref.branchFileRef Annex.Branch.fullname logf
in liftIO $ lfeeder ((logf, f, k), ref)
in liftIO $ lfeeder ((logf, (si, f), k), ref)
Nothing -> noop
precacher config oreader lfeeder lcloser
Nothing -> liftIO $ void lcloser
feedmatches matcher ofeeder f sha =
feedmatches matcher ofeeder si f sha =
whenM (matcher $ MatchingFile $ FileInfo f f) $
liftIO $ ofeeder (f, sha)
liftIO $ ofeeder ((si, f), sha)
process matcher ofeeder mdfeeder mdcloser seenpointer ((f, sha, mode):rest) =
process matcher ofeeder mdfeeder mdcloser seenpointer ((si, (f, sha, mode)):rest) =
case Git.toTreeItemType mode of
Just Git.TreeSymlink -> do
whenM (exists f) $
@ -358,8 +352,8 @@ seekFilteredKeys seeker listfs = do
-- slower, but preserves the requested
-- file order.
if seenpointer
then liftIO $ mdfeeder (f, sha)
else feedmatches matcher ofeeder f sha
then liftIO $ mdfeeder ((si, f), sha)
else feedmatches matcher ofeeder si f sha
process matcher ofeeder mdfeeder mdcloser seenpointer rest
Just Git.TreeSubmodule ->
process matcher ofeeder mdfeeder mdcloser seenpointer rest
@ -368,7 +362,7 @@ seekFilteredKeys seeker listfs = do
-- large files by first looking up the size.
Just _ -> do
whenM (exists f) $
liftIO $ mdfeeder (f, sha)
liftIO $ mdfeeder ((si, f), sha)
process matcher ofeeder mdfeeder mdcloser True rest
Nothing ->
process matcher ofeeder mdfeeder mdcloser seenpointer rest
@ -379,19 +373,24 @@ seekFilteredKeys seeker listfs = do
exists p = isJust <$> liftIO (catchMaybeIO $ R.getSymbolicLinkStatus p)
mdprocess matcher mdreader ofeeder ocloser = liftIO mdreader >>= \case
Just (f, Just (sha, size, _type))
Just ((si, f), Just (sha, size, _type))
| size < maxPointerSz -> do
feedmatches matcher ofeeder f sha
feedmatches matcher ofeeder si f sha
mdprocess matcher mdreader ofeeder ocloser
Just _ -> mdprocess matcher mdreader ofeeder ocloser
Nothing -> liftIO $ void ocloser
seekHelper :: (a -> RawFilePath) -> WarnUnmatchWhen -> ([LsFiles.Options] -> [RawFilePath] -> Git.Repo -> IO ([a], IO Bool)) -> WorkTreeItems -> Annex [a]
seekHelper :: (a -> RawFilePath) -> WarnUnmatchWhen -> ([LsFiles.Options] -> [RawFilePath] -> Git.Repo -> IO ([a], IO Bool)) -> WorkTreeItems -> Annex [(SeekInput, a)]
seekHelper c ww a (WorkTreeItems l) = do
os <- seekOptions ww
inRepo $ \g ->
concat . concat <$> forM (segmentXargsOrdered l)
(runSegmentPaths c (\fs -> Git.Command.leaveZombie <$> a os fs g) . map toRawFilePath)
(runSegmentPaths' mk c (\fs -> Git.Command.leaveZombie <$> a os fs g) . map toRawFilePath)
where
mk (Just i) f = (SeekInput [fromRawFilePath i], f)
-- This is not accurate, but it only happens when there are a
-- great many input WorkTreeItems.
mk Nothing f = (SeekInput [fromRawFilePath (c f)], f)
seekHelper _ _ _ NoWorkTreeItems = return []
data WarnUnmatchWhen = WarnUnmatchLsFiles | WarnUnmatchWorkTreeItems