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
Show stats Download patch file Download diff file Expand all files Collapse all files

7
Annex/Drop.hs
View file

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

12
Annex/Import.hs
View file

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

18
Annex/Ingest.hs
View file

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

2
Annex/Init.hs
View file

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

2
Annex/SpecialRemote.hs
View file

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

25
CmdLine/GitAnnex.hs
View file

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

28
Command/Add.hs
View file

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

6
Command/Copy.hs
View file

@ -47,7 +47,7 @@ seek :: CopyOptions -> CommandSeek
seek o = startConcurrency commandStages $ do seek o = startConcurrency commandStages $ do
let go = whenAnnexed $ start o let go = whenAnnexed $ start o
case batchOption o of case batchOption o of
Batch fmt -> batchFilesMatching fmt go Batch fmt -> batchFilesMatching fmt (go . toRawFilePath)
NoBatch -> withKeyOptions NoBatch -> withKeyOptions
(keyOptions o) (autoMode o) (keyOptions o) (autoMode o)
(commandAction . Command.Move.startKey (fromToOptions o) Command.Move.RemoveNever) (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. {- A copy is just a move that does not delete the source file.
- However, auto mode avoids unnecessary copies, and avoids getting or - However, auto mode avoids unnecessary copies, and avoids getting or
- sending non-preferred content. -} - sending non-preferred content. -}
start :: CopyOptions -> FilePath -> Key -> CommandStart start :: CopyOptions -> RawFilePath -> Key -> CommandStart
start o file key = stopUnless shouldCopy $ start o file key = stopUnless shouldCopy $
Command.Move.start (fromToOptions o) Command.Move.RemoveNever file key Command.Move.start (fromToOptions o) Command.Move.RemoveNever file key
where where
shouldCopy shouldCopy
| autoMode o = want <||> numCopiesCheck file key (<) | autoMode o = want <||> numCopiesCheck (fromRawFilePath file) key (<)
| otherwise = return True | otherwise = return True
want = case fromToOptions o of want = case fromToOptions o of
Right (ToRemote dest) -> Right (ToRemote dest) ->

4
Command/Drop.hs
View file

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

25
Command/Export.hs
View file

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

48
Command/Fsck.hs
View file

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

4
Command/Move.hs
View file

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

4
Command/Reinject.hs
View file

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

1
Command/Sync.hs
View file

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

4
Command/Whereis.hs
View file

@ -40,14 +40,14 @@ seek o = do
m <- remoteMap id m <- remoteMap id
let go = whenAnnexed $ start m let go = whenAnnexed $ start m
case batchOption o of case batchOption o of
Batch fmt -> batchFilesMatching fmt go Batch fmt -> batchFilesMatching fmt (go . toRawFilePath)
NoBatch -> NoBatch ->
withKeyOptions (keyOptions o) False withKeyOptions (keyOptions o) False
(commandAction . startKeys m) (commandAction . startKeys m)
(withFilesInGit (commandAction . go)) (withFilesInGit (commandAction . go))
=<< workTreeItems (whereisFiles o) =<< 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)) start remotemap file key = startKeys remotemap (key, mkActionItem (key, afile))
where where
afile = AssociatedFile (Just file) afile = AssociatedFile (Just file)

36
Logs/Config.hs
View file

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

9
doc/todo/optimize_by_converting_String_to_ByteString.mdwn
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 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. 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 As a first step, profile and look for the hot spots. Known hot spots:
uses fromRawFilePath and that adds around 3% overhead in `git-annex find`.
Converting it to a RawFilePath needs a version of `</>` for RawFilePaths. * 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 * System.FilePath is not available for RawFilePath, and many of the
conversions are to get a FilePath in order to use that library. conversions are to get a FilePath in order to use that library.