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

get the most commonly used commands building again

Browse source 
A quick benchmark of whereis shows not much speed improvement, maybe a
few percent. Profiling it found a hotspot, adds to todo.
This commit is contained in:
Joey Hess 2019-12-04 13:15:34 -04:00
parent 650a631ef8
commit b88f89c1ef
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
19 changed files with 137 additions and 108 deletions
Download patch file Download diff file Expand all files Collapse all files

28
Command/Add.hs
View file

@ -50,7 +50,7 @@ optParser desc = AddOptions
seek :: AddOptions -> CommandSeek
seek o = startConcurrency commandStages $ do
matcher <- largeFilesMatcher
let gofile file = ifM (checkFileMatcher matcher file <||> Annex.getState Annex.force)
let gofile file = ifM (checkFileMatcher matcher (fromRawFilePath file) <||> Annex.getState Annex.force)
( start file
, ifM (annexAddSmallFiles <$> Annex.getGitConfig)
( startSmall file
@ -61,7 +61,7 @@ seek o = startConcurrency commandStages $ do
Batch fmt
| updateOnly o ->
giveup "--update --batch is not supported"
| otherwise -> batchFilesMatching fmt gofile
| otherwise -> batchFilesMatching fmt (gofile . toRawFilePath)
NoBatch -> do
l <- workTreeItems (addThese o)
let go a = a (commandAction . gofile) l
@ -71,28 +71,28 @@ seek o = startConcurrency commandStages $ do
go withUnmodifiedUnlockedPointers
{- Pass file off to git-add. -}
startSmall :: FilePath -> CommandStart
startSmall :: RawFilePath -> CommandStart
startSmall file = starting "add" (ActionItemWorkTreeFile file) $
next $ addSmall file
addSmall :: FilePath -> Annex Bool
addSmall :: RawFilePath -> Annex Bool
addSmall file = do
showNote "non-large file; adding content to git repository"
addFile file
addFile :: FilePath -> Annex Bool
addFile :: RawFilePath -> Annex Bool
addFile file = do
ps <- forceParams
Annex.Queue.addCommand "add" (ps++[Param "--"]) [file]
Annex.Queue.addCommand "add" (ps++[Param "--"]) [fromRawFilePath file]
return True
start :: FilePath -> CommandStart
start :: RawFilePath -> CommandStart
start file = do
mk <- liftIO $ isPointerFile file
maybe go fixuppointer mk
where
go = ifAnnexed file addpresent add
add = liftIO (catchMaybeIO $ getSymbolicLinkStatus file) >>= \case
add = liftIO (catchMaybeIO $ getSymbolicLinkStatus (fromRawFilePath file)) >>= \case
Nothing -> stop
Just s
| not (isRegularFile s) && not (isSymbolicLink s) -> stop
@ -102,28 +102,28 @@ start file = do
then next $ addFile file
else perform file
addpresent key =
liftIO (catchMaybeIO $ getSymbolicLinkStatus file) >>= \case
liftIO (catchMaybeIO $ getSymbolicLinkStatus $ fromRawFilePath file) >>= \case
Just s | isSymbolicLink s -> fixuplink key
_ -> add
fixuplink key = starting "add" (ActionItemWorkTreeFile file) $ do
-- the annexed symlink is present but not yet added to git
liftIO $ removeFile file
addLink file key Nothing
liftIO $ removeFile (fromRawFilePath file)
addLink (fromRawFilePath file) key Nothing
next $
cleanup key =<< inAnnex key
fixuppointer key = starting "add" (ActionItemWorkTreeFile file) $ do
-- the pointer file is present, but not yet added to git
Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath file)
Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath (fromRawFilePath file))
next $ addFile file
perform :: FilePath -> CommandPerform
perform :: RawFilePath -> CommandPerform
perform file = withOtherTmp $ \tmpdir -> do
lockingfile <- not <$> addUnlocked
let cfg = LockDownConfig
{ lockingFile = lockingfile
, hardlinkFileTmpDir = Just tmpdir
}
ld <- lockDown cfg file
ld <- lockDown cfg (fromRawFilePath file)
let sizer = keySource <$> ld
v <- metered Nothing sizer $ \_meter meterupdate ->
ingestAdd meterupdate ld

6
Command/Copy.hs
View file

@ -47,7 +47,7 @@ seek :: CopyOptions -> CommandSeek
seek o = startConcurrency commandStages $ do
let go = whenAnnexed $ start o
case batchOption o of
Batch fmt -> batchFilesMatching fmt go
Batch fmt -> batchFilesMatching fmt (go . toRawFilePath)
NoBatch -> withKeyOptions
(keyOptions o) (autoMode o)
(commandAction . Command.Move.startKey (fromToOptions o) Command.Move.RemoveNever)
@ -57,12 +57,12 @@ seek o = startConcurrency commandStages $ do
{- 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. -}
start :: CopyOptions -> FilePath -> Key -> CommandStart
start :: CopyOptions -> RawFilePath -> Key -> CommandStart
start o file key = stopUnless shouldCopy $
Command.Move.start (fromToOptions o) Command.Move.RemoveNever file key
where
shouldCopy
| autoMode o = want <||> numCopiesCheck file key (<)
| autoMode o = want <||> numCopiesCheck (fromRawFilePath file) key (<)
| otherwise = return True
want = case fromToOptions o of
Right (ToRemote dest) ->

4
Command/Drop.hs
View file

@ -54,7 +54,7 @@ parseDropFromOption = parseRemoteOption <$> strOption
seek :: DropOptions -> CommandSeek
seek o = startConcurrency transferStages $
case batchOption o of
Batch fmt -> batchFilesMatching fmt go
Batch fmt -> batchFilesMatching fmt (go . toRawFilePath)
NoBatch -> withKeyOptions (keyOptions o) (autoMode o)
(commandAction . startKeys o)
(withFilesInGit (commandAction . go))
@ -62,7 +62,7 @@ seek o = startConcurrency transferStages $
where
go = whenAnnexed $ start o
start :: DropOptions -> FilePath -> Key -> CommandStart
start :: DropOptions -> RawFilePath -> Key -> CommandStart
start o file key = start' o key afile ai
where
afile = AssociatedFile (Just file)

25
Command/Export.hs
View file

@ -6,6 +6,7 @@
-}
{-# LANGUAGE TupleSections, BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
module Command.Export where
@ -70,7 +71,7 @@ optParser _ = ExportOptions
-- To handle renames which swap files, the exported file is first renamed
-- to a stable temporary name based on the key.
exportTempName :: ExportKey -> ExportLocation
exportTempName ek = mkExportLocation $
exportTempName ek = mkExportLocation $ toRawFilePath $
".git-annex-tmp-content-" ++ serializeKey (asKey (ek))
seek :: ExportOptions -> CommandSeek
@ -258,9 +259,9 @@ startExport r db cvar allfilledvar ti = do
performExport r db ek af (Git.LsTree.sha ti) loc allfilledvar
)
where
loc = mkExportLocation f
loc = mkExportLocation (toRawFilePath f)
f = getTopFilePath (Git.LsTree.file ti)
af = AssociatedFile (Just f)
af = AssociatedFile (Just (toRawFilePath f))
notrecordedpresent ek = (||)
<$> liftIO (notElem loc <$> getExportedLocation db (asKey ek))
-- If content was removed from the remote, the export db
@ -316,14 +317,14 @@ startUnexport r db f shas = do
else starting ("unexport " ++ name r) (ActionItemOther (Just f')) $
performUnexport r db eks loc
where
loc = mkExportLocation f'
loc = mkExportLocation (toRawFilePath f')
f' = getTopFilePath f
startUnexport' :: Remote -> ExportHandle -> TopFilePath -> ExportKey -> CommandStart
startUnexport' r db f ek = starting ("unexport " ++ name r) (ActionItemOther (Just f')) $
performUnexport r db [ek] loc
where
loc = mkExportLocation f'
loc = mkExportLocation (toRawFilePath f')
f' = getTopFilePath f
-- Unlike a usual drop from a repository, this does not check that
@ -363,19 +364,19 @@ startRecoverIncomplete r db sha oldf
| otherwise = do
ek <- exportKey sha
let loc = exportTempName ek
starting ("unexport " ++ name r) (ActionItemOther (Just (fromExportLocation loc))) $ do
starting ("unexport " ++ name r) (ActionItemOther (Just (fromRawFilePath (fromExportLocation loc)))) $ do
liftIO $ removeExportedLocation db (asKey ek) oldloc
performUnexport r db [ek] loc
where
oldloc = mkExportLocation oldf'
oldloc = mkExportLocation (toRawFilePath oldf')
oldf' = getTopFilePath oldf
startMoveToTempName :: Remote -> ExportHandle -> TopFilePath -> ExportKey -> CommandStart
startMoveToTempName r db f ek = starting ("rename " ++ name r)
(ActionItemOther $ Just $ f' ++ " -> " ++ fromExportLocation tmploc)
(ActionItemOther $ Just $ f' ++ " -> " ++ fromRawFilePath (fromExportLocation tmploc))
(performRename r db ek loc tmploc)
where
loc = mkExportLocation f'
loc = mkExportLocation (toRawFilePath f')
f' = getTopFilePath f
tmploc = exportTempName ek
@ -383,10 +384,10 @@ startMoveFromTempName :: Remote -> ExportHandle -> ExportKey -> TopFilePath -> C
startMoveFromTempName r db ek f = do
let tmploc = exportTempName ek
stopUnless (liftIO $ elem tmploc <$> getExportedLocation db (asKey ek)) $
starting ("rename " ++ name r) (ActionItemOther (Just (fromExportLocation tmploc ++ " -> " ++ f'))) $
starting ("rename " ++ name r) (ActionItemOther (Just (fromRawFilePath (fromExportLocation tmploc) ++ " -> " ++ f'))) $
performRename r db ek tmploc loc
where
loc = mkExportLocation f'
loc = mkExportLocation (toRawFilePath f')
f' = getTopFilePath f
performRename :: Remote -> ExportHandle -> ExportKey -> ExportLocation -> ExportLocation -> CommandPerform
@ -468,7 +469,7 @@ filterPreferredContent r tree = logExportExcluded (uuid r) $ \logwriter -> do
-- Match filename relative to the
-- top of the tree.
let af = AssociatedFile $ Just $
getTopFilePath topf
toRawFilePath $ getTopFilePath topf
let mi = MatchingKey k af
ifM (checkMatcher' matcher mi mempty)
( return (Just ti)

48
Command/Fsck.hs
View file

@ -102,11 +102,11 @@ checkDeadRepo u =
whenM ((==) DeadTrusted <$> lookupTrust u) $
earlyWarning "Warning: Fscking a repository that is currently marked as dead."
start :: Maybe Remote -> Incremental -> FilePath -> Key -> CommandStart
start from inc file key = Backend.getBackend file key >>= \case
start :: Maybe Remote -> Incremental -> RawFilePath -> Key -> CommandStart
start from inc file key = Backend.getBackend (fromRawFilePath file) key >>= \case
Nothing -> stop
Just backend -> do
numcopies <- getFileNumCopies file
numcopies <- getFileNumCopies (fromRawFilePath file)
case from of
Nothing -> go $ perform key file backend numcopies
Just r -> go $ performRemote key afile backend numcopies r
@ -114,9 +114,9 @@ start from inc file key = Backend.getBackend file key >>= \case
go = runFsck inc (mkActionItem (key, afile)) key
afile = AssociatedFile (Just file)
perform :: Key -> FilePath -> Backend -> NumCopies -> Annex Bool
perform :: Key -> RawFilePath -> Backend -> NumCopies -> Annex Bool
perform key file backend numcopies = do
keystatus <- getKeyFileStatus key file
keystatus <- getKeyFileStatus key (fromRawFilePath file)
check
-- order matters
[ fixLink key file
@ -203,18 +203,18 @@ check :: [Annex Bool] -> Annex Bool
check cs = and <$> sequence cs
{- Checks that symlinks points correctly to the annexed content. -}
fixLink :: Key -> FilePath -> Annex Bool
fixLink :: Key -> RawFilePath -> Annex Bool
fixLink key file = do
want <- calcRepo $ gitAnnexLink file key
want <- calcRepo $ gitAnnexLink (fromRawFilePath file) key
have <- getAnnexLinkTarget file
maybe noop (go want) have
return True
where
go want have
| want /= fromInternalGitPath (fromRawFilePath have) = do
| want /= fromRawFilePath (fromInternalGitPath have) = do
showNote "fixing link"
liftIO $ createDirectoryIfMissing True (parentDir file)
liftIO $ removeFile file
liftIO $ createDirectoryIfMissing True (parentDir (fromRawFilePath file))
liftIO $ removeFile (fromRawFilePath file)
addAnnexLink want file
| otherwise = noop
@ -267,7 +267,7 @@ verifyLocationLog' key ai present u updatestatus = do
fix InfoMissing
warning $
"** Based on the location log, " ++
actionItemDesc ai ++
decodeBS' (actionItemDesc ai) ++
"\n** was expected to be present, " ++
"but its content is missing."
return False
@ -302,23 +302,23 @@ verifyRequiredContent key ai@(ActionItemAssociatedFile afile _) = do
missingrequired <- Remote.prettyPrintUUIDs "missingrequired" missinglocs
warning $
"** Required content " ++
actionItemDesc ai ++
decodeBS' (actionItemDesc ai) ++
" is missing from these repositories:\n" ++
missingrequired
return False
verifyRequiredContent _ _ = return True
{- Verifies the associated file records. -}
verifyAssociatedFiles :: Key -> KeyStatus -> FilePath -> Annex Bool
verifyAssociatedFiles :: Key -> KeyStatus -> RawFilePath -> Annex Bool
verifyAssociatedFiles key keystatus file = do
when (isKeyUnlockedThin keystatus) $ do
f <- inRepo $ toTopFilePath file
f <- inRepo $ toTopFilePath $ fromRawFilePath file
afs <- Database.Keys.getAssociatedFiles key
unless (getTopFilePath f `elem` map getTopFilePath afs) $
Database.Keys.addAssociatedFile key f
return True
verifyWorkTree :: Key -> FilePath -> Annex Bool
verifyWorkTree :: Key -> RawFilePath -> Annex Bool
verifyWorkTree key file = do
{- Make sure that a pointer file is replaced with its content,
- when the content is available. -}
@ -326,8 +326,8 @@ verifyWorkTree key file = do
case mk of
Just k | k == key -> whenM (inAnnex key) $ do
showNote "fixing worktree content"
replaceFile file $ \tmp -> do
mode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus file
replaceFile (fromRawFilePath file) $ \tmp -> do
mode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus (fromRawFilePath file)
ifM (annexThin <$> Annex.getGitConfig)
( void $ linkFromAnnex key tmp mode
, do
@ -335,7 +335,7 @@ verifyWorkTree key file = do
void $ checkedCopyFile key obj tmp mode
thawContent tmp
)
Database.Keys.storeInodeCaches key [file]
Database.Keys.storeInodeCaches key [fromRawFilePath file]
_ -> return ()
return True
@ -375,7 +375,7 @@ checkKeySizeOr bad key file ai = case fromKey keySize key of
badsize a b = do
msg <- bad key
warning $ concat
[ actionItemDesc ai
[ decodeBS' (actionItemDesc ai)
, ": Bad file size ("
, compareSizes storageUnits True a b
, "); "
@ -393,11 +393,11 @@ checkKeyUpgrade backend key ai (AssociatedFile (Just file)) =
case Types.Backend.canUpgradeKey backend of
Just a | a key -> do
warning $ concat
[ actionItemDesc ai
[ decodeBS' (actionItemDesc ai)
, ": Can be upgraded to an improved key format. "
, "You can do so by running: git annex migrate --backend="
, decodeBS (formatKeyVariety (fromKey keyVariety key)) ++ " "
, file
, decodeBS' file
]
return True
_ -> return True
@ -448,7 +448,7 @@ checkBackendOr' bad backend key file ai postcheck =
unless ok $ do
msg <- bad key
warning $ concat
[ actionItemDesc ai
[ decodeBS' (actionItemDesc ai)
, ": Bad file content; "
, msg
]
@ -460,7 +460,7 @@ checkKeyNumCopies :: Key -> AssociatedFile -> NumCopies -> Annex Bool
checkKeyNumCopies key afile numcopies = do
let (desc, hasafile) = case afile of
AssociatedFile Nothing -> (serializeKey key, False)
AssociatedFile (Just af) -> (af, True)
AssociatedFile (Just af) -> (fromRawFilePath af, True)
locs <- loggedLocations key
(untrustedlocations, otherlocations) <- trustPartition UnTrusted locs
(deadlocations, safelocations) <- trustPartition DeadTrusted otherlocations
@ -680,7 +680,7 @@ getKeyFileStatus key file = do
s <- getKeyStatus key
case s of
KeyUnlockedThin -> catchDefaultIO KeyUnlockedThin $
ifM (isJust <$> isAnnexLink file)
ifM (isJust <$> isAnnexLink (toRawFilePath file))
( return KeyLockedThin
, return KeyUnlockedThin
)

6
Command/Get.hs
View file

@ -42,19 +42,19 @@ seek o = startConcurrency transferStages $ do
from <- maybe (pure Nothing) (Just <$$> getParsed) (getFrom o)
let go = whenAnnexed $ start o from
case batchOption o of
Batch fmt -> batchFilesMatching fmt go
Batch fmt -> batchFilesMatching fmt (go . toRawFilePath)
NoBatch -> withKeyOptions (keyOptions o) (autoMode o)
(commandAction . startKeys from)
(withFilesInGit (commandAction . go))
=<< workTreeItems (getFiles o)
start :: GetOptions -> Maybe Remote -> FilePath -> Key -> CommandStart
start :: GetOptions -> Maybe Remote -> RawFilePath -> Key -> CommandStart
start o from file key = start' expensivecheck from key afile ai
where
afile = AssociatedFile (Just file)
ai = mkActionItem (key, afile)
expensivecheck
| autoMode o = numCopiesCheck file key (<)
| autoMode o = numCopiesCheck (fromRawFilePath file) key (<)
<||> wantGet False (Just key) afile
| otherwise = return True

4
Command/Import.hs
View file

@ -117,7 +117,7 @@ seek o@(RemoteImportOptions {}) = startConcurrency commandStages $ do
startLocal :: GetFileMatcher -> DuplicateMode -> (FilePath, FilePath) -> CommandStart
startLocal largematcher mode (srcfile, destfile) =
ifM (liftIO $ isRegularFile <$> getSymbolicLinkStatus srcfile)
( starting "import" (ActionItemWorkTreeFile destfile)
( starting "import" (ActionItemWorkTreeFile (toRawFilePath destfile))
pickaction
, stop
)
@ -202,7 +202,7 @@ startLocal largematcher mode (srcfile, destfile) =
>>= maybe
stop
(\addedk -> next $ Command.Add.cleanup addedk True)
, next $ Command.Add.addSmall destfile
, next $ Command.Add.addSmall $ toRawFilePath destfile
)
notoverwriting why = do
warning $ "not overwriting existing " ++ destfile ++ " " ++ why

4
Command/Move.hs
View file

@ -57,13 +57,13 @@ seek :: MoveOptions -> CommandSeek
seek o = startConcurrency transferStages $ do
let go = whenAnnexed $ start (fromToOptions o) (removeWhen o)
case batchOption o of
Batch fmt -> batchFilesMatching fmt go
Batch fmt -> batchFilesMatching fmt (go . toRawFilePath)
NoBatch -> withKeyOptions (keyOptions o) False
(commandAction . startKey (fromToOptions o) (removeWhen o))
(withFilesInGit (commandAction . go))
=<< workTreeItems (moveFiles o)
start :: FromToHereOptions -> RemoveWhen -> FilePath -> Key -> CommandStart
start :: FromToHereOptions -> RemoveWhen -> RawFilePath -> Key -> CommandStart
start fromto removewhen f k = start' fromto removewhen afile k ai
where
afile = AssociatedFile (Just f)

4
Command/Reinject.hs
View file

@ -42,7 +42,7 @@ seek os
startSrcDest :: [FilePath] -> CommandStart
startSrcDest (src:dest:[])
| src == dest = stop
| otherwise = notAnnexed src $ ifAnnexed dest go stop
| otherwise = notAnnexed src $ ifAnnexed (toRawFilePath dest) go stop
where
go key = starting "reinject" (ActionItemOther (Just src)) $
ifM (verifyKeyContent RetrievalAllKeysSecure DefaultVerify UnVerified key src)
@ -65,7 +65,7 @@ startKnown src = notAnnexed src $
)
notAnnexed :: FilePath -> CommandStart -> CommandStart
notAnnexed src = ifAnnexed src $
notAnnexed src = ifAnnexed (toRawFilePath src) $
giveup $ "cannot used annexed file as src: " ++ src
perform :: FilePath -> Key -> CommandPerform

1
Command/Sync.hs
View file

@ -7,6 +7,7 @@
-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
module Command.Sync (
cmd,

4
Command/Whereis.hs
View file

@ -40,14 +40,14 @@ seek o = do
m <- remoteMap id
let go = whenAnnexed $ start m
case batchOption o of
Batch fmt -> batchFilesMatching fmt go
Batch fmt -> batchFilesMatching fmt (go . toRawFilePath)
NoBatch ->
withKeyOptions (keyOptions o) False
(commandAction . startKeys m)
(withFilesInGit (commandAction . go))
=<< workTreeItems (whereisFiles o)
start :: M.Map UUID Remote -> FilePath -> Key -> CommandStart
start :: M.Map UUID Remote -> RawFilePath -> Key -> CommandStart
start remotemap file key = startKeys remotemap (key, mkActionItem (key, afile))
where
afile = AssociatedFile (Just file)