Merge branch 'streamkeys'

This commit is contained in:
Joey Hess 2020-07-10 15:49:17 -04:00
commit 7f1a6fac06
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
39 changed files with 214 additions and 144 deletions

View file

@ -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

View file

@ -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)
lookupFile = lookupFile' catkeyfile
lookupKey :: RawFilePath -> Annex (Maybe Key)
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)
lookupFileNotHidden = lookupFile' catkeyfile
lookupKeyNotHidden :: RawFilePath -> Annex (Maybe Key)
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)
lookupFile' catkeyfile file = isAnnexLink file >>= \case
lookupKey' :: (RawFilePath -> Annex (Maybe Key)) -> RawFilePath -> Annex (Maybe Key)
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.
-

View file

@ -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. -}

View file

@ -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

View file

@ -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

View file

@ -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).

View file

@ -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.

View file

@ -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 $
seekHelper ww LsFiles.inRepo l
withFilesInGit ww a l = seekFiltered a $
seekHelper id ww LsFiles.inRepo l
withFilesInGitNonRecursive :: WarnUnmatchWhen -> String -> (RawFilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek
withFilesInGitNonRecursive ww needforce a l = ifM (Annex.getState Annex.force)
( withFilesInGit ww a l
withFilesInGitAnnex :: WarnUnmatchWhen -> (RawFilePath -> Key -> CommandSeek) -> [WorkTreeItem] -> CommandSeek
withFilesInGitAnnex ww a l = seekFilteredKeys a $
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 $
return $ concat $ segmentPaths (map (\(WorkTreeItem f) -> toRawFilePath f) l) fs
go fs = seekFiltered a $
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 $
seekHelper WarnUnmatchWorkTreeItems (const LsFiles.stagedNotDeleted) l
isOldUnlocked :: RawFilePath -> Annex Bool
isOldUnlocked f = liftIO (notSymlink f) <&&>
(isJust <$> catKeyFile f <||> isJust <$> catKeyFileHEAD f)
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) -> [WorkTreeItem] -> CommandSeek
withUnmodifiedUnlockedPointers ww a l = seekActions $
prepFiltered a unlockedfiles
withUnmodifiedUnlockedPointers ww a l = seekFiltered 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 $
prepFiltered a $ seekHelper ww LsFiles.modified params
withFilesMaybeModified ww a params = seekFiltered a $
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]
prepFiltered a fs = do
seekFiltered :: (RawFilePath -> CommandSeek) -> Annex [RawFilePath] -> Annex ()
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 ()
seekActions gen = sequence_ =<< gen
-- This is significantly faster than using lookupKey after seekFiltered.
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]
seekHelper ww a l = do
goread reader = liftIO reader >>= \case
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

View file

@ -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

View file

@ -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

View file

@ -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.

View file

@ -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

View file

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

View file

@ -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

View file

@ -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

View file

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

View file

@ -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

View file

@ -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
startNew file key = ifM (isJust <$> isAnnexLink file)
start :: RawFilePath -> Key -> CommandStart
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
performNew file key = do
perform :: RawFilePath -> Key -> CommandPerform
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
cleanupNew file key = do
cleanup :: RawFilePath -> Key -> CommandCleanup
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)"

View file

@ -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
(commandAction . (whenAnnexed $ start o outputter))
(fs, False) -> withFilesInGitAnnex ww
(commandAction' (start o outputter))
=<< workTreeItems ww fs
([], True) -> commandAction (startAll o outputter)
(_, True) -> giveup "Cannot specify both files and --all"

View file

@ -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
GetAll -> withFilesInGit ww
Set _ -> withFilesInGitNonRecursive ww
Get _ -> withFilesInGitAnnex ww
GetAll -> withFilesInGitAnnex 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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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 $

View file

@ -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

View file

@ -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) $

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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))
catObjectReader c h = ifM (hIsEOF h)
catObjectMetaDataStream
:: (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
return (Just (f, Just content))
v <- getv h r
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"
]

View file

@ -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

View file

@ -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]

View file

@ -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

View file

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

View file

@ -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))
lookupFile1 file = do
lookupKey1 :: FilePath -> Annex (Maybe (Key, Backend))
lookupKey1 file = do
tl <- liftIO $ tryIO getsymlink
case tl of
Left _ -> return Nothing

View file

@ -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

View file

@ -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 [] new = [new]
segmentPaths [_] new = [new] -- optimisation
segmentPaths (l:ls) new = found : segmentPaths ls rest
segmentPaths :: (a -> RawFilePath) -> [RawFilePath] -> [a] -> [[a]]
segmentPaths _ [] new = [new]
segmentPaths _ [_] new = [new] -- optimisation
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 paths = segmentPaths paths <$> a paths
runSegmentPaths :: (a -> RawFilePath) -> ([RawFilePath] -> IO [a]) -> [RawFilePath] -> IO [[a]]
runSegmentPaths c a paths = segmentPaths c paths <$> a paths
{- Converts paths in the home directory to use ~/ -}
relHome :: FilePath -> IO String