From b88f89c1ef230419c8abe1957dde744354485ce3 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 4 Dec 2019 13:15:34 -0400 Subject: [PATCH] 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. --- Annex/Drop.hs | 7 +-- Annex/Import.hs | 12 ++--- Annex/Ingest.hs | 18 +++---- Annex/Init.hs | 2 +- Annex/SpecialRemote.hs | 2 + CmdLine/GitAnnex.hs | 25 ++++++++-- Command/Add.hs | 28 +++++------ Command/Copy.hs | 6 +-- Command/Drop.hs | 4 +- Command/Export.hs | 25 +++++----- Command/Fsck.hs | 48 +++++++++---------- Command/Get.hs | 6 +-- Command/Import.hs | 4 +- Command/Move.hs | 4 +- Command/Reinject.hs | 4 +- Command/Sync.hs | 1 + Command/Whereis.hs | 4 +- Logs/Config.hs | 36 +++++++------- ...ze_by_converting_String_to_ByteString.mdwn | 9 ++-- 19 files changed, 137 insertions(+), 108 deletions(-) diff --git a/Annex/Drop.hs b/Annex/Drop.hs index 96f0eb7e30..f2489e5482 100644 --- a/Annex/Drop.hs +++ b/Annex/Drop.hs @@ -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 diff --git a/Annex/Import.hs b/Annex/Import.hs index 7438a7794c..8291cd51bf 100644 --- a/Annex/Import.hs +++ b/Annex/Import.hs @@ -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)) diff --git a/Annex/Ingest.hs b/Annex/Ingest.hs index 1406c4007c..5d5636b2e5 100644 --- a/Annex/Ingest.hs +++ b/Annex/Ingest.hs @@ -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 diff --git a/Annex/Init.hs b/Annex/Init.hs index ac6718dde7..c034bfac0c 100644 --- a/Annex/Init.hs +++ b/Annex/Init.hs @@ -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" diff --git a/Annex/SpecialRemote.hs b/Annex/SpecialRemote.hs index 37e0e2129a..f27c405d6b 100644 --- a/Annex/SpecialRemote.hs +++ b/Annex/SpecialRemote.hs @@ -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 diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs index deb723cf1d..fd1953faf2 100644 --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -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 diff --git a/Command/Add.hs b/Command/Add.hs index 200f66e768..0ebe42d735 100644 --- a/Command/Add.hs +++ b/Command/Add.hs @@ -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 diff --git a/Command/Copy.hs b/Command/Copy.hs index 91fec7fef6..ba7c83bf47 100644 --- a/Command/Copy.hs +++ b/Command/Copy.hs @@ -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) -> diff --git a/Command/Drop.hs b/Command/Drop.hs index 5d0d6179c7..9b8c4710ec 100644 --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -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) diff --git a/Command/Export.hs b/Command/Export.hs index 1163f5bad2..77ebc009f9 100644 --- a/Command/Export.hs +++ b/Command/Export.hs @@ -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) diff --git a/Command/Fsck.hs b/Command/Fsck.hs index 480042f9b5..bb2dde569f 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -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 ) diff --git a/Command/Get.hs b/Command/Get.hs index ba4dcb2010..e3bf47cb59 100644 --- a/Command/Get.hs +++ b/Command/Get.hs @@ -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 diff --git a/Command/Import.hs b/Command/Import.hs index 0488ef4cb7..58c1b40f93 100644 --- a/Command/Import.hs +++ b/Command/Import.hs @@ -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 diff --git a/Command/Move.hs b/Command/Move.hs index a5f6e9a025..68bc419e20 100644 --- a/Command/Move.hs +++ b/Command/Move.hs @@ -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) diff --git a/Command/Reinject.hs b/Command/Reinject.hs index df975531ce..d33817debf 100644 --- a/Command/Reinject.hs +++ b/Command/Reinject.hs @@ -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 diff --git a/Command/Sync.hs b/Command/Sync.hs index d35986c0f3..880b1dbbc0 100644 --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -7,6 +7,7 @@ -} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} module Command.Sync ( cmd, diff --git a/Command/Whereis.hs b/Command/Whereis.hs index c5010473c4..1946cfbdf6 100644 --- a/Command/Whereis.hs +++ b/Command/Whereis.hs @@ -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) diff --git a/Logs/Config.hs b/Logs/Config.hs index ca6387e4e0..068a12a061 100644 --- a/Logs/Config.hs +++ b/Logs/Config.hs @@ -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 diff --git a/doc/todo/optimize_by_converting_String_to_ByteString.mdwn b/doc/todo/optimize_by_converting_String_to_ByteString.mdwn index 83104bf0dc..1c51fd0aa9 100644 --- a/doc/todo/optimize_by_converting_String_to_ByteString.mdwn +++ b/doc/todo/optimize_by_converting_String_to_ByteString.mdwn @@ -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. -- 2.30.2