get the most commonly used commands building again

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

View file

@ -49,7 +49,8 @@ type Reason = String
handleDropsFrom :: [UUID] -> [Remote] -> Reason -> Bool -> Key -> AssociatedFile -> [VerifiedCopy] -> (CommandStart -> CommandCleanup) -> Annex ()
handleDropsFrom locs rs reason fromhere key afile preverified runner = do
g <- Annex.gitRepo
l <- map (`fromTopFilePath` g) <$> Database.Keys.getAssociatedFiles key
l <- map toRawFilePath . map (`fromTopFilePath` g)
<$> Database.Keys.getAssociatedFiles key
let fs = case afile of
AssociatedFile (Just f) -> nub (f : l)
AssociatedFile Nothing -> l
@ -62,7 +63,7 @@ handleDropsFrom locs rs reason fromhere key afile preverified runner = do
(untrusted, have) <- trustPartition UnTrusted locs
numcopies <- if null fs
then getNumCopies
else maximum <$> mapM getFileNumCopies fs
else maximum <$> mapM (getFileNumCopies . fromRawFilePath) fs
return (NumCopies (length have), numcopies, S.fromList untrusted)
{- Check that we have enough copies still to drop the content.
@ -107,7 +108,7 @@ handleDropsFrom locs rs reason fromhere key afile preverified runner = do
[ "dropped"
, case afile of
AssociatedFile Nothing -> serializeKey key
AssociatedFile (Just af) -> af
AssociatedFile (Just af) -> fromRawFilePath af
, "(from " ++ maybe "here" show u ++ ")"
, "(copies now " ++ show (fromNumCopies have - 1) ++ ")"
, ": " ++ reason

View file

@ -264,7 +264,7 @@ buildImportTrees basetree msubdir importable = History
graftTree' importtree subdir basetree repo hdl
mktreeitem (loc, k) = do
let lf = fromImportLocation loc
let lf = fromRawFilePath (fromImportLocation loc)
let treepath = asTopFilePath lf
let topf = asTopFilePath $
maybe lf (\sd -> getTopFilePath sd </> lf) msubdir
@ -327,7 +327,7 @@ downloadImport remote importtreeconfig importablecontents = do
(k:_) -> return $ Left $ Just (loc, k)
[] -> do
job <- liftIO $ newEmptyTMVarIO
let ai = ActionItemOther (Just (fromImportLocation loc))
let ai = ActionItemOther (Just (fromRawFilePath (fromImportLocation loc)))
let downloadaction = starting ("import " ++ Remote.name remote) ai $ do
when oldversion $
showNote "old version"
@ -377,9 +377,9 @@ downloadImport remote importtreeconfig importablecontents = do
fmap fst <$> genKey ks nullMeterUpdate backend
locworktreefilename loc = asTopFilePath $ case importtreeconfig of
ImportTree -> fromImportLocation loc
ImportTree -> fromRawFilePath (fromImportLocation loc)
ImportSubTree subdir _ ->
getTopFilePath subdir </> fromImportLocation loc
getTopFilePath subdir </> fromRawFilePath (fromImportLocation loc)
getcidkey cidmap db cid = liftIO $
CIDDb.getContentIdentifierKeys db rs cid >>= \case
@ -450,7 +450,7 @@ wantImport :: FileMatcher Annex -> ImportLocation -> ByteSize -> Annex Bool
wantImport matcher loc sz = checkMatcher' matcher mi mempty
where
mi = MatchingInfo $ ProvidedInfo
{ providedFilePath = Right $ fromImportLocation loc
{ providedFilePath = Right $ fromRawFilePath $ fromImportLocation loc
, providedKey = unavail "key"
, providedFileSize = Right sz
, providedMimeType = unavail "mime"
@ -503,4 +503,4 @@ listImportableContents r = fmap removegitspecial
, importableHistory =
map removegitspecial (importableHistory ic)
}
gitspecial l = ".git" `elem` Posix.splitDirectories (fromImportLocation l)
gitspecial l = ".git" `elem` Posix.splitDirectories (fromRawFilePath (fromImportLocation l))

View file

@ -136,7 +136,7 @@ ingestAdd' meterupdate ld@(Just (LockedDown cfg source)) mk = do
then addLink f k mic
else do
mode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus (contentLocation source)
stagePointerFile f mode =<< hashPointerFile k
stagePointerFile (toRawFilePath f) mode =<< hashPointerFile k
return (Just k)
{- Ingests a locked down file into the annex. Does not update the working
@ -187,7 +187,7 @@ ingest' preferredbackend meterupdate (Just (LockedDown cfg source)) mk restage =
gounlocked _ _ _ = failure "failed statting file"
success k mcache s = do
genMetaData k (keyFilename source) s
genMetaData k (toRawFilePath (keyFilename source)) s
return (Just k, mcache)
failure msg = do
@ -208,13 +208,13 @@ finishIngestUnlocked' key source restage = do
{- Copy to any other locations using the same key. -}
populateAssociatedFiles :: Key -> KeySource -> Restage -> Annex ()
populateAssociatedFiles key source restage = do
obj <- calcRepo (gitAnnexLocation key)
obj <- toRawFilePath <$> calcRepo (gitAnnexLocation key)
g <- Annex.gitRepo
ingestedf <- flip fromTopFilePath g
<$> inRepo (toTopFilePath (keyFilename source))
afs <- map (`fromTopFilePath` g) <$> Database.Keys.getAssociatedFiles key
forM_ (filter (/= ingestedf) afs) $
populatePointerFile restage key obj
populatePointerFile restage key obj . toRawFilePath
cleanCruft :: KeySource -> Annex ()
cleanCruft source = when (contentLocation source /= keyFilename source) $
@ -264,7 +264,7 @@ restoreFile file key e = do
makeLink :: FilePath -> Key -> Maybe InodeCache -> Annex String
makeLink file key mcache = flip catchNonAsync (restoreFile file key) $ do
l <- calcRepo $ gitAnnexLink file key
replaceFile file $ makeAnnexLink l
replaceFile file $ makeAnnexLink l . toRawFilePath
-- touch symlink to have same time as the original file,
-- as provided in the InodeCache
@ -291,7 +291,7 @@ addLink file key mcache = ifM (coreSymlinks <$> Annex.getGitConfig)
Annex.Queue.addCommand "add" (ps++[Param "--"]) [file]
, do
l <- makeLink file key mcache
addAnnexLink l file
addAnnexLink l (toRawFilePath file)
)
{- Parameters to pass to git add, forcing addition of ignored files. -}
@ -329,7 +329,7 @@ addAnnexedFile file key mtmp = ifM addUnlocked
(pure Nothing)
(\tmp -> liftIO $ catchMaybeIO $ fileMode <$> getFileStatus tmp)
mtmp
stagePointerFile file mode =<< hashPointerFile key
stagePointerFile (toRawFilePath file) mode =<< hashPointerFile key
Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath file)
case mtmp of
Just tmp -> ifM (moveAnnex key tmp)
@ -349,6 +349,6 @@ addAnnexedFile file key mtmp = ifM addUnlocked
where
linkunlocked mode = linkFromAnnex key file mode >>= \case
LinkAnnexFailed -> liftIO $
writePointerFile file key mode
writePointerFile (toRawFilePath file) key mode
_ -> return ()
writepointer mode = liftIO $ writePointerFile file key mode
writepointer mode = liftIO $ writePointerFile (toRawFilePath file) key mode

View file

@ -275,5 +275,5 @@ initSharedClone True = do
- affect it. -}
propigateSecureHashesOnly :: Annex ()
propigateSecureHashesOnly =
maybe noop (setConfig "annex.securehashesonly")
maybe noop (setConfig "annex.securehashesonly" . decodeBS')
=<< getGlobalConfig "annex.securehashesonly"

View file

@ -5,6 +5,8 @@
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE OverloadedStrings #-}
module Annex.SpecialRemote (
module Annex.SpecialRemote,
module Annex.SpecialRemote.Config

View file

@ -18,15 +18,17 @@ import Annex.Multicast
import Types.Test
import Types.Benchmark
{-
import qualified Command.Help
import qualified Command.Add
{-
import qualified Command.Unannex
-}
import qualified Command.Drop
import qualified Command.Move
import qualified Command.Copy
import qualified Command.Get
import qualified Command.Fsck
{-
import qualified Command.LookupKey
import qualified Command.CalcKey
import qualified Command.ContentLocation
@ -49,7 +51,9 @@ import qualified Command.VAdd
import qualified Command.VFilter
import qualified Command.VPop
import qualified Command.VCycle
-}
import qualified Command.Reinject
{-
import qualified Command.Fix
import qualified Command.Init
import qualified Command.Describe
@ -71,7 +75,9 @@ import qualified Command.PostReceive
import qualified Command.Find
{-
import qualified Command.FindRef
-}
import qualified Command.Whereis
{-
import qualified Command.List
import qualified Command.Log
import qualified Command.Merge
@ -95,13 +101,17 @@ import qualified Command.Schedule
import qualified Command.Ungroup
import qualified Command.Config
import qualified Command.Vicfg
-}
import qualified Command.Sync
{-
import qualified Command.Mirror
import qualified Command.AddUrl
import qualified Command.ImportFeed
import qualified Command.RmUrl
-}
import qualified Command.Import
import qualified Command.Export
{-
import qualified Command.Map
import qualified Command.Direct
import qualified Command.Indirect
@ -129,23 +139,28 @@ import qualified Command.Benchmark
cmds :: Parser TestOptions -> TestRunner -> MkBenchmarkGenerator -> [Command]
cmds testoptparser testrunner mkbenchmarkgenerator =
{- [ Command.Help.cmd
[ Command.Help.cmd
, Command.Add.cmd
, Command.Get.cmd
, Command.Drop.cmd
, Command.Move.cmd
, Command.Copy.cmd
, Command.Fsck.cmd
{-
, Command.Unlock.cmd
, Command.Unlock.editcmd
, Command.Lock.cmd
-}
, Command.Sync.cmd
{-
, Command.Mirror.cmd
, Command.AddUrl.cmd
, Command.ImportFeed.cmd
, Command.RmUrl.cmd
-}
, Command.Import.cmd
, Command.Export.cmd
{-
, Command.Init.cmd
, Command.Describe.cmd
, Command.InitRemote.cmd
@ -153,7 +168,9 @@ cmds testoptparser testrunner mkbenchmarkgenerator =
, Command.RenameRemote.cmd
, Command.EnableTor.cmd
, Command.Multicast.cmd
-}
, Command.Reinject.cmd
{-
, Command.Unannex.cmd
, Command.Uninit.cmd
, Command.Reinit.cmd
@ -201,10 +218,12 @@ cmds testoptparser testrunner mkbenchmarkgenerator =
, Command.DropUnused.cmd
, Command.AddUnused.cmd
-}
[ Command.Find.cmd
, Command.Find.cmd
{-
, Command.FindRef.cmd
-}
, Command.Whereis.cmd
{-
, Command.List.cmd
, Command.Log.cmd
, Command.Merge.cmd

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

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

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)

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)

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
)

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

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

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)

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

View file

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

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)

View file

@ -6,7 +6,7 @@
-}
module Logs.Config (
ConfigName,
ConfigKey,
ConfigValue,
setGlobalConfig,
unsetGlobalConfig,
@ -18,48 +18,50 @@ import Annex.Common
import Logs
import Logs.MapLog
import qualified Annex.Branch
import Git.Types (ConfigKey(..))
import qualified Data.Map as M
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import qualified Data.Attoparsec.ByteString.Lazy as A
import Data.ByteString.Builder
type ConfigName = String
type ConfigValue = String
type ConfigValue = S.ByteString
setGlobalConfig :: ConfigName -> ConfigValue -> Annex ()
setGlobalConfig :: ConfigKey -> ConfigValue -> Annex ()
setGlobalConfig name new = do
curr <- getGlobalConfig name
when (curr /= Just new) $
setGlobalConfig' name new
setGlobalConfig' :: ConfigName -> ConfigValue -> Annex ()
setGlobalConfig' :: ConfigKey -> ConfigValue -> Annex ()
setGlobalConfig' name new = do
c <- liftIO currentVectorClock
Annex.Branch.change configLog $
buildGlobalConfig . changeMapLog c name new . parseGlobalConfig
unsetGlobalConfig :: ConfigName -> Annex ()
unsetGlobalConfig :: ConfigKey -> Annex ()
unsetGlobalConfig name = do
curr <- getGlobalConfig name
when (curr /= Nothing) $
setGlobalConfig' name "" -- set to empty string to unset
setGlobalConfig' name mempty -- set to empty string to unset
-- Reads the global config log every time.
getGlobalConfig :: ConfigName -> Annex (Maybe ConfigValue)
getGlobalConfig :: ConfigKey -> Annex (Maybe ConfigValue)
getGlobalConfig name = M.lookup name <$> loadGlobalConfig
buildGlobalConfig :: MapLog ConfigName ConfigValue -> Builder
buildGlobalConfig = buildMapLog fieldbuilder valuebuilder
buildGlobalConfig :: MapLog ConfigKey ConfigValue -> Builder
buildGlobalConfig = buildMapLog configkeybuilder valuebuilder
where
fieldbuilder = byteString . encodeBS
valuebuilder = byteString . encodeBS
configkeybuilder (ConfigKey f) = byteString f
valuebuilder = byteString
parseGlobalConfig :: L.ByteString -> MapLog ConfigName ConfigValue
parseGlobalConfig = parseMapLog string string
parseGlobalConfig :: L.ByteString -> MapLog ConfigKey ConfigValue
parseGlobalConfig = parseMapLog configkeyparser valueparser
where
string = decodeBS <$> A.takeByteString
configkeyparser = ConfigKey <$> A.takeByteString
valueparser = A.takeByteString
loadGlobalConfig :: Annex (M.Map ConfigName ConfigValue)
loadGlobalConfig = M.filter (not . null) . simpleMap . parseGlobalConfig
loadGlobalConfig :: Annex (M.Map ConfigKey ConfigValue)
loadGlobalConfig = M.filter (not . S.null) . simpleMap . parseGlobalConfig
<$> Annex.Branch.get configLog

View file

@ -14,9 +14,12 @@ the `bs` branch has quite a lot of things still needing work, including:
decodeBS conversions. Or at least most of them. There are likely
quite a few places where a value is converted back and forth several times.
As a first step, profile and look for the hot spots. For example, keyFile
uses fromRawFilePath and that adds around 3% overhead in `git-annex find`.
Converting it to a RawFilePath needs a version of `</>` for RawFilePaths.
As a first step, profile and look for the hot spots. Known hot spots:
* keyFile uses fromRawFilePath and that adds around 3% overhead in `git-annex find`.
Converting it to a RawFilePath needs a version of `</>` for RawFilePaths.
* getJournalFileStale uses fromRawFilePath, and adds 3-5% overhead in
`git-annex whereis`. Converting it to RawFilePath needs a version of `</>` for RawFilePaths.
* System.FilePath is not available for RawFilePath, and many of the
conversions are to get a FilePath in order to use that library.