From 6a97ff6b3a5ffacfe889abd6c23325a0f4f1dfc9 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 25 Nov 2019 16:18:19 -0400 Subject: [PATCH 01/42] wip RawFilePath Goal is to make git-annex faster by using ByteString for all the worktree traversal. For now, this is focusing on Command.Find, in order to benchmark how much it helps. (All other commands are temporarily disabled) Currently in a very bad unbuildable in-between state. --- Annex/Locations.hs | 6 ++- CmdLine/GitAnnex.hs | 11 ++++- CmdLine/Seek.hs | 26 +++++------ Git/Branch.hs | 19 ++++---- Git/CatFile.hs | 12 ++--- Git/Command.hs | 32 ++++++++------ Git/Construct.hs | 2 +- Git/DiffTree.hs | 4 +- Git/FilePath.hs | 20 ++++----- Git/Filename.hs | 38 +++++++++------- Git/HashObject.hs | 2 +- Git/LsFiles.hs | 105 +++++++++++++++++++++++--------------------- Git/LsTree.hs | 47 ++++++++++++-------- Git/Ref.hs | 20 ++++++--- Git/RefLog.hs | 2 +- Git/Repair.hs | 4 +- Git/Status.hs | 2 +- Git/Tree.hs | 10 ++--- Git/Types.hs | 21 +++++---- Git/UnionMerge.hs | 5 ++- Git/UpdateIndex.hs | 37 +++++++++------- Types/Export.hs | 19 ++++---- Types/Import.hs | 4 +- Utility/Misc.hs | 7 +++ git-annex.cabal | 3 +- 25 files changed, 258 insertions(+), 200 deletions(-) diff --git a/Annex/Locations.hs b/Annex/Locations.hs index f9c65732e8..cdaa8d3f6e 100644 --- a/Annex/Locations.hs +++ b/Annex/Locations.hs @@ -201,8 +201,10 @@ gitAnnexLink file key r config = do | not (coreSymlinks config) && needsSubmoduleFixup r = absNormPathUnix currdir $ Git.repoPath r ".git" | otherwise = Git.localGitDir r - absNormPathUnix d p = toInternalGitPath $ - absPathFrom (toInternalGitPath d) (toInternalGitPath p) + absNormPathUnix d p = fromRawFilePath $ toInternalGitPath $ toRawFilePath $ + absPathFrom + (fromRawFilePath $ toInternalGitPath $ toRawFilePath d) + (fromRawFilePath $ toInternalGitPath $ toRawFilePath p) {- Calculates a symlink target as would be used in a typical git - repository, with .git in the top of the work tree. -} diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs index 9fc0d272ae..bfec6f6271 100644 --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -18,6 +18,7 @@ import Annex.Multicast import Types.Test import Types.Benchmark +{- import qualified Command.Help import qualified Command.Add import qualified Command.Unannex @@ -66,7 +67,9 @@ import qualified Command.Unlock import qualified Command.Lock import qualified Command.PreCommit import qualified Command.PostReceive +-} import qualified Command.Find +{- import qualified Command.FindRef import qualified Command.Whereis import qualified Command.List @@ -122,10 +125,11 @@ import qualified Command.Test import qualified Command.FuzzTest import qualified Command.TestRemote 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 @@ -196,7 +200,9 @@ cmds testoptparser testrunner mkbenchmarkgenerator = , Command.Unused.cmd , Command.DropUnused.cmd , Command.AddUnused.cmd - , Command.Find.cmd +-} + [ Command.Find.cmd +{- , Command.FindRef.cmd , Command.Whereis.cmd , Command.List.cmd @@ -231,6 +237,7 @@ cmds testoptparser testrunner mkbenchmarkgenerator = , Command.TestRemote.cmd , Command.Benchmark.cmd $ mkbenchmarkgenerator $ cmds testoptparser testrunner (\_ _ -> return noop) +-} ] run :: Parser TestOptions -> TestRunner -> MkBenchmarkGenerator -> [String] -> IO () diff --git a/CmdLine/Seek.hs b/CmdLine/Seek.hs index 4107e9dcd6..e523eac99a 100644 --- a/CmdLine/Seek.hs +++ b/CmdLine/Seek.hs @@ -34,11 +34,11 @@ import Annex.Content import Annex.InodeSentinal import qualified Database.Keys -withFilesInGit :: (FilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek +withFilesInGit :: (RawFilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek withFilesInGit a l = seekActions $ prepFiltered a $ seekHelper LsFiles.inRepo l -withFilesInGitNonRecursive :: String -> (FilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek +withFilesInGitNonRecursive :: String -> (RawFilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek withFilesInGitNonRecursive needforce a l = ifM (Annex.getState Annex.force) ( withFilesInGit a l , if null l @@ -58,7 +58,7 @@ withFilesInGitNonRecursive needforce a l = ifM (Annex.getState Annex.force) getfiles c ps _ -> giveup needforce -withFilesNotInGit :: Bool -> (FilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek +withFilesNotInGit :: Bool -> (RawFilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek withFilesNotInGit skipdotfiles a l | skipdotfiles = do {- dotfiles are not acted on unless explicitly listed -} @@ -78,7 +78,7 @@ withFilesNotInGit skipdotfiles a l go fs = seekActions $ prepFiltered a $ return $ concat $ segmentPaths (map (\(WorkTreeItem f) -> f) l) fs -withPathContents :: ((FilePath, FilePath) -> CommandSeek) -> CmdParams -> CommandSeek +withPathContents :: ((RawFilePath, RawFilePath) -> CommandSeek) -> CmdParams -> CommandSeek withPathContents a params = do matcher <- Limit.getMatcher forM_ params $ \p -> do @@ -110,30 +110,30 @@ withPairs a params = seekActions $ return $ map a $ pairs [] params pairs c (x:y:xs) = pairs ((x,y):c) xs pairs _ _ = giveup "expected pairs" -withFilesToBeCommitted :: (FilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek +withFilesToBeCommitted :: (RawFilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek withFilesToBeCommitted a l = seekActions $ prepFiltered a $ seekHelper LsFiles.stagedNotDeleted l -isOldUnlocked :: FilePath -> Annex Bool +isOldUnlocked :: RawFilePath -> Annex Bool isOldUnlocked f = liftIO (notSymlink f) <&&> (isJust <$> catKeyFile f <||> isJust <$> catKeyFileHEAD f) {- unlocked pointer files that are staged, and whose content has not been - modified-} -withUnmodifiedUnlockedPointers :: (FilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek +withUnmodifiedUnlockedPointers :: (RawFilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek withUnmodifiedUnlockedPointers a l = seekActions $ prepFiltered a unlockedfiles where unlockedfiles = filterM isUnmodifiedUnlocked =<< seekHelper LsFiles.typeChangedStaged l -isUnmodifiedUnlocked :: FilePath -> Annex Bool +isUnmodifiedUnlocked :: RawFilePath -> Annex Bool isUnmodifiedUnlocked f = catKeyFile f >>= \case Nothing -> return False Just k -> sameInodeCache f =<< Database.Keys.getInodeCaches k {- Finds files that may be modified. -} -withFilesMaybeModified :: (FilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek +withFilesMaybeModified :: (RawFilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek withFilesMaybeModified a params = seekActions $ prepFiltered a $ seekHelper LsFiles.modified params @@ -225,7 +225,7 @@ withKeyOptions' ko auto mkkeyaction fallbackaction params = do forM_ ts $ \(t, i) -> keyaction (transferKey t, mkActionItem (t, i)) -prepFiltered :: (FilePath -> CommandSeek) -> Annex [FilePath] -> Annex [CommandSeek] +prepFiltered :: (RawFilePath -> CommandSeek) -> Annex [RawFilePath] -> Annex [CommandSeek] prepFiltered a fs = do matcher <- Limit.getMatcher map (process matcher) <$> fs @@ -235,7 +235,7 @@ prepFiltered a fs = do seekActions :: Annex [CommandSeek] -> Annex () seekActions gen = sequence_ =<< gen -seekHelper :: ([FilePath] -> Git.Repo -> IO ([FilePath], IO Bool)) -> [WorkTreeItem] -> Annex [FilePath] +seekHelper :: ([RawFilePath] -> Git.Repo -> IO ([RawFilePath], IO Bool)) -> [WorkTreeItem] -> Annex [RawFilePath] seekHelper a l = inRepo $ \g -> concat . concat <$> forM (segmentXargsOrdered l') (runSegmentPaths (\fs -> Git.Command.leaveZombie <$> a fs g)) @@ -243,7 +243,7 @@ seekHelper a l = inRepo $ \g -> l' = map (\(WorkTreeItem f) -> f) l -- An item in the work tree, which may be a file or a directory. -newtype WorkTreeItem = WorkTreeItem FilePath +newtype WorkTreeItem = WorkTreeItem RawFilePath -- When in an adjusted branch that hides some files, it may not exist -- in the current work tree, but in the original branch. This allows @@ -273,5 +273,5 @@ workTreeItems' (AllowHidden allowhidden) ps = do isJust <$> catObjectMetaDataHidden f currbranch | otherwise = return False -notSymlink :: FilePath -> IO Bool +notSymlink :: RawFilePath -> IO Bool notSymlink f = liftIO $ not . isSymbolicLink <$> getSymbolicLinkStatus f diff --git a/Git/Branch.hs b/Git/Branch.hs index 2de6f9e0fd..ffd9a189d2 100644 --- a/Git/Branch.hs +++ b/Git/Branch.hs @@ -16,6 +16,8 @@ import Git.Command import qualified Git.Config import qualified Git.Ref +import qualified Data.ByteString as B + {- The currently checked out branch. - - In a just initialized git repo before the first commit, @@ -29,19 +31,19 @@ current r = do case v of Nothing -> return Nothing Just branch -> - ifM (null <$> pipeReadStrict [Param "show-ref", Param $ fromRef branch] r) + ifM (B.null <$> pipeReadStrict [Param "show-ref", Param $ fromRef branch] r) ( return Nothing , return v ) {- The current branch, which may not really exist yet. -} currentUnsafe :: Repo -> IO (Maybe Branch) -currentUnsafe r = parse . firstLine +currentUnsafe r = parse . firstLine' <$> pipeReadStrict [Param "symbolic-ref", Param "-q", Param $ fromRef Git.Ref.headRef] r where - parse l - | null l = Nothing - | otherwise = Just $ Git.Ref l + parse b + | B.null b = Nothing + | otherwise = Just $ Git.Ref $ decodeBS b {- Checks if the second branch has any commits not present on the first - branch. -} @@ -53,7 +55,8 @@ changed origbranch newbranch repo where changed' :: Branch -> Branch -> [CommandParam] -> Repo -> IO String -changed' origbranch newbranch extraps repo = pipeReadStrict ps repo +changed' origbranch newbranch extraps repo = + decodeBS <$> pipeReadStrict ps repo where ps = [ Param "log" @@ -72,7 +75,7 @@ changedCommits origbranch newbranch extraps repo = - - This requires there to be a path from the old to the new. -} fastForwardable :: Ref -> Ref -> Repo -> IO Bool -fastForwardable old new repo = not . null <$> +fastForwardable old new repo = not . B.null <$> pipeReadStrict [ Param "log" , Param $ fromRef old ++ ".." ++ fromRef new @@ -160,7 +163,7 @@ commitCommand' runner commitmode ps = runner $ commit :: CommitMode -> Bool -> String -> Branch -> [Ref] -> Repo -> IO (Maybe Sha) commit commitmode allowempty message branch parentrefs repo = do tree <- getSha "write-tree" $ - pipeReadStrict [Param "write-tree"] repo + decodeBS' <$> pipeReadStrict [Param "write-tree"] repo ifM (cancommit tree) ( do sha <- commitTree commitmode message parentrefs tree repo diff --git a/Git/CatFile.hs b/Git/CatFile.hs index 49b89454c9..732c18a643 100644 --- a/Git/CatFile.hs +++ b/Git/CatFile.hs @@ -66,13 +66,13 @@ catFileStop h = do CoProcess.stop (checkFileProcess h) {- Reads a file from a specified branch. -} -catFile :: CatFileHandle -> Branch -> FilePath -> IO L.ByteString +catFile :: CatFileHandle -> Branch -> RawFilePath -> IO L.ByteString catFile h branch file = catObject h $ Ref $ - fromRef branch ++ ":" ++ toInternalGitPath file + fromRef branch ++ ":" ++ fromRawFilePath (toInternalGitPath file) -catFileDetails :: CatFileHandle -> Branch -> FilePath -> IO (Maybe (L.ByteString, Sha, ObjectType)) +catFileDetails :: CatFileHandle -> Branch -> RawFilePath -> IO (Maybe (L.ByteString, Sha, ObjectType)) catFileDetails h branch file = catObjectDetails h $ Ref $ - fromRef branch ++ ":" ++ toInternalGitPath file + fromRef branch ++ ":" ++ fromRawFilePath (toInternalGitPath file) {- Uses a running git cat-file read the content of an object. - Objects that do not exist will have "" returned. -} @@ -148,7 +148,7 @@ parseResp object l | otherwise = case words l of [sha, objtype, size] | length sha == shaSize -> - case (readObjectType objtype, reads size) of + case (readObjectType (encodeBS objtype), reads size) of (Just t, [(bytes, "")]) -> Just $ ParsedResp (Ref sha) bytes t _ -> Nothing @@ -185,7 +185,7 @@ querySize r repo = maybe Nothing (readMaybe . takeWhile (/= '\n')) <$> querySingle (Param "-s") r repo hGetContentsStrict queryObjectType :: Ref -> Repo -> IO (Maybe ObjectType) -queryObjectType r repo = maybe Nothing (readObjectType . takeWhile (/= '\n')) +queryObjectType r repo = maybe Nothing (readObjectType . encodeBS . takeWhile (/= '\n')) <$> querySingle (Param "-t") r repo hGetContentsStrict queryContent :: Ref -> Repo -> IO (Maybe L.ByteString) diff --git a/Git/Command.hs b/Git/Command.hs index 3101acd79e..12f69b6201 100644 --- a/Git/Command.hs +++ b/Git/Command.hs @@ -14,6 +14,9 @@ import Git import Git.Types import qualified Utility.CoProcess as CoProcess +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString as S + {- Constructs a git command line operating on the specified repo. -} gitCommandLine :: [CommandParam] -> Repo -> [CommandParam] gitCommandLine params r@(Repo { location = l@(Local { } ) }) = @@ -50,10 +53,10 @@ runQuiet params repo = withQuietOutput createProcessSuccess $ - read, that will wait on the command, and - return True if it succeeded. Failure to wait will result in zombies. -} -pipeReadLazy :: [CommandParam] -> Repo -> IO (String, IO Bool) +pipeReadLazy :: [CommandParam] -> Repo -> IO (L.ByteString, IO Bool) pipeReadLazy params repo = assertLocal repo $ do (_, Just h, _, pid) <- createProcess p { std_out = CreatePipe } - c <- hGetContents h + c <- L.hGetContents h return (c, checkSuccessProcess pid) where p = gitCreateProcess params repo @@ -62,8 +65,8 @@ pipeReadLazy params repo = assertLocal repo $ do - - Nonzero exit status is ignored. -} -pipeReadStrict :: [CommandParam] -> Repo -> IO String -pipeReadStrict = pipeReadStrict' hGetContentsStrict +pipeReadStrict :: [CommandParam] -> Repo -> IO S.ByteString +pipeReadStrict = pipeReadStrict' S.hGetContents {- The reader action must be strict. -} pipeReadStrict' :: (Handle -> IO a) -> [CommandParam] -> Repo -> IO a @@ -93,21 +96,24 @@ pipeWrite params repo = assertLocal repo $ {- Reads null terminated output of a git command (as enabled by the -z - parameter), and splits it. -} -pipeNullSplit :: [CommandParam] -> Repo -> IO ([String], IO Bool) +pipeNullSplit :: [CommandParam] -> Repo -> IO ([L.ByteString], IO Bool) pipeNullSplit params repo = do (s, cleanup) <- pipeReadLazy params repo - return (filter (not . null) $ splitc sep s, cleanup) - where - sep = '\0' + return (filter (not . L.null) $ L.split 0 s, cleanup) -pipeNullSplitStrict :: [CommandParam] -> Repo -> IO [String] +{- Reads lazily, but converts each part to a strict ByteString for + - convenience. -} +pipeNullSplit' :: [CommandParam] -> Repo -> IO ([S.ByteString], IO Bool) +pipeNullSplit' params repo = do + (s, cleanup) <- pipeNullSplit params repo + return (map L.toStrict s, cleanup) + +pipeNullSplitStrict :: [CommandParam] -> Repo -> IO [S.ByteString] pipeNullSplitStrict params repo = do s <- pipeReadStrict params repo - return $ filter (not . null) $ splitc sep s - where - sep = '\0' + return $ filter (not . S.null) $ S.split 0 s -pipeNullSplitZombie :: [CommandParam] -> Repo -> IO [String] +pipeNullSplitZombie :: [CommandParam] -> Repo -> IO [L.ByteString] pipeNullSplitZombie params repo = leaveZombie <$> pipeNullSplit params repo {- Doesn't run the cleanup action. A zombie results. -} diff --git a/Git/Construct.hs b/Git/Construct.hs index d032c59c39..7191f33036 100644 --- a/Git/Construct.hs +++ b/Git/Construct.hs @@ -58,7 +58,7 @@ fromPath dir = fromAbsPath =<< absPath dir - specified. -} fromAbsPath :: FilePath -> IO Repo fromAbsPath dir - | absoluteGitPath dir = hunt + | absoluteGitPath (encodeBS dir) = hunt | otherwise = error $ "internal error, " ++ dir ++ " is not absolute" where diff --git a/Git/DiffTree.hs b/Git/DiffTree.hs index 0aad4db188..f6c5c60955 100644 --- a/Git/DiffTree.hs +++ b/Git/DiffTree.hs @@ -89,7 +89,7 @@ commitDiff ref = getdiff (Param "show") getdiff :: CommandParam -> [CommandParam] -> Repo -> IO ([DiffTreeItem], IO Bool) getdiff command params repo = do (diff, cleanup) <- pipeNullSplit ps repo - return (parseDiffRaw diff, cleanup) + return (parseDiffRaw (map decodeBL diff), cleanup) where ps = command : @@ -113,7 +113,7 @@ parseDiffRaw l = go l , srcsha = fromMaybe (error "bad srcsha") $ extractSha ssha , dstsha = fromMaybe (error "bad dstsha") $ extractSha dsha , status = s - , file = asTopFilePath $ fromInternalGitPath $ Git.Filename.decode f + , file = asTopFilePath $ fromRawFilePath $ fromInternalGitPath $ Git.Filename.decode $ toRawFilePath f } where readmode = fst . Prelude.head . readOct diff --git a/Git/FilePath.hs b/Git/FilePath.hs index f0c3b69ed7..fffbea98d4 100644 --- a/Git/FilePath.hs +++ b/Git/FilePath.hs @@ -34,7 +34,7 @@ import qualified System.FilePath.Posix import GHC.Generics import Control.DeepSeq -{- A FilePath, relative to the top of the git repository. -} +{- A RawFilePath, relative to the top of the git repository. -} newtype TopFilePath = TopFilePath { getTopFilePath :: FilePath } deriving (Show, Eq, Ord, Generic) @@ -46,7 +46,7 @@ data BranchFilePath = BranchFilePath Ref TopFilePath {- Git uses the branch:file form to refer to a BranchFilePath -} descBranchFilePath :: BranchFilePath -> String -descBranchFilePath (BranchFilePath b f) = fromRef b ++ ':' : getTopFilePath f +descBranchFilePath (BranchFilePath b f) = fromRef b ++ ':' : (getTopFilePath f) {- Path to a TopFilePath, within the provided git repo. -} fromTopFilePath :: TopFilePath -> Git.Repo -> FilePath @@ -68,25 +68,25 @@ asTopFilePath file = TopFilePath file - despite Windows using '\'. - -} -type InternalGitPath = String +type InternalGitPath = RawFilePath -toInternalGitPath :: FilePath -> InternalGitPath +toInternalGitPath :: RawFilePath -> InternalGitPath #ifndef mingw32_HOST_OS toInternalGitPath = id #else -toInternalGitPath = replace "\\" "/" +toInternalGitPath = encodeBS . replace "\\" "/" . decodeBS #endif -fromInternalGitPath :: InternalGitPath -> FilePath +fromInternalGitPath :: InternalGitPath -> RawFilePath #ifndef mingw32_HOST_OS fromInternalGitPath = id #else -fromInternalGitPath = replace "/" "\\" +fromInternalGitPath = encodeBS . replace "/" "\\" . decodeBS #endif {- isAbsolute on Windows does not think "/foo" or "\foo" is absolute, - so try posix paths. -} -absoluteGitPath :: FilePath -> Bool -absoluteGitPath p = isAbsolute p || - System.FilePath.Posix.isAbsolute (toInternalGitPath p) +absoluteGitPath :: RawFilePath -> Bool +absoluteGitPath p = isAbsolute (decodeBS p) || + System.FilePath.Posix.isAbsolute (decodeBS (toInternalGitPath p)) diff --git a/Git/Filename.hs b/Git/Filename.hs index 40a449c9c9..52dce828e3 100644 --- a/Git/Filename.hs +++ b/Git/Filename.hs @@ -12,23 +12,29 @@ import Common import Utility.Format (decode_c, encode_c) import Data.Char +import Data.Word +import qualified Data.ByteString as S -decode :: String -> FilePath -decode [] = [] -decode f@(c:s) - -- encoded strings will be inside double quotes - | c == '"' && end s == ['"'] = decode_c $ beginning s - | otherwise = f +-- encoded filenames will be inside double quotes +decode :: S.ByteString -> RawFilePath +decode b = case S.uncons b of + Nothing -> b + Just (h, t) + | h /= q -> b + | otherwise -> case S.unsnoc t of + Nothing -> b + Just (i, l) + | l /= q -> b + | otherwise -> + encodeBS $ decode_c $ decodeBS i + where + q :: Word8 + q = fromIntegral (ord '"') {- Should not need to use this, except for testing decode. -} -encode :: FilePath -> String -encode s = "\"" ++ encode_c s ++ "\"" +encode :: RawFilePath -> S.ByteString +encode s = encodeBS $ "\"" ++ encode_c (decodeBS s) ++ "\"" -{- For quickcheck. - - - - See comment on Utility.Format.prop_encode_c_decode_c_roundtrip for - - why this only tests chars < 256 -} -prop_encode_decode_roundtrip :: String -> Bool -prop_encode_decode_roundtrip s = s' == decode (encode s') - where - s' = filter (\c -> ord c < 256) s +{- For quickcheck. -} +prop_encode_decode_roundtrip :: RawFilePath -> Bool +prop_encode_decode_roundtrip s = s == decode (encode s) diff --git a/Git/HashObject.hs b/Git/HashObject.hs index 2453cc1c5f..605e6d504c 100644 --- a/Git/HashObject.hs +++ b/Git/HashObject.hs @@ -73,4 +73,4 @@ hashObject' objtype writer repo = getSha subcmd $ pipeWriteRead (map Param params) (Just writer) repo where subcmd = "hash-object" - params = [subcmd, "-t", show objtype, "-w", "--stdin", "--no-filters"] + params = [subcmd, "-t", decodeBS (fmtObjectType objtype), "-w", "--stdin", "--no-filters"] diff --git a/Git/LsFiles.hs b/Git/LsFiles.hs index d27146c890..160c0c1ec1 100644 --- a/Git/LsFiles.hs +++ b/Git/LsFiles.hs @@ -34,37 +34,40 @@ import Git.Sha import Numeric import System.Posix.Types +import qualified Data.ByteString.Lazy as L {- Scans for files that are checked into git's index at the specified locations. -} -inRepo :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) +inRepo :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) inRepo = inRepo' [] -inRepo' :: [CommandParam] -> [FilePath] -> Repo -> IO ([FilePath], IO Bool) -inRepo' ps l = pipeNullSplit $ - Param "ls-files" : - Param "--cached" : - Param "-z" : - ps ++ - (Param "--" : map File l) +inRepo' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +inRepo' ps l repo = pipeNullSplit' params repo + where + params = + Param "ls-files" : + Param "--cached" : + Param "-z" : + ps ++ + (Param "--" : map (File . fromRawFilePath) l) {- Files that are checked into the index or have been committed to a - branch. -} -inRepoOrBranch :: Branch -> [FilePath] -> Repo -> IO ([FilePath], IO Bool) +inRepoOrBranch :: Branch -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) inRepoOrBranch (Ref b) = inRepo' [Param $ "--with-tree=" ++ b] {- Scans for files at the specified locations that are not checked into git. -} -notInRepo :: Bool -> [FilePath] -> Repo -> IO ([FilePath], IO Bool) +notInRepo :: Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) notInRepo = notInRepo' [] -notInRepo' :: [CommandParam] -> Bool -> [FilePath] -> Repo -> IO ([FilePath], IO Bool) -notInRepo' ps include_ignored l repo = pipeNullSplit params repo +notInRepo' :: [CommandParam] -> Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +notInRepo' ps include_ignored l repo = pipeNullSplit' params repo where params = concat [ [ Param "ls-files", Param "--others"] , ps , exclude , [ Param "-z", Param "--" ] - , map File l + , map (File . fromRawFilePath) l ] exclude | include_ignored = [] @@ -72,48 +75,48 @@ notInRepo' ps include_ignored l repo = pipeNullSplit params repo {- Scans for files at the specified locations that are not checked into - git. Empty directories are included in the result. -} -notInRepoIncludingEmptyDirectories :: Bool -> [FilePath] -> Repo -> IO ([FilePath], IO Bool) +notInRepoIncludingEmptyDirectories :: Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) notInRepoIncludingEmptyDirectories = notInRepo' [Param "--directory"] {- Finds all files in the specified locations, whether checked into git or - not. -} -allFiles :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) -allFiles l = pipeNullSplit $ +allFiles :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +allFiles l = pipeNullSplit' $ Param "ls-files" : Param "--cached" : Param "--others" : Param "-z" : Param "--" : - map File l + map (File . fromRawFilePath) l {- Returns a list of files in the specified locations that have been - deleted. -} -deleted :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) -deleted l repo = pipeNullSplit params repo +deleted :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +deleted l repo = pipeNullSplit' params repo where params = Param "ls-files" : Param "--deleted" : Param "-z" : Param "--" : - map File l + map (File . fromRawFilePath) l {- Returns a list of files in the specified locations that have been - modified. -} -modified :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) -modified l repo = pipeNullSplit params repo +modified :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +modified l repo = pipeNullSplit' params repo where params = Param "ls-files" : Param "--modified" : Param "-z" : Param "--" : - map File l + map (File . fromRawFilePath) l {- Files that have been modified or are not checked into git (and are not - ignored). -} -modifiedOthers :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) -modifiedOthers l repo = pipeNullSplit params repo +modifiedOthers :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +modifiedOthers l repo = pipeNullSplit' params repo where params = Param "ls-files" : @@ -122,69 +125,69 @@ modifiedOthers l repo = pipeNullSplit params repo Param "--exclude-standard" : Param "-z" : Param "--" : - map File l + map (File . fromRawFilePath) l {- Returns a list of all files that are staged for commit. -} -staged :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) +staged :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) staged = staged' [] {- Returns a list of the files, staged for commit, that are being added, - moved, or changed (but not deleted), from the specified locations. -} -stagedNotDeleted :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) +stagedNotDeleted :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) stagedNotDeleted = staged' [Param "--diff-filter=ACMRT"] -staged' :: [CommandParam] -> [FilePath] -> Repo -> IO ([FilePath], IO Bool) -staged' ps l = pipeNullSplit $ prefix ++ ps ++ suffix +staged' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +staged' ps l repo = pipeNullSplit' (prefix ++ ps ++ suffix) repo where prefix = [Param "diff", Param "--cached", Param "--name-only", Param "-z"] - suffix = Param "--" : map File l + suffix = Param "--" : map (File . fromRawFilePath) l -type StagedDetails = (FilePath, Maybe Sha, Maybe FileMode) +type StagedDetails = (RawFilePath, Maybe Sha, Maybe FileMode) {- Returns details about files that are staged in the index, - as well as files not yet in git. Skips ignored files. -} -stagedOthersDetails :: [FilePath] -> Repo -> IO ([StagedDetails], IO Bool) +stagedOthersDetails :: [RawFilePath] -> Repo -> IO ([StagedDetails], IO Bool) stagedOthersDetails = stagedDetails' [Param "--others", Param "--exclude-standard"] {- Returns details about all files that are staged in the index. -} -stagedDetails :: [FilePath] -> Repo -> IO ([StagedDetails], IO Bool) +stagedDetails :: [RawFilePath] -> Repo -> IO ([StagedDetails], IO Bool) stagedDetails = stagedDetails' [] {- Gets details about staged files, including the Sha of their staged - contents. -} -stagedDetails' :: [CommandParam] -> [FilePath] -> Repo -> IO ([StagedDetails], IO Bool) +stagedDetails' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([StagedDetails], IO Bool) stagedDetails' ps l repo = do (ls, cleanup) <- pipeNullSplit params repo return (map parse ls, cleanup) where params = Param "ls-files" : Param "--stage" : Param "-z" : ps ++ - Param "--" : map File l + Param "--" : map (File . fromRawFilePath) l parse s - | null file = (s, Nothing, Nothing) - | otherwise = (file, extractSha $ take shaSize rest, readmode mode) + | null file = (L.toStrict s, Nothing, Nothing) + | otherwise = (toRawFilePath file, extractSha $ take shaSize rest, readmode mode) where - (metadata, file) = separate (== '\t') s + (metadata, file) = separate (== '\t') (decodeBL' s) (mode, rest) = separate (== ' ') metadata readmode = fst <$$> headMaybe . readOct {- Returns a list of the files in the specified locations that are staged - for commit, and whose type has changed. -} -typeChangedStaged :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) +typeChangedStaged :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) typeChangedStaged = typeChanged' [Param "--cached"] {- Returns a list of the files in the specified locations whose type has - changed. Files only staged for commit will not be included. -} -typeChanged :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) +typeChanged :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) typeChanged = typeChanged' [] -typeChanged' :: [CommandParam] -> [FilePath] -> Repo -> IO ([FilePath], IO Bool) +typeChanged' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) typeChanged' ps l repo = do (fs, cleanup) <- pipeNullSplit (prefix ++ ps ++ suffix) repo -- git diff returns filenames relative to the top of the git repo; -- convert to filenames relative to the cwd, like git ls-files. top <- absPath (repoPath repo) currdir <- getCurrentDirectory - return (map (\f -> relPathDirToFileAbs currdir $ top f) fs, cleanup) + return (map (\f -> toRawFilePath (relPathDirToFileAbs currdir $ top decodeBL' f)) fs, cleanup) where prefix = [ Param "diff" @@ -192,7 +195,7 @@ typeChanged' ps l repo = do , Param "--diff-filter=T" , Param "-z" ] - suffix = Param "--" : (if null l then [File "."] else map File l) + suffix = Param "--" : (if null l then [File "."] else map (File . fromRawFilePath) l) {- A item in conflict has two possible values. - Either can be Nothing, when that side deleted the file. -} @@ -202,7 +205,7 @@ data Conflicting v = Conflicting } deriving (Show) data Unmerged = Unmerged - { unmergedFile :: FilePath + { unmergedFile :: RawFilePath , unmergedTreeItemType :: Conflicting TreeItemType , unmergedSha :: Conflicting Sha } @@ -217,21 +220,21 @@ data Unmerged = Unmerged - 3 = them - If a line is omitted, that side removed the file. -} -unmerged :: [FilePath] -> Repo -> IO ([Unmerged], IO Bool) +unmerged :: [RawFilePath] -> Repo -> IO ([Unmerged], IO Bool) unmerged l repo = do (fs, cleanup) <- pipeNullSplit params repo - return (reduceUnmerged [] $ catMaybes $ map parseUnmerged fs, cleanup) + return (reduceUnmerged [] $ catMaybes $ map (parseUnmerged . decodeBL') fs, cleanup) where params = Param "ls-files" : Param "--unmerged" : Param "-z" : Param "--" : - map File l + map (File . fromRawFilePath) l data InternalUnmerged = InternalUnmerged { isus :: Bool - , ifile :: FilePath + , ifile :: RawFilePath , itreeitemtype :: Maybe TreeItemType , isha :: Maybe Sha } @@ -245,9 +248,9 @@ parseUnmerged s if stage /= 2 && stage /= 3 then Nothing else do - treeitemtype <- readTreeItemType rawtreeitemtype + treeitemtype <- readTreeItemType (encodeBS rawtreeitemtype) sha <- extractSha rawsha - return $ InternalUnmerged (stage == 2) file + return $ InternalUnmerged (stage == 2) (toRawFilePath file) (Just treeitemtype) (Just sha) _ -> Nothing where diff --git a/Git/LsTree.hs b/Git/LsTree.hs index 8ca805402b..aa3651a543 100644 --- a/Git/LsTree.hs +++ b/Git/LsTree.hs @@ -26,12 +26,16 @@ import Git.FilePath import qualified Git.Filename import Numeric -import Data.Char +import Data.Either import System.Posix.Types +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import qualified Data.Attoparsec.ByteString.Lazy as A +import qualified Data.Attoparsec.ByteString.Char8 as A8 data TreeItem = TreeItem { mode :: FileMode - , typeobj :: String + , typeobj :: S.ByteString , sha :: Ref , file :: TopFilePath } deriving Show @@ -45,7 +49,7 @@ lsTree = lsTree' [] lsTree' :: [CommandParam] -> LsTreeMode -> Ref -> Repo -> IO ([TreeItem], IO Bool) lsTree' ps lsmode t repo = do (l, cleanup) <- pipeNullSplit (lsTreeParams lsmode t ps) repo - return (map parseLsTree l, cleanup) + return (rights (map parseLsTree l), cleanup) lsTreeParams :: LsTreeMode -> Ref -> [CommandParam] -> [CommandParam] lsTreeParams lsmode r ps = @@ -63,7 +67,8 @@ lsTreeParams lsmode r ps = {- Lists specified files in a tree. -} lsTreeFiles :: Ref -> [FilePath] -> Repo -> IO [TreeItem] -lsTreeFiles t fs repo = map parseLsTree <$> pipeNullSplitStrict ps repo +lsTreeFiles t fs repo = rights . map (parseLsTree . L.fromStrict) + <$> pipeNullSplitStrict ps repo where ps = [ Param "ls-tree" @@ -73,30 +78,34 @@ lsTreeFiles t fs repo = map parseLsTree <$> pipeNullSplitStrict ps repo , File $ fromRef t ] ++ map File fs +parseLsTree :: L.ByteString -> Either String TreeItem +parseLsTree b = case A.parse parserLsTree b of + A.Done _ r -> Right r + A.Fail _ _ err -> Left err + {- Parses a line of ls-tree output, in format: - mode SP type SP sha TAB file - - (The --long format is not currently supported.) -} -parseLsTree :: String -> TreeItem -parseLsTree l = TreeItem - { mode = smode - , typeobj = t - , sha = Ref s - , file = sfile - } - where - (m, past_m) = splitAt 7 l -- mode is 6 bytes - (!t, past_t) = separate isSpace past_m - (!s, past_s) = splitAt shaSize past_t - !f = drop 1 past_s - !smode = fst $ Prelude.head $ readOct m - !sfile = asTopFilePath $ Git.Filename.decode f +parserLsTree :: A.Parser TreeItem +parserLsTree = TreeItem + -- mode + <$> A8.decimal + <* A8.char ' ' + -- type + <*> A.takeTill (== 32) + <* A8.char ' ' + -- sha + <*> (Ref . decodeBS' <$> A.take shaSize) + <* A8.char '\t' + -- file + <*> (asTopFilePath . decodeBS' . Git.Filename.decode <$> A.takeByteString) {- Inverse of parseLsTree -} formatLsTree :: TreeItem -> String formatLsTree ti = unwords [ showOct (mode ti) "" - , typeobj ti + , decodeBS (typeobj ti) , fromRef (sha ti) , getTopFilePath (file ti) ] diff --git a/Git/Ref.hs b/Git/Ref.hs index 964dbafb08..d0542f4f84 100644 --- a/Git/Ref.hs +++ b/Git/Ref.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Git.Ref where import Common @@ -13,7 +15,8 @@ import Git.Command import Git.Sha import Git.Types -import Data.Char (chr) +import Data.Char (chr, ord) +import qualified Data.ByteString as S headRef :: Ref headRef = Ref "HEAD" @@ -88,8 +91,10 @@ file ref repo = localGitDir repo fromRef ref - that was just created. -} headExists :: Repo -> IO Bool headExists repo = do - ls <- lines <$> pipeReadStrict [Param "show-ref", Param "--head"] repo - return $ any (" HEAD" `isSuffixOf`) ls + ls <- S.split nl <$> pipeReadStrict [Param "show-ref", Param "--head"] repo + return $ any (" HEAD" `S.isSuffixOf`) ls + where + nl = fromIntegral (ord '\n') {- Get the sha of a fully qualified git ref, if it exists. -} sha :: Branch -> Repo -> IO (Maybe Sha) @@ -100,8 +105,9 @@ sha branch repo = process <$> showref repo , Param "--hash" -- get the hash , Param $ fromRef branch ] - process [] = Nothing - process s = Just $ Ref $ firstLine s + process s + | S.null s = Nothing + | otherwise = Just $ Ref $ decodeBS' $ firstLine' s headSha :: Repo -> IO (Maybe Sha) headSha = sha headRef @@ -116,7 +122,7 @@ matchingWithHEAD refs repo = matching' ("--head" : map fromRef refs) repo {- List of (shas, branches) matching a given ref spec. -} matching' :: [String] -> Repo -> IO [(Sha, Branch)] -matching' ps repo = map gen . lines <$> +matching' ps repo = map gen . lines . decodeBS' <$> pipeReadStrict (Param "show-ref" : map Param ps) repo where gen l = let (r, b) = separate (== ' ') l @@ -148,7 +154,7 @@ delete oldvalue ref = run - The ref may be something like a branch name, and it could contain - ":subdir" if a subtree is wanted. -} tree :: Ref -> Repo -> IO (Maybe Sha) -tree (Ref ref) = extractSha <$$> pipeReadStrict +tree (Ref ref) = extractSha . decodeBS <$$> pipeReadStrict [ Param "rev-parse", Param "--verify", Param "--quiet", Param ref' ] where ref' = if ":" `isInfixOf` ref diff --git a/Git/RefLog.hs b/Git/RefLog.hs index 2c5a65d74a..7ba8713af7 100644 --- a/Git/RefLog.hs +++ b/Git/RefLog.hs @@ -21,7 +21,7 @@ getMulti :: [Branch] -> Repo -> IO [Sha] getMulti bs = get' (map (Param . fromRef) bs) get' :: [CommandParam] -> Repo -> IO [Sha] -get' ps = mapMaybe extractSha . lines <$$> pipeReadStrict ps' +get' ps = mapMaybe extractSha . lines . decodeBS <$$> pipeReadStrict ps' where ps' = catMaybes [ Just $ Param "log" diff --git a/Git/Repair.hs b/Git/Repair.hs index e6267a5f54..734c884f60 100644 --- a/Git/Repair.hs +++ b/Git/Repair.hs @@ -284,7 +284,7 @@ findUncorruptedCommit missing goodcommits branch r = do , Param "--format=%H" , Param (fromRef branch) ] r - let branchshas = catMaybes $ map extractSha ls + let branchshas = catMaybes $ map (extractSha . decodeBS) ls reflogshas <- RefLog.get branch r -- XXX Could try a bit harder here, and look -- for uncorrupted old commits in branches in the @@ -313,7 +313,7 @@ verifyCommit missing goodcommits commit r , Param "--format=%H %T" , Param (fromRef commit) ] r - let committrees = map parse ls + let committrees = map (parse . decodeBS) ls if any isNothing committrees || null committrees then do void cleanup diff --git a/Git/Status.hs b/Git/Status.hs index 5a1077baf8..c15a11bd63 100644 --- a/Git/Status.hs +++ b/Git/Status.hs @@ -69,7 +69,7 @@ parseStatusZ = go [] getStatus :: [CommandParam] -> [FilePath] -> Repo -> IO ([StagedUnstaged Status], IO Bool) getStatus ps fs r = do (ls, cleanup) <- pipeNullSplit ps' r - return (parseStatusZ ls, cleanup) + return (parseStatusZ (map decodeBL ls), cleanup) where ps' = concat [ [Param "status"] diff --git a/Git/Tree.hs b/Git/Tree.hs index 3a8851099a..8a69c53a2a 100644 --- a/Git/Tree.hs +++ b/Git/Tree.hs @@ -115,7 +115,7 @@ mkTreeOutput :: FileMode -> ObjectType -> Sha -> TopFilePath -> String mkTreeOutput fm ot s f = concat [ showOct fm "" , " " - , show ot + , decodeBS (fmtObjectType ot) , " " , fromRef s , "\t" @@ -134,7 +134,7 @@ treeItemToTreeContent (TreeItem f m s) = case toTreeItemType m of treeItemToLsTreeItem :: TreeItem -> LsTree.TreeItem treeItemToLsTreeItem (TreeItem f mode sha) = LsTree.TreeItem { LsTree.mode = mode - , LsTree.typeobj = show BlobObject + , LsTree.typeobj = fmtObjectType BlobObject , LsTree.sha = sha , LsTree.file = f } @@ -239,7 +239,7 @@ adjustTree adjusttreeitem addtreeitems resolveaddconflict removefiles r repo = Just CommitObject -> do let ti = TreeCommit (LsTree.file i) (LsTree.mode i) (LsTree.sha i) go h wasmodified (ti:c) depth intree is - _ -> error ("unexpected object type \"" ++ LsTree.typeobj i ++ "\"") + _ -> error ("unexpected object type \"" ++ decodeBS (LsTree.typeobj i) ++ "\"") | otherwise = return (c, wasmodified, i:is) adjustlist h depth ishere underhere l = do @@ -328,7 +328,7 @@ graftTree' subtree graftloc basetree repo hdl = go basetree graftdirs -- For a graftloc of "foo/bar/baz", this generates -- ["foo", "foo/bar", "foo/bar/baz"] - graftdirs = map (asTopFilePath . toInternalGitPath) $ + graftdirs = map (asTopFilePath . decodeBS . toInternalGitPath . encodeBS) $ mkpaths [] $ splitDirectories $ gitPath graftloc mkpaths _ [] = [] mkpaths base (d:rest) = (joinPath base d) : mkpaths (base ++ [d]) rest @@ -355,7 +355,7 @@ extractTree l = case go [] inTopTree l of Just CommitObject -> let c = TreeCommit (LsTree.file i) (LsTree.mode i) (LsTree.sha i) in go (c:t) intree is - _ -> parseerr ("unexpected object type \"" ++ LsTree.typeobj i ++ "\"") + _ -> parseerr ("unexpected object type \"" ++ decodeBS (LsTree.typeobj i) ++ "\"") | otherwise = Right (t, i:is) parseerr = Left diff --git a/Git/Types.hs b/Git/Types.hs index 4a4dff0c53..90401db153 100644 --- a/Git/Types.hs +++ b/Git/Types.hs @@ -5,13 +5,17 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Git.Types where import Network.URI import qualified Data.Map as M +import qualified Data.ByteString as S import System.Posix.Types import Utility.SafeCommand + {- Support repositories on local disk, and repositories accessed via an URL. - - Repos on local disk have a git directory, and unless bare, a worktree. @@ -64,32 +68,31 @@ newtype RefDate = RefDate String {- Types of objects that can be stored in git. -} data ObjectType = BlobObject | CommitObject | TreeObject - deriving (Eq) -instance Show ObjectType where - show BlobObject = "blob" - show CommitObject = "commit" - show TreeObject = "tree" - -readObjectType :: String -> Maybe ObjectType +readObjectType :: S.ByteString -> Maybe ObjectType readObjectType "blob" = Just BlobObject readObjectType "commit" = Just CommitObject readObjectType "tree" = Just TreeObject readObjectType _ = Nothing +fmtObjectType :: ObjectType -> S.ByteString +fmtObjectType BlobObject = "blob" +fmtObjectType CommitObject = "commit" +fmtObjectType TreeObject = "tree" + {- Types of items in a tree. -} data TreeItemType = TreeFile | TreeExecutable | TreeSymlink | TreeSubmodule deriving (Eq) {- Git uses magic numbers to denote the type of a tree item. -} -readTreeItemType :: String -> Maybe TreeItemType +readTreeItemType :: S.ByteString -> Maybe TreeItemType readTreeItemType "100644" = Just TreeFile readTreeItemType "100755" = Just TreeExecutable readTreeItemType "120000" = Just TreeSymlink readTreeItemType "160000" = Just TreeSubmodule readTreeItemType _ = Nothing -fmtTreeItemType :: TreeItemType -> String +fmtTreeItemType :: TreeItemType -> S.ByteString fmtTreeItemType TreeFile = "100644" fmtTreeItemType TreeExecutable = "100755" fmtTreeItemType TreeSymlink = "120000" diff --git a/Git/UnionMerge.hs b/Git/UnionMerge.hs index ea9dd3500e..fc3c30e2ac 100644 --- a/Git/UnionMerge.hs +++ b/Git/UnionMerge.hs @@ -10,6 +10,7 @@ module Git.UnionMerge ( mergeIndex ) where +import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as L8 import qualified Data.Set as S @@ -69,7 +70,7 @@ diffOpts = ["--raw", "-z", "-r", "--no-renames", "-l0"] doMerge :: HashObjectHandle -> CatFileHandle -> [String] -> Repo -> Streamer doMerge hashhandle ch differ repo streamer = do (diff, cleanup) <- pipeNullSplit (map Param differ) repo - go diff + go (map decodeBL' diff) void $ cleanup where go [] = noop @@ -80,7 +81,7 @@ doMerge hashhandle ch differ repo streamer = do {- Given an info line from a git raw diff, and the filename, generates - a line suitable for update-index that union merges the two sides of the - diff. -} -mergeFile :: String -> FilePath -> HashObjectHandle -> CatFileHandle -> IO (Maybe String) +mergeFile :: String -> FilePath -> HashObjectHandle -> CatFileHandle -> IO (Maybe L.ByteString) mergeFile info file hashhandle h = case filter (/= nullSha) [Ref asha, Ref bsha] of [] -> return Nothing (sha:[]) -> use sha diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs index 435c4f28e2..76094a3432 100644 --- a/Git/UpdateIndex.hs +++ b/Git/UpdateIndex.hs @@ -1,11 +1,11 @@ {- git-update-index library - - - Copyright 2011-2018 Joey Hess + - Copyright 2011-2019 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE BangPatterns, CPP #-} +{-# LANGUAGE BangPatterns, OverloadedStrings, CPP #-} module Git.UpdateIndex ( Streamer, @@ -32,12 +32,14 @@ import Git.FilePath import Git.Sha import qualified Git.DiffTreeItem as Diff +import qualified Data.ByteString.Lazy as L + {- Streamers are passed a callback and should feed it lines in the form - read by update-index, and generated by ls-tree. -} -type Streamer = (String -> IO ()) -> IO () +type Streamer = (L.ByteString -> IO ()) -> IO () {- A streamer with a precalculated value. -} -pureStreamer :: String -> Streamer +pureStreamer :: L.ByteString -> Streamer pureStreamer !s = \streamer -> streamer s {- Streams content into update-index from a list of Streamers. -} @@ -49,8 +51,8 @@ data UpdateIndexHandle = UpdateIndexHandle ProcessHandle Handle streamUpdateIndex' :: UpdateIndexHandle -> Streamer -> IO () streamUpdateIndex' (UpdateIndexHandle _ h) a = a $ \s -> do - hPutStr h s - hPutStr h "\0" + L.hPutStr h s + L.hPutStr h "\0" startUpdateIndex :: Repo -> IO UpdateIndexHandle startUpdateIndex repo = do @@ -84,14 +86,13 @@ lsSubTree (Ref x) p repo streamer = do {- Generates a line suitable to be fed into update-index, to add - a given file with a given sha. -} -updateIndexLine :: Sha -> TreeItemType -> TopFilePath -> String -updateIndexLine sha treeitemtype file = concat - [ fmtTreeItemType treeitemtype - , " blob " - , fromRef sha - , "\t" - , indexPath file - ] +updateIndexLine :: Sha -> TreeItemType -> TopFilePath -> L.ByteString +updateIndexLine sha treeitemtype file = L.fromStrict $ + fmtTreeItemType treeitemtype + <> " blob " + <> encodeBS (fromRef sha) + <> "\t" + <> indexPath file stageFile :: Sha -> TreeItemType -> FilePath -> Repo -> IO Streamer stageFile sha treeitemtype file repo = do @@ -105,7 +106,11 @@ unstageFile file repo = do return $ unstageFile' p unstageFile' :: TopFilePath -> Streamer -unstageFile' p = pureStreamer $ "0 " ++ fromRef nullSha ++ "\t" ++ indexPath p +unstageFile' p = pureStreamer $ L.fromStrict $ + "0 " + <> encodeBS' (fromRef nullSha) + <> "\t" + <> indexPath p {- A streamer that adds a symlink to the index. -} stageSymlink :: FilePath -> Sha -> Repo -> IO Streamer @@ -123,7 +128,7 @@ stageDiffTreeItem d = case toTreeItemType (Diff.dstmode d) of Just t -> pureStreamer $ updateIndexLine (Diff.dstsha d) t (Diff.file d) indexPath :: TopFilePath -> InternalGitPath -indexPath = toInternalGitPath . getTopFilePath +indexPath = toInternalGitPath . toRawFilePath . getTopFilePath {- Refreshes the index, by checking file stat information. -} refreshIndex :: Repo -> ((FilePath -> IO ()) -> IO ()) -> IO Bool diff --git a/Types/Export.hs b/Types/Export.hs index 437d74e286..b90b5cbe5e 100644 --- a/Types/Export.hs +++ b/Types/Export.hs @@ -17,38 +17,39 @@ module Types.Export ( import Git.FilePath import Utility.Split +import Utility.FileSystemEncoding import qualified System.FilePath.Posix as Posix -- A location on a remote that a key can be exported to. --- The FilePath will be relative to the top of the remote, +-- The RawFilePath will be relative to the top of the remote, -- and uses unix-style path separators. -newtype ExportLocation = ExportLocation FilePath +newtype ExportLocation = ExportLocation RawFilePath deriving (Show, Eq) -mkExportLocation :: FilePath -> ExportLocation +mkExportLocation :: RawFilePath -> ExportLocation mkExportLocation = ExportLocation . toInternalGitPath -fromExportLocation :: ExportLocation -> FilePath +fromExportLocation :: ExportLocation -> RawFilePath fromExportLocation (ExportLocation f) = f -newtype ExportDirectory = ExportDirectory FilePath +newtype ExportDirectory = ExportDirectory RawFilePath deriving (Show, Eq) -mkExportDirectory :: FilePath -> ExportDirectory +mkExportDirectory :: RawFilePath -> ExportDirectory mkExportDirectory = ExportDirectory . toInternalGitPath -fromExportDirectory :: ExportDirectory -> FilePath +fromExportDirectory :: ExportDirectory -> RawFilePath fromExportDirectory (ExportDirectory f) = f -- | All subdirectories down to the ExportLocation, with the deepest ones -- last. Does not include the top of the export. exportDirectories :: ExportLocation -> [ExportDirectory] exportDirectories (ExportLocation f) = - map (ExportDirectory . Posix.joinPath . reverse) (subs [] dirs) + map (ExportDirectory . encodeBS . Posix.joinPath . reverse) (subs [] dirs) where subs _ [] = [] subs ps (d:ds) = (d:ps) : subs (d:ps) ds dirs = map Posix.dropTrailingPathSeparator $ - dropFromEnd 1 $ Posix.splitPath f + dropFromEnd 1 $ Posix.splitPath $ decodeBS f diff --git a/Types/Import.hs b/Types/Import.hs index c6d94edb61..a297af76e6 100644 --- a/Types/Import.hs +++ b/Types/Import.hs @@ -19,10 +19,10 @@ import Utility.FileSystemEncoding - location on the remote. -} type ImportLocation = ExportLocation -mkImportLocation :: FilePath -> ImportLocation +mkImportLocation :: RawFilePath -> ImportLocation mkImportLocation = mkExportLocation -fromImportLocation :: ImportLocation -> FilePath +fromImportLocation :: ImportLocation -> RawFilePath fromImportLocation = fromExportLocation {- An identifier for content stored on a remote that has been imported into diff --git a/Utility/Misc.hs b/Utility/Misc.hs index de77c949a0..2f1766ec23 100644 --- a/Utility/Misc.hs +++ b/Utility/Misc.hs @@ -12,6 +12,7 @@ module Utility.Misc ( readFileStrict, separate, firstLine, + firstLine', segment, segmentDelim, massReplace, @@ -28,6 +29,7 @@ import Data.Char import Data.List import System.Exit import Control.Applicative +import qualified Data.ByteString as S import Prelude {- A version of hgetContents that is not lazy. Ensures file is @@ -56,6 +58,11 @@ separate c l = unbreak $ break c l firstLine :: String -> String firstLine = takeWhile (/= '\n') +firstLine' :: S.ByteString -> S.ByteString +firstLine' = S.takeWhile (/= nl) + where + nl = fromIntegral (ord '\n') + {- Splits a list into segments that are delimited by items matching - a predicate. (The delimiters are not included in the segments.) - Segments may be empty. -} diff --git a/git-annex.cabal b/git-annex.cabal index 5d8ba73914..83da5bcb74 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -602,7 +602,7 @@ Executable git-annex if flag(DebugLocks) CPP-Options: -DDEBUGLOCKS - Other-Modules: + Other-Modules-Temp-Disabled: Annex Annex.Action Annex.AdjustedBranch @@ -860,7 +860,6 @@ Executable git-annex Git.RefLog Git.Remote Git.Remote.Remove - Git.Repair Git.Sha Git.Ssh Git.Status From 067aabdd4899997f10c78388273f28cccf777b66 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 26 Nov 2019 15:27:22 -0400 Subject: [PATCH 02/42] wip RawFilePath 2x git-annex find speedup Finally builds (oh the agoncy of making it build), but still very unmergable, only Command.Find is included and lots of stuff is badly hacked to make it compile. Benchmarking vs master, this git-annex find is significantly faster! Specifically: num files old new speedup 48500 4.77 3.73 28% 12500 1.36 1.02 66% 20 0.075 0.074 0% (so startup time is unchanged) That's without really finishing the optimization. Things still to do: * Eliminate all the fromRawFilePath, toRawFilePath, encodeBS, decodeBS conversions. * Use versions of IO actions like getFileStatus that take a RawFilePath. * Eliminate some Data.ByteString.Lazy.toStrict, which is a slow copy. * Use ByteString for parsing git config to speed up startup. It's likely several of those will speed up git-annex find further. And other commands will certianly benefit even more. --- Annex/AutoMerge.hs | 12 +++ Annex/Branch.hs | 30 +++---- Annex/Branch/Transitions.hs | 2 +- Annex/CatFile.hs | 18 ++--- Annex/Content.hs | 4 +- Annex/Content/PointerFile.hs | 26 +++--- Annex/FileMatcher.hs | 4 +- Annex/Journal.hs | 10 +-- Annex/Link.hs | 52 ++++++------ Annex/Locations.hs | 3 +- Annex/MetaData.hs | 6 +- Annex/Notification.hs | 2 +- Annex/NumCopies.hs | 2 +- Annex/View.hs | 4 +- Annex/WorkTree.hs | 20 ++--- Backend/Hash.hs | 2 +- CmdLine/GitAnnexShell/Fields.hs | 2 +- CmdLine/Seek.hs | 28 ++++--- Command/Find.hs | 13 +-- Command/Unannex.hs | 4 +- Command/Uninit.hs | 4 +- Database/ContentIdentifier.hs | 2 +- Database/Export.hs | 22 ++--- Database/Keys.hs | 13 +-- Git/Command.hs | 8 +- Git/FilePath.hs | 7 +- Git/Filename.hs | 4 +- Git/Ref.hs | 6 +- Key.hs | 5 ++ Limit.hs | 12 +-- Limit/Wanted.hs | 2 +- Logs.hs | 137 ++++++++++++++++++-------------- Logs/Export.hs | 11 ++- Logs/Location.hs | 2 +- Logs/MetaData.hs | 8 +- Logs/PreferredContent/Raw.hs | 2 +- Logs/Presence.hs | 12 +-- Logs/SingleValue.hs | 6 +- Logs/Transfer.hs | 6 +- Logs/Transitions.hs | 6 +- Logs/Web.hs | 2 +- Messages.hs | 32 ++++---- Messages/Internal.hs | 10 ++- Messages/JSON.hs | 5 +- Messages/Progress.hs | 1 + P2P/Protocol.hs | 7 +- Remote/Directory.hs | 8 +- Remote/Git.hs | 2 +- Remote/Helper/Ssh.hs | 2 +- Remote/List.hs | 6 ++ Remote/Rsync.hs | 10 +-- Test.hs | 7 ++ Test/Framework.hs | 8 +- Types/ActionItem.hs | 18 +++-- Types/Key.hs | 3 +- Types/Transfer.hs | 6 +- Upgrade.hs | 4 + Utility/Path.hs | 10 ++- git-annex.cabal | 6 +- git-annex.hs | 4 +- stack.yaml | 6 +- 61 files changed, 380 insertions(+), 296 deletions(-) diff --git a/Annex/AutoMerge.hs b/Annex/AutoMerge.hs index 766e5274ae..00193d3481 100644 --- a/Annex/AutoMerge.hs +++ b/Annex/AutoMerge.hs @@ -43,6 +43,8 @@ import qualified Data.ByteString.Lazy as L -} autoMergeFrom :: Git.Ref -> Maybe Git.Ref -> [Git.Merge.MergeConfig] -> Annex Bool -> Git.Branch.CommitMode -> Annex Bool autoMergeFrom branch currbranch mergeconfig canresolvemerge commitmode = do + error "STUBBED FIXME" +{- showOutput case currbranch of Nothing -> go Nothing @@ -62,6 +64,7 @@ autoMergeFrom branch currbranch mergeconfig canresolvemerge commitmode = do ( resolveMerge old branch False , return False ) +-} {- Resolves a conflicted merge. It's important that any conflicts be - resolved in a way that itself avoids later merge conflicts, since @@ -104,6 +107,8 @@ autoMergeFrom branch currbranch mergeconfig canresolvemerge commitmode = do -} resolveMerge :: Maybe Git.Ref -> Git.Ref -> Bool -> Annex Bool resolveMerge us them inoverlay = do + error "STUBBED FIXME" +{- top <- if inoverlay then pure "." else fromRepo Git.repoPath @@ -132,10 +137,13 @@ resolveMerge us them inoverlay = do cleanConflictCruft mergedks' mergedfs' unstagedmap showLongNote "Merge conflict was automatically resolved; you may want to examine the result." return merged +-} resolveMerge' :: InodeMap -> Maybe Git.Ref -> Git.Ref -> Bool -> LsFiles.Unmerged -> Annex ([Key], Maybe FilePath) resolveMerge' _ Nothing _ _ _ = return ([], Nothing) resolveMerge' unstagedmap (Just us) them inoverlay u = do + error "STUBBED FIXME" +{- kus <- getkey LsFiles.valUs kthem <- getkey LsFiles.valThem case (kus, kthem) of @@ -265,6 +273,7 @@ resolveMerge' unstagedmap (Just us) them inoverlay u = do [Param "--quiet", Param "-f", Param "--cached", Param "--"] [file] void a return (ks, Just file) +-} {- git-merge moves conflicting files away to files - named something like f~HEAD or f~branch or just f, but the @@ -278,6 +287,8 @@ resolveMerge' unstagedmap (Just us) them inoverlay u = do -} cleanConflictCruft :: [Key] -> [FilePath] -> InodeMap -> Annex () cleanConflictCruft resolvedks resolvedfs unstagedmap = do + error "STUBBED FIXME" +{- is <- S.fromList . map (inodeCacheToKey Strongly) . concat <$> mapM Database.Keys.getInodeCaches resolvedks forM_ (M.toList unstagedmap) $ \(i, f) -> @@ -294,6 +305,7 @@ cleanConflictCruft resolvedks resolvedfs unstagedmap = do , inks <$> liftIO (isPointerFile f) ] | otherwise = return False +-} conflictCruftBase :: FilePath -> FilePath conflictCruftBase f = reverse $ drop 1 $ dropWhile (/= '~') $ reverse f diff --git a/Annex/Branch.hs b/Annex/Branch.hs index faf11ce05a..c39807f61e 100644 --- a/Annex/Branch.hs +++ b/Annex/Branch.hs @@ -215,7 +215,7 @@ updateTo' pairs = do - content is returned. - - Returns an empty string if the file doesn't exist yet. -} -get :: FilePath -> Annex L.ByteString +get :: RawFilePath -> Annex L.ByteString get file = do update getLocal file @@ -224,21 +224,21 @@ get file = do - reflect changes in remotes. - (Changing the value this returns, and then merging is always the - same as using get, and then changing its value.) -} -getLocal :: FilePath -> Annex L.ByteString +getLocal :: RawFilePath -> Annex L.ByteString getLocal file = go =<< getJournalFileStale file where go (Just journalcontent) = return journalcontent go Nothing = getRef fullname file {- Gets the content of a file as staged in the branch's index. -} -getStaged :: FilePath -> Annex L.ByteString +getStaged :: RawFilePath -> Annex L.ByteString getStaged = getRef indexref where -- This makes git cat-file be run with ":file", -- so it looks at the index. indexref = Ref "" -getHistorical :: RefDate -> FilePath -> Annex L.ByteString +getHistorical :: RefDate -> RawFilePath -> Annex L.ByteString getHistorical date file = -- This check avoids some ugly error messages when the reflog -- is empty. @@ -247,7 +247,7 @@ getHistorical date file = , getRef (Git.Ref.dateRef fullname date) file ) -getRef :: Ref -> FilePath -> Annex L.ByteString +getRef :: Ref -> RawFilePath -> Annex L.ByteString getRef ref file = withIndex $ catFile ref file {- Applies a function to modify the content of a file. @@ -255,11 +255,11 @@ getRef ref file = withIndex $ catFile ref file - Note that this does not cause the branch to be merged, it only - modifes the current content of the file on the branch. -} -change :: Journalable content => FilePath -> (L.ByteString -> content) -> Annex () +change :: Journalable content => RawFilePath -> (L.ByteString -> content) -> Annex () change file f = lockJournal $ \jl -> f <$> getLocal file >>= set jl file {- Applies a function which can modify the content of a file, or not. -} -maybeChange :: Journalable content => FilePath -> (L.ByteString -> Maybe content) -> Annex () +maybeChange :: Journalable content => RawFilePath -> (L.ByteString -> Maybe content) -> Annex () maybeChange file f = lockJournal $ \jl -> do v <- getLocal file case f v of @@ -269,7 +269,7 @@ maybeChange file f = lockJournal $ \jl -> do _ -> noop {- Records new content of a file into the journal -} -set :: Journalable content => JournalLocked -> FilePath -> content -> Annex () +set :: Journalable content => JournalLocked -> RawFilePath -> content -> Annex () set = setJournalFile {- Commit message used when making a commit of whatever data has changed @@ -353,23 +353,23 @@ commitIndex' jl branchref message basemessage retrynum parents = do {- Lists all files on the branch. including ones in the journal - that have not been committed yet. There may be duplicates in the list. -} -files :: Annex [FilePath] +files :: Annex [RawFilePath] files = do update -- ++ forces the content of the first list to be buffered in memory, -- so use getJournalledFilesStale which should be much smaller most -- of the time. branchFiles will stream as the list is consumed. (++) - <$> getJournalledFilesStale + <$> (map toRawFilePath <$> getJournalledFilesStale) <*> branchFiles {- Files in the branch, not including any from journalled changes, - and without updating the branch. -} -branchFiles :: Annex [FilePath] +branchFiles :: Annex [RawFilePath] branchFiles = withIndex $ inRepo branchFiles' -branchFiles' :: Git.Repo -> IO [FilePath] -branchFiles' = Git.Command.pipeNullSplitZombie +branchFiles' :: Git.Repo -> IO [RawFilePath] +branchFiles' = Git.Command.pipeNullSplitZombie' (lsTreeParams Git.LsTree.LsTreeRecursive fullname [Param "--name-only"]) {- Populates the branch's index file with the current branch contents. @@ -593,14 +593,14 @@ performTransitionsLocked jl ts neednewlocalbranch transitionedrefs = do if L.null content' then do Annex.Queue.addUpdateIndex - =<< inRepo (Git.UpdateIndex.unstageFile file) + =<< inRepo (Git.UpdateIndex.unstageFile (fromRawFilePath file)) -- File is deleted; can't run any other -- transitions on it. return () else do sha <- hashBlob content' Annex.Queue.addUpdateIndex $ Git.UpdateIndex.pureStreamer $ - Git.UpdateIndex.updateIndexLine sha TreeFile (asTopFilePath file) + Git.UpdateIndex.updateIndexLine sha TreeFile (asTopFilePath (fromRawFilePath file)) apply rest file content' checkBranchDifferences :: Git.Ref -> Annex () diff --git a/Annex/Branch/Transitions.hs b/Annex/Branch/Transitions.hs index 1ed2e4d505..a360919890 100644 --- a/Annex/Branch/Transitions.hs +++ b/Annex/Branch/Transitions.hs @@ -34,7 +34,7 @@ data FileTransition = ChangeFile Builder | PreserveFile -type TransitionCalculator = TrustMap -> M.Map UUID RemoteConfig -> FilePath -> L.ByteString -> FileTransition +type TransitionCalculator = TrustMap -> M.Map UUID RemoteConfig -> RawFilePath -> L.ByteString -> FileTransition getTransitionCalculator :: Transition -> Maybe TransitionCalculator getTransitionCalculator ForgetGitHistory = Nothing diff --git a/Annex/CatFile.hs b/Annex/CatFile.hs index 149fde4475..2037693e91 100644 --- a/Annex/CatFile.hs +++ b/Annex/CatFile.hs @@ -39,12 +39,12 @@ import Annex.Link import Annex.CurrentBranch import Types.AdjustedBranch -catFile :: Git.Branch -> FilePath -> Annex L.ByteString +catFile :: Git.Branch -> RawFilePath -> Annex L.ByteString catFile branch file = do h <- catFileHandle liftIO $ Git.CatFile.catFile h branch file -catFileDetails :: Git.Branch -> FilePath -> Annex (Maybe (L.ByteString, Sha, ObjectType)) +catFileDetails :: Git.Branch -> RawFilePath -> Annex (Maybe (L.ByteString, Sha, ObjectType)) catFileDetails branch file = do h <- catFileHandle liftIO $ Git.CatFile.catFileDetails h branch file @@ -109,8 +109,8 @@ catKey ref = go =<< catObjectMetaData ref go _ = return Nothing {- Gets a symlink target. -} -catSymLinkTarget :: Sha -> Annex String -catSymLinkTarget sha = fromInternalGitPath . decodeBL <$> get +catSymLinkTarget :: Sha -> Annex RawFilePath +catSymLinkTarget sha = fromInternalGitPath . L.toStrict <$> get where -- Avoid buffering the whole file content, which might be large. -- 8192 is enough if it really is a symlink. @@ -137,24 +137,24 @@ catSymLinkTarget sha = fromInternalGitPath . decodeBL <$> get - - So, this gets info from the index, unless running as a daemon. -} -catKeyFile :: FilePath -> Annex (Maybe Key) +catKeyFile :: RawFilePath -> Annex (Maybe Key) catKeyFile f = ifM (Annex.getState Annex.daemon) ( catKeyFileHEAD f , catKey $ Git.Ref.fileRef f ) -catKeyFileHEAD :: FilePath -> Annex (Maybe Key) +catKeyFileHEAD :: RawFilePath -> Annex (Maybe Key) catKeyFileHEAD f = catKey $ Git.Ref.fileFromRef Git.Ref.headRef f {- Look in the original branch from whence an adjusted branch is based - to find the file. But only when the adjustment hides some files. -} -catKeyFileHidden :: FilePath -> CurrBranch -> Annex (Maybe Key) +catKeyFileHidden :: RawFilePath -> CurrBranch -> Annex (Maybe Key) catKeyFileHidden = hiddenCat catKey -catObjectMetaDataHidden :: FilePath -> CurrBranch -> Annex (Maybe (Integer, ObjectType)) +catObjectMetaDataHidden :: RawFilePath -> CurrBranch -> Annex (Maybe (Integer, ObjectType)) catObjectMetaDataHidden = hiddenCat catObjectMetaData -hiddenCat :: (Ref -> Annex (Maybe a)) -> FilePath -> CurrBranch -> Annex (Maybe a) +hiddenCat :: (Ref -> Annex (Maybe a)) -> RawFilePath -> CurrBranch -> Annex (Maybe a) hiddenCat a f (Just origbranch, Just adj) | adjustmentHidesFiles adj = a (Git.Ref.fileFromRef origbranch f) hiddenCat _ _ _ = return Nothing diff --git a/Annex/Content.hs b/Annex/Content.hs index 040914bb73..b3752c6ba9 100644 --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -483,7 +483,7 @@ moveAnnex key src = ifM (checkSecureHashes key) fs <- map (`fromTopFilePath` g) <$> Database.Keys.getAssociatedFiles key unless (null fs) $ do - ics <- mapM (populatePointerFile (Restage True) key dest) fs + ics <- mapM (populatePointerFile (Restage True) key (toRawFilePath dest) . toRawFilePath) fs Database.Keys.storeInodeCaches' key [dest] (catMaybes ics) ) alreadyhave = liftIO $ removeFile src @@ -650,7 +650,7 @@ removeAnnex (ContentRemovalLock key) = withObjectLoc key $ \file -> -- Check associated pointer file for modifications, and reset if -- it's unmodified. resetpointer file = ifM (isUnmodified key file) - ( depopulatePointerFile key file + ( depopulatePointerFile key (toRawFilePath file) -- Modified file, so leave it alone. -- If it was a hard link to the annex object, -- that object might have been frozen as part of the diff --git a/Annex/Content/PointerFile.hs b/Annex/Content/PointerFile.hs index 2ed0db5ab9..59825a9d70 100644 --- a/Annex/Content/PointerFile.hs +++ b/Annex/Content/PointerFile.hs @@ -30,16 +30,17 @@ import Utility.Touch - - Returns an InodeCache if it populated the pointer file. -} -populatePointerFile :: Restage -> Key -> FilePath -> FilePath -> Annex (Maybe InodeCache) +populatePointerFile :: Restage -> Key -> RawFilePath -> RawFilePath -> Annex (Maybe InodeCache) populatePointerFile restage k obj f = go =<< liftIO (isPointerFile f) where go (Just k') | k == k' = do - destmode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus f - liftIO $ nukeFile f - (ic, populated) <- replaceFile f $ \tmp -> do - ok <- linkOrCopy k obj tmp destmode >>= \case + let f' = fromRawFilePath f + destmode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus f' + liftIO $ nukeFile f' + (ic, populated) <- replaceFile f' $ \tmp -> do + ok <- linkOrCopy k (fromRawFilePath obj) tmp destmode >>= \case Just _ -> thawContent tmp >> return True - Nothing -> liftIO (writePointerFile tmp k destmode) >> return False + Nothing -> liftIO (writePointerFile (toRawFilePath tmp) k destmode) >> return False ic <- withTSDelta (liftIO . genInodeCache tmp) return (ic, ok) maybe noop (restagePointerFile restage f) ic @@ -51,14 +52,15 @@ populatePointerFile restage k obj f = go =<< liftIO (isPointerFile f) {- Removes the content from a pointer file, replacing it with a pointer. - - Does not check if the pointer file is modified. -} -depopulatePointerFile :: Key -> FilePath -> Annex () +depopulatePointerFile :: Key -> RawFilePath -> Annex () depopulatePointerFile key file = do - st <- liftIO $ catchMaybeIO $ getFileStatus file + let file' = fromRawFilePath file + st <- liftIO $ catchMaybeIO $ getFileStatus file' let mode = fmap fileMode st - secureErase file - liftIO $ nukeFile file - ic <- replaceFile file $ \tmp -> do - liftIO $ writePointerFile tmp key mode + secureErase file' + liftIO $ nukeFile file' + ic <- replaceFile file' $ \tmp -> do + liftIO $ writePointerFile (toRawFilePath tmp) key mode #if ! defined(mingw32_HOST_OS) -- Don't advance mtime; this avoids unncessary re-smudging -- by git in some cases. diff --git a/Annex/FileMatcher.hs b/Annex/FileMatcher.hs index b41a4a421f..05e6e7f761 100644 --- a/Annex/FileMatcher.hs +++ b/Annex/FileMatcher.hs @@ -54,7 +54,7 @@ checkFileMatcher' getmatcher file notconfigured = do matcher <- getmatcher file checkMatcher matcher Nothing afile S.empty notconfigured d where - afile = AssociatedFile (Just file) + afile = AssociatedFile (Just (toRawFilePath file)) -- checkMatcher will never use this, because afile is provided. d = return True @@ -62,7 +62,7 @@ checkMatcher :: FileMatcher Annex -> Maybe Key -> AssociatedFile -> AssumeNotPre checkMatcher matcher mkey afile notpresent notconfigured d | isEmpty matcher = notconfigured | otherwise = case (mkey, afile) of - (_, AssociatedFile (Just file)) -> go =<< fileMatchInfo file + (_, AssociatedFile (Just file)) -> go =<< fileMatchInfo (fromRawFilePath file) (Just key, _) -> go (MatchingKey key afile) _ -> d where diff --git a/Annex/Journal.hs b/Annex/Journal.hs index 917d638aa8..e7e624f354 100644 --- a/Annex/Journal.hs +++ b/Annex/Journal.hs @@ -44,18 +44,18 @@ instance Journalable Builder where - getJournalFileStale to always return a consistent journal file - content, although possibly not the most current one. -} -setJournalFile :: Journalable content => JournalLocked -> FilePath -> content -> Annex () +setJournalFile :: Journalable content => JournalLocked -> RawFilePath -> content -> Annex () setJournalFile _jl file content = withOtherTmp $ \tmp -> do createAnnexDirectory =<< fromRepo gitAnnexJournalDir -- journal file is written atomically - jfile <- fromRepo $ journalFile file + jfile <- fromRepo $ journalFile $ fromRawFilePath file let tmpfile = tmp takeFileName jfile liftIO $ do withFile tmpfile WriteMode $ \h -> writeJournalHandle h content moveFile tmpfile jfile {- Gets any journalled content for a file in the branch. -} -getJournalFile :: JournalLocked -> FilePath -> Annex (Maybe L.ByteString) +getJournalFile :: JournalLocked -> RawFilePath -> Annex (Maybe L.ByteString) getJournalFile _jl = getJournalFileStale {- Without locking, this is not guaranteed to be the most recent @@ -69,9 +69,9 @@ getJournalFile _jl = getJournalFileStale - concurrency or other issues with a lazy read, and the minor loss of - laziness doesn't matter much, as the files are not very large. -} -getJournalFileStale :: FilePath -> Annex (Maybe L.ByteString) +getJournalFileStale :: RawFilePath -> Annex (Maybe L.ByteString) getJournalFileStale file = inRepo $ \g -> catchMaybeIO $ - L.fromStrict <$> S.readFile (journalFile file g) + L.fromStrict <$> S.readFile (journalFile (fromRawFilePath file) g) {- List of existing journal files, but without locking, may miss new ones - just being added, or may have false positives if the journal is staged diff --git a/Annex/Link.hs b/Annex/Link.hs index 00c2d68d9e..609e9eb1d3 100644 --- a/Annex/Link.hs +++ b/Annex/Link.hs @@ -43,7 +43,7 @@ import qualified Data.ByteString.Lazy as L type LinkTarget = String {- Checks if a file is a link to a key. -} -isAnnexLink :: FilePath -> Annex (Maybe Key) +isAnnexLink :: RawFilePath -> Annex (Maybe Key) isAnnexLink file = maybe Nothing parseLinkTargetOrPointer <$> getAnnexLinkTarget file {- Gets the link target of a symlink. @@ -54,13 +54,13 @@ isAnnexLink file = maybe Nothing parseLinkTargetOrPointer <$> getAnnexLinkTarget - Returns Nothing if the file is not a symlink, or not a link to annex - content. -} -getAnnexLinkTarget :: FilePath -> Annex (Maybe S.ByteString) +getAnnexLinkTarget :: RawFilePath -> Annex (Maybe S.ByteString) getAnnexLinkTarget f = getAnnexLinkTarget' f =<< (coreSymlinks <$> Annex.getGitConfig) {- Pass False to force looking inside file, for when git checks out - symlinks as plain files. -} -getAnnexLinkTarget' :: FilePath -> Bool -> Annex (Maybe S.ByteString) +getAnnexLinkTarget' :: RawFilePath -> Bool -> Annex (Maybe S.ByteString) getAnnexLinkTarget' file coresymlinks = if coresymlinks then check probesymlink $ return Nothing @@ -75,9 +75,9 @@ getAnnexLinkTarget' file coresymlinks = if coresymlinks | otherwise -> return Nothing Nothing -> fallback - probesymlink = R.readSymbolicLink $ toRawFilePath file + probesymlink = R.readSymbolicLink file - probefilecontent = withFile file ReadMode $ \h -> do + probefilecontent = withFile (fromRawFilePath file) ReadMode $ \h -> do s <- S.hGet h unpaddedMaxPointerSz -- If we got the full amount, the file is too large -- to be a symlink target. @@ -92,7 +92,7 @@ getAnnexLinkTarget' file coresymlinks = if coresymlinks then mempty else s -makeAnnexLink :: LinkTarget -> FilePath -> Annex () +makeAnnexLink :: LinkTarget -> RawFilePath -> Annex () makeAnnexLink = makeGitLink {- Creates a link on disk. @@ -102,48 +102,48 @@ makeAnnexLink = makeGitLink - it's staged as such, so use addAnnexLink when adding a new file or - modified link to git. -} -makeGitLink :: LinkTarget -> FilePath -> Annex () +makeGitLink :: LinkTarget -> RawFilePath -> Annex () makeGitLink linktarget file = ifM (coreSymlinks <$> Annex.getGitConfig) ( liftIO $ do - void $ tryIO $ removeFile file - createSymbolicLink linktarget file - , liftIO $ writeFile file linktarget + void $ tryIO $ removeFile (fromRawFilePath file) + createSymbolicLink linktarget (fromRawFilePath file) + , liftIO $ writeFile (fromRawFilePath file) linktarget ) {- Creates a link on disk, and additionally stages it in git. -} -addAnnexLink :: LinkTarget -> FilePath -> Annex () +addAnnexLink :: LinkTarget -> RawFilePath -> Annex () addAnnexLink linktarget file = do makeAnnexLink linktarget file stageSymlink file =<< hashSymlink linktarget {- Injects a symlink target into git, returning its Sha. -} hashSymlink :: LinkTarget -> Annex Sha -hashSymlink linktarget = hashBlob $ toRawFilePath $ toInternalGitPath linktarget +hashSymlink = hashBlob . toInternalGitPath . toRawFilePath {- Stages a symlink to an annexed object, using a Sha of its target. -} -stageSymlink :: FilePath -> Sha -> Annex () +stageSymlink :: RawFilePath -> Sha -> Annex () stageSymlink file sha = Annex.Queue.addUpdateIndex =<< - inRepo (Git.UpdateIndex.stageSymlink file sha) + inRepo (Git.UpdateIndex.stageSymlink (fromRawFilePath file) sha) {- Injects a pointer file content into git, returning its Sha. -} hashPointerFile :: Key -> Annex Sha hashPointerFile key = hashBlob $ formatPointer key {- Stages a pointer file, using a Sha of its content -} -stagePointerFile :: FilePath -> Maybe FileMode -> Sha -> Annex () +stagePointerFile :: RawFilePath -> Maybe FileMode -> Sha -> Annex () stagePointerFile file mode sha = Annex.Queue.addUpdateIndex =<< - inRepo (Git.UpdateIndex.stageFile sha treeitemtype file) + inRepo (Git.UpdateIndex.stageFile sha treeitemtype $ fromRawFilePath file) where treeitemtype | maybe False isExecutable mode = TreeExecutable | otherwise = TreeFile -writePointerFile :: FilePath -> Key -> Maybe FileMode -> IO () +writePointerFile :: RawFilePath -> Key -> Maybe FileMode -> IO () writePointerFile file k mode = do - S.writeFile file (formatPointer k) - maybe noop (setFileMode file) mode + S.writeFile (fromRawFilePath file) (formatPointer k) + maybe noop (setFileMode $ fromRawFilePath file) mode newtype Restage = Restage Bool @@ -172,17 +172,17 @@ newtype Restage = Restage Bool - the worktree file is changed by something else before git update-index - gets to look at it. -} -restagePointerFile :: Restage -> FilePath -> InodeCache -> Annex () +restagePointerFile :: Restage -> RawFilePath -> InodeCache -> Annex () restagePointerFile (Restage False) f _ = - toplevelWarning True $ unableToRestage (Just f) + toplevelWarning True $ unableToRestage $ Just $ fromRawFilePath f restagePointerFile (Restage True) f orig = withTSDelta $ \tsd -> do -- update-index is documented as picky about "./file" and it -- fails on "../../repo/path/file" when cwd is not in the repo -- being acted on. Avoid these problems with an absolute path. - absf <- liftIO $ absPath f + absf <- liftIO $ absPath $ fromRawFilePath f Annex.Queue.addInternalAction runner [(absf, isunmodified tsd)] where - isunmodified tsd = genInodeCache f tsd >>= return . \case + isunmodified tsd = genInodeCache (fromRawFilePath f) tsd >>= return . \case Nothing -> False Just new -> compareStrong orig new @@ -264,7 +264,7 @@ parseLinkTarget l formatPointer :: Key -> S.ByteString formatPointer k = prefix <> keyFile' k <> nl where - prefix = toRawFilePath $ toInternalGitPath (pathSeparator:objectDir) + prefix = toInternalGitPath $ toRawFilePath (pathSeparator:objectDir) nl = S8.singleton '\n' {- Maximum size of a file that could be a pointer to a key. @@ -283,8 +283,8 @@ unpaddedMaxPointerSz = 8192 {- Checks if a worktree file is a pointer to a key. - - Unlocked files whose content is present are not detected by this. -} -isPointerFile :: FilePath -> IO (Maybe Key) -isPointerFile f = catchDefaultIO Nothing $ withFile f ReadMode $ \h -> +isPointerFile :: RawFilePath -> IO (Maybe Key) +isPointerFile f = catchDefaultIO Nothing $ withFile (fromRawFilePath f) ReadMode $ \h -> parseLinkTargetOrPointer <$> S.hGet h unpaddedMaxPointerSz {- Checks a symlink target or pointer file first line to see if it diff --git a/Annex/Locations.hs b/Annex/Locations.hs index cdaa8d3f6e..1a9b5a6055 100644 --- a/Annex/Locations.hs +++ b/Annex/Locations.hs @@ -192,7 +192,8 @@ gitAnnexLink file key r config = do let absfile = absNormPathUnix currdir file let gitdir = getgitdir currdir loc <- gitAnnexLocation' key r config False False (\_ -> return True) gitdir - toInternalGitPath <$> relPathDirToFile (parentDir absfile) loc + fromRawFilePath . toInternalGitPath . toRawFilePath + <$> relPathDirToFile (parentDir absfile) loc where getgitdir currdir {- This special case is for git submodules on filesystems not diff --git a/Annex/MetaData.hs b/Annex/MetaData.hs index 4b355dbb72..4e0a541af9 100644 --- a/Annex/MetaData.hs +++ b/Annex/MetaData.hs @@ -37,7 +37,7 @@ import Data.Time.Clock.POSIX - - Also, can generate new metadata, if configured to do so. -} -genMetaData :: Key -> FilePath -> FileStatus -> Annex () +genMetaData :: Key -> RawFilePath -> FileStatus -> Annex () genMetaData key file status = do catKeyFileHEAD file >>= \case Nothing -> noop @@ -53,8 +53,8 @@ genMetaData key file status = do where mtime = posixSecondsToUTCTime $ realToFrac $ modificationTime status warncopied = warning $ - "Copied metadata from old version of " ++ file ++ " to new version. " ++ - "If you don't want this copied metadata, run: git annex metadata --remove-all " ++ file + "Copied metadata from old version of " ++ fromRawFilePath file ++ " to new version. " ++ + "If you don't want this copied metadata, run: git annex metadata --remove-all " ++ fromRawFilePath file -- If the only fields copied were date metadata, and they'll -- be overwritten with the current mtime, no need to warn about -- copying. diff --git a/Annex/Notification.hs b/Annex/Notification.hs index 29b8fc9828..186676cd3e 100644 --- a/Annex/Notification.hs +++ b/Annex/Notification.hs @@ -60,7 +60,7 @@ notifyDrop (AssociatedFile (Just f)) ok = do wanted <- Annex.getState Annex.desktopnotify when (notifyFinish wanted) $ liftIO $ do client <- DBus.Client.connectSession - void $ Notify.notify client (droppedNote ok f) + void $ Notify.notify client (droppedNote ok (fromRawFilePath f)) #else notifyDrop (AssociatedFile (Just _)) _ = noop #endif diff --git a/Annex/NumCopies.hs b/Annex/NumCopies.hs index 0072614674..0b9b9b7096 100644 --- a/Annex/NumCopies.hs +++ b/Annex/NumCopies.hs @@ -72,7 +72,7 @@ getFileNumCopies f = fromSources getAssociatedFileNumCopies :: AssociatedFile -> Annex NumCopies getAssociatedFileNumCopies (AssociatedFile afile) = - maybe getNumCopies getFileNumCopies afile + maybe getNumCopies getFileNumCopies (fromRawFilePath <$> afile) {- This is the globally visible numcopies value for a file. So it does - not include local configuration in the git config or command line diff --git a/Annex/View.hs b/Annex/View.hs index 412cca8e0e..d20bbb8caa 100644 --- a/Annex/View.hs +++ b/Annex/View.hs @@ -343,11 +343,11 @@ narrowView = applyView' viewedFileReuse getViewedFileMetaData applyView' :: MkViewedFile -> (FilePath -> MetaData) -> View -> Annex Git.Branch applyView' mkviewedfile getfilemetadata view = do top <- fromRepo Git.repoPath - (l, clean) <- inRepo $ Git.LsFiles.stagedDetails [top] + (l, clean) <- inRepo $ Git.LsFiles.stagedDetails [toRawFilePath top] liftIO . nukeFile =<< fromRepo gitAnnexViewIndex uh <- withViewIndex $ inRepo Git.UpdateIndex.startUpdateIndex forM_ l $ \(f, sha, mode) -> do - topf <- inRepo (toTopFilePath f) + topf <- inRepo (toTopFilePath $ fromRawFilePath f) go uh topf sha (toTreeItemType =<< mode) =<< lookupFile f liftIO $ do void $ stopUpdateIndex uh diff --git a/Annex/WorkTree.hs b/Annex/WorkTree.hs index b04eeac4d8..269213428e 100644 --- a/Annex/WorkTree.hs +++ b/Annex/WorkTree.hs @@ -33,35 +33,35 @@ import Config - When in an adjusted branch that may have hidden the file, looks for a - pointer to a key in the original branch. -} -lookupFile :: FilePath -> Annex (Maybe Key) +lookupFile :: RawFilePath -> Annex (Maybe Key) lookupFile = lookupFile' catkeyfile where catkeyfile file = - ifM (liftIO $ doesFileExist file) + ifM (liftIO $ doesFileExist $ fromRawFilePath file) ( catKeyFile file , catKeyFileHidden file =<< getCurrentBranch ) -lookupFileNotHidden :: FilePath -> Annex (Maybe Key) +lookupFileNotHidden :: RawFilePath -> Annex (Maybe Key) lookupFileNotHidden = lookupFile' catkeyfile where catkeyfile file = - ifM (liftIO $ doesFileExist file) + ifM (liftIO $ doesFileExist $ fromRawFilePath file) ( catKeyFile file , return Nothing ) -lookupFile' :: (FilePath -> Annex (Maybe Key)) -> FilePath -> Annex (Maybe Key) +lookupFile' :: (RawFilePath -> Annex (Maybe Key)) -> RawFilePath -> Annex (Maybe Key) lookupFile' catkeyfile file = isAnnexLink file >>= \case Just key -> return (Just key) Nothing -> catkeyfile file {- Modifies an action to only act on files that are already annexed, - and passes the key on to it. -} -whenAnnexed :: (FilePath -> Key -> Annex (Maybe a)) -> FilePath -> Annex (Maybe a) +whenAnnexed :: (RawFilePath -> Key -> Annex (Maybe a)) -> RawFilePath -> Annex (Maybe a) whenAnnexed a file = ifAnnexed file (a file) (return Nothing) -ifAnnexed :: FilePath -> (Key -> Annex a) -> Annex a -> Annex a +ifAnnexed :: RawFilePath -> (Key -> Annex a) -> Annex a -> Annex a ifAnnexed file yes no = maybe no yes =<< lookupFile file {- Find all unlocked files and update the keys database for them. @@ -96,7 +96,7 @@ scanUnlockedFiles = whenM (inRepo Git.Ref.headExists <&&> not <$> isBareRepo) $ liftIO . Database.Keys.SQL.addAssociatedFileFast (toIKey k) tf whenM (inAnnex k) $ do f <- fromRepo $ fromTopFilePath tf - liftIO (isPointerFile f) >>= \case + liftIO (isPointerFile (toRawFilePath f)) >>= \case Just k' | k' == k -> do destmode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus f ic <- replaceFile f $ \tmp -> @@ -105,7 +105,7 @@ scanUnlockedFiles = whenM (inRepo Git.Ref.headExists <&&> not <$> isBareRepo) $ withTSDelta (liftIO . genInodeCache tmp) LinkAnnexNoop -> return Nothing LinkAnnexFailed -> liftIO $ do - writePointerFile tmp k destmode + writePointerFile (toRawFilePath tmp) k destmode return Nothing - maybe noop (restagePointerFile (Restage True) f) ic + maybe noop (restagePointerFile (Restage True) (toRawFilePath f)) ic _ -> noop diff --git a/Backend/Hash.hs b/Backend/Hash.hs index c91f175772..aec60f0cfe 100644 --- a/Backend/Hash.hs +++ b/Backend/Hash.hs @@ -188,7 +188,7 @@ trivialMigrate' oldkey newbackend afile maxextlen AssociatedFile Nothing -> Nothing AssociatedFile (Just file) -> Just $ alterKey oldkey $ \d -> d { keyName = keyHash oldkey - <> encodeBS (selectExtension maxextlen file) + <> encodeBS' (selectExtension maxextlen (fromRawFilePath file)) , keyVariety = newvariety } {- Upgrade to fix bad previous migration that created a diff --git a/CmdLine/GitAnnexShell/Fields.hs b/CmdLine/GitAnnexShell/Fields.hs index c5c0118a43..639adf3477 100644 --- a/CmdLine/GitAnnexShell/Fields.hs +++ b/CmdLine/GitAnnexShell/Fields.hs @@ -30,7 +30,7 @@ remoteUUID = Field "remoteuuid" $ associatedFile :: Field associatedFile = Field "associatedfile" $ \f -> -- is the file a safe relative filename? - not (absoluteGitPath f) && not ("../" `isPrefixOf` f) + not (absoluteGitPath (toRawFilePath f)) && not ("../" `isPrefixOf` f) direct :: Field direct = Field "direct" $ \f -> f == "1" diff --git a/CmdLine/Seek.hs b/CmdLine/Seek.hs index e523eac99a..68ee9efc02 100644 --- a/CmdLine/Seek.hs +++ b/CmdLine/Seek.hs @@ -48,7 +48,7 @@ withFilesInGitNonRecursive needforce a l = ifM (Annex.getState Annex.force) where getfiles c [] = return (reverse c) getfiles c ((WorkTreeItem p):ps) = do - (fs, cleanup) <- inRepo $ LsFiles.inRepo [p] + (fs, cleanup) <- inRepo $ LsFiles.inRepo [toRawFilePath p] case fs of [f] -> do void $ liftIO $ cleanup @@ -62,7 +62,7 @@ withFilesNotInGit :: Bool -> (RawFilePath -> CommandSeek) -> [WorkTreeItem] -> C withFilesNotInGit skipdotfiles a l | skipdotfiles = do {- dotfiles are not acted on unless explicitly listed -} - files <- filter (not . dotfile) <$> + files <- filter (not . dotfile . fromRawFilePath) <$> seekunless (null ps && not (null l)) ps dotfiles <- seekunless (null dotps) dotps go (files++dotfiles) @@ -74,11 +74,11 @@ withFilesNotInGit skipdotfiles a l force <- Annex.getState Annex.force g <- gitRepo liftIO $ Git.Command.leaveZombie - <$> LsFiles.notInRepo force (map (\(WorkTreeItem f) -> f) l') g + <$> LsFiles.notInRepo force (map (\(WorkTreeItem f) -> toRawFilePath f) l') g go fs = seekActions $ prepFiltered a $ - return $ concat $ segmentPaths (map (\(WorkTreeItem f) -> f) l) fs + return $ concat $ segmentPaths (map (\(WorkTreeItem f) -> toRawFilePath f) l) fs -withPathContents :: ((RawFilePath, RawFilePath) -> CommandSeek) -> CmdParams -> CommandSeek +withPathContents :: ((FilePath, FilePath) -> CommandSeek) -> CmdParams -> CommandSeek withPathContents a params = do matcher <- Limit.getMatcher forM_ params $ \p -> do @@ -130,7 +130,7 @@ withUnmodifiedUnlockedPointers a l = seekActions $ isUnmodifiedUnlocked :: RawFilePath -> Annex Bool isUnmodifiedUnlocked f = catKeyFile f >>= \case Nothing -> return False - Just k -> sameInodeCache f =<< Database.Keys.getInodeCaches k + Just k -> sameInodeCache (fromRawFilePath f) =<< Database.Keys.getInodeCaches k {- Finds files that may be modified. -} withFilesMaybeModified :: (RawFilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek @@ -169,7 +169,7 @@ withKeyOptions ko auto keyaction = withKeyOptions' ko auto mkkeyaction return $ \v@(k, ai) -> let i = case ai of ActionItemBranchFilePath (BranchFilePath _ topf) _ -> - MatchingKey k (AssociatedFile $ Just $ getTopFilePath topf) + MatchingKey k (AssociatedFile $ Just $ toRawFilePath $ getTopFilePath topf) _ -> MatchingKey k (AssociatedFile Nothing) in whenM (matcher i) $ keyaction v @@ -230,7 +230,9 @@ prepFiltered a fs = do matcher <- Limit.getMatcher map (process matcher) <$> fs where - process matcher f = whenM (matcher $ MatchingFile $ FileInfo f f) $ a f + process matcher f = + let f' = fromRawFilePath f + in whenM (matcher $ MatchingFile $ FileInfo f' f') $ a f seekActions :: Annex [CommandSeek] -> Annex () seekActions gen = sequence_ =<< gen @@ -238,12 +240,12 @@ seekActions gen = sequence_ =<< gen seekHelper :: ([RawFilePath] -> Git.Repo -> IO ([RawFilePath], IO Bool)) -> [WorkTreeItem] -> Annex [RawFilePath] seekHelper a l = inRepo $ \g -> concat . concat <$> forM (segmentXargsOrdered l') - (runSegmentPaths (\fs -> Git.Command.leaveZombie <$> a fs g)) + (runSegmentPaths (\fs -> Git.Command.leaveZombie <$> a fs g) . map toRawFilePath) where l' = map (\(WorkTreeItem f) -> f) l -- An item in the work tree, which may be a file or a directory. -newtype WorkTreeItem = WorkTreeItem RawFilePath +newtype WorkTreeItem = WorkTreeItem FilePath -- When in an adjusted branch that hides some files, it may not exist -- in the current work tree, but in the original branch. This allows @@ -264,14 +266,14 @@ workTreeItems' (AllowHidden allowhidden) ps = do unlessM (exists p <||> hidden currbranch p) $ do toplevelWarning False (p ++ " not found") Annex.incError - return (map WorkTreeItem ps) + return (map (WorkTreeItem) ps) where exists p = isJust <$> liftIO (catchMaybeIO $ getSymbolicLinkStatus p) hidden currbranch p | allowhidden = do f <- liftIO $ relPathCwdToFile p - isJust <$> catObjectMetaDataHidden f currbranch + isJust <$> catObjectMetaDataHidden (toRawFilePath f) currbranch | otherwise = return False notSymlink :: RawFilePath -> IO Bool -notSymlink f = liftIO $ not . isSymbolicLink <$> getSymbolicLinkStatus f +notSymlink f = liftIO $ not . isSymbolicLink <$> getSymbolicLinkStatus (fromRawFilePath f) diff --git a/Command/Find.hs b/Command/Find.hs index 820b993a93..06dcd86fd7 100644 --- a/Command/Find.hs +++ b/Command/Find.hs @@ -9,6 +9,7 @@ module Command.Find where import Data.Default import qualified Data.Map as M +import qualified Data.ByteString.Char8 as S8 import Command import Annex.Content @@ -57,29 +58,29 @@ seek o = case batchOption o of (commandAction . startKeys o) (withFilesInGit (commandAction . go)) =<< workTreeItems (findThese o) - Batch fmt -> batchFilesMatching fmt go + Batch fmt -> batchFilesMatching fmt (go . toRawFilePath) where go = whenAnnexed $ start o -- only files inAnnex are shown, unless the user has requested -- others via a limit -start :: FindOptions -> FilePath -> Key -> CommandStart +start :: FindOptions -> RawFilePath -> Key -> CommandStart start o file key = stopUnless (limited <||> inAnnex key) $ startingCustomOutput key $ do - showFormatted (formatOption o) file $ ("file", file) : keyVars key + showFormatted (formatOption o) file $ ("file", fromRawFilePath file) : keyVars key next $ return True startKeys :: FindOptions -> (Key, ActionItem) -> CommandStart startKeys o (key, ActionItemBranchFilePath (BranchFilePath _ topf) _) = - start o (getTopFilePath topf) key + start o (toRawFilePath (getTopFilePath topf)) key startKeys _ _ = stop -showFormatted :: Maybe Utility.Format.Format -> String -> [(String, String)] -> Annex () +showFormatted :: Maybe Utility.Format.Format -> RawFilePath -> [(String, String)] -> Annex () showFormatted format unformatted vars = unlessM (showFullJSON $ JSONChunk vars) $ case format of - Nothing -> liftIO $ putStrLn unformatted + Nothing -> liftIO $ S8.putStrLn unformatted Just formatter -> liftIO $ putStr $ Utility.Format.format formatter $ M.fromList vars diff --git a/Command/Unannex.hs b/Command/Unannex.hs index cbb8cb5214..7610b56176 100644 --- a/Command/Unannex.hs +++ b/Command/Unannex.hs @@ -25,10 +25,10 @@ cmd = withGlobalOptions [annexedMatchingOptions] $ seek :: CmdParams -> CommandSeek seek ps = (withFilesInGit $ commandAction . whenAnnexed start) =<< workTreeItems ps -start :: FilePath -> Key -> CommandStart +start :: RawFilePath -> Key -> CommandStart start file key = stopUnless (inAnnex key) $ starting "unannex" (mkActionItem (key, file)) $ - perform file key + perform (fromRawFilePath file) key perform :: FilePath -> Key -> CommandPerform perform file key = do diff --git a/Command/Uninit.hs b/Command/Uninit.hs index 3f2a45c10f..1e4ebdf2dc 100644 --- a/Command/Uninit.hs +++ b/Command/Uninit.hs @@ -34,14 +34,14 @@ check = do whenM ((/=) <$> liftIO (absPath top) <*> liftIO (absPath currdir)) $ giveup "can only run uninit from the top of the git repository" where - current_branch = Git.Ref . Prelude.head . lines <$> revhead + current_branch = Git.Ref . Prelude.head . lines . decodeBS' <$> revhead revhead = inRepo $ Git.Command.pipeReadStrict [Param "rev-parse", Param "--abbrev-ref", Param "HEAD"] seek :: CmdParams -> CommandSeek seek ps = do l <- workTreeItems ps - withFilesNotInGit False (commandAction . whenAnnexed startCheckIncomplete) l + withFilesNotInGit False (commandAction . whenAnnexed (startCheckIncomplete . fromRawFilePath)) l Annex.changeState $ \s -> s { Annex.fast = True } withFilesInGit (commandAction . whenAnnexed Command.Unannex.start) l finish diff --git a/Database/ContentIdentifier.hs b/Database/ContentIdentifier.hs index 024825eaec..bbe3022367 100644 --- a/Database/ContentIdentifier.hs +++ b/Database/ContentIdentifier.hs @@ -145,7 +145,7 @@ updateFromLog db (oldtree, currtree) = do recordAnnexBranchTree db currtree flushDbQueue db where - go ti = case extLogFileKey remoteContentIdentifierExt (getTopFilePath (DiffTree.file ti)) of + go ti = case extLogFileKey remoteContentIdentifierExt (toRawFilePath (getTopFilePath (DiffTree.file ti))) of Nothing -> return () Just k -> do l <- Log.getContentIdentifiers k diff --git a/Database/Export.hs b/Database/Export.hs index 0da0173fad..6168a60616 100644 --- a/Database/Export.hs +++ b/Database/Export.hs @@ -128,28 +128,28 @@ addExportedLocation :: ExportHandle -> Key -> ExportLocation -> IO () addExportedLocation h k el = queueDb h $ do void $ insertUnique $ Exported ik ef let edirs = map - (\ed -> ExportedDirectory (toSFilePath (fromExportDirectory ed)) ef) + (\ed -> ExportedDirectory (toSFilePath (fromRawFilePath (fromExportDirectory ed))) ef) (exportDirectories el) putMany edirs where ik = toIKey k - ef = toSFilePath (fromExportLocation el) + ef = toSFilePath $ fromRawFilePath $ fromExportLocation el removeExportedLocation :: ExportHandle -> Key -> ExportLocation -> IO () removeExportedLocation h k el = queueDb h $ do deleteWhere [ExportedKey ==. ik, ExportedFile ==. ef] - let subdirs = map (toSFilePath . fromExportDirectory) + let subdirs = map (toSFilePath . fromRawFilePath . fromExportDirectory) (exportDirectories el) deleteWhere [ExportedDirectoryFile ==. ef, ExportedDirectorySubdir <-. subdirs] where ik = toIKey k - ef = toSFilePath (fromExportLocation el) + ef = toSFilePath $ fromRawFilePath $ fromExportLocation el {- Note that this does not see recently queued changes. -} getExportedLocation :: ExportHandle -> Key -> IO [ExportLocation] getExportedLocation (ExportHandle h _) k = H.queryDbQueue h $ do l <- selectList [ExportedKey ==. ik] [] - return $ map (mkExportLocation . fromSFilePath . exportedFile . entityVal) l + return $ map (mkExportLocation . toRawFilePath . fromSFilePath . exportedFile . entityVal) l where ik = toIKey k @@ -159,13 +159,13 @@ isExportDirectoryEmpty (ExportHandle h _) d = H.queryDbQueue h $ do l <- selectList [ExportedDirectorySubdir ==. ed] [] return $ null l where - ed = toSFilePath $ fromExportDirectory d + ed = toSFilePath $ fromRawFilePath $ fromExportDirectory d {- Get locations in the export that might contain a key. -} getExportTree :: ExportHandle -> Key -> IO [ExportLocation] getExportTree (ExportHandle h _) k = H.queryDbQueue h $ do l <- selectList [ExportTreeKey ==. ik] [] - return $ map (mkExportLocation . fromSFilePath . exportTreeFile . entityVal) l + return $ map (mkExportLocation . toRawFilePath . fromSFilePath . exportTreeFile . entityVal) l where ik = toIKey k @@ -181,21 +181,21 @@ getExportTreeKey (ExportHandle h _) el = H.queryDbQueue h $ do map (fromIKey . exportTreeKey . entityVal) <$> selectList [ExportTreeFile ==. ef] [] where - ef = toSFilePath (fromExportLocation el) + ef = toSFilePath (fromRawFilePath $ fromExportLocation el) addExportTree :: ExportHandle -> Key -> ExportLocation -> IO () addExportTree h k loc = queueDb h $ void $ insertUnique $ ExportTree ik ef where ik = toIKey k - ef = toSFilePath (fromExportLocation loc) + ef = toSFilePath (fromRawFilePath $ fromExportLocation loc) removeExportTree :: ExportHandle -> Key -> ExportLocation -> IO () removeExportTree h k loc = queueDb h $ deleteWhere [ExportTreeKey ==. ik, ExportTreeFile ==. ef] where ik = toIKey k - ef = toSFilePath (fromExportLocation loc) + ef = toSFilePath (fromRawFilePath $ fromExportLocation loc) -- An action that is passed the old and new values that were exported, -- and updates state. @@ -220,7 +220,7 @@ mkExportDiffUpdater removeold addnew h srcek dstek i = do Nothing -> return () Just k -> liftIO $ addnew h (asKey k) loc where - loc = mkExportLocation $ getTopFilePath $ Git.DiffTree.file i + loc = mkExportLocation $ toRawFilePath $ getTopFilePath $ Git.DiffTree.file i runExportDiffUpdater :: ExportDiffUpdater -> ExportHandle -> Sha -> Sha -> Annex () runExportDiffUpdater updater h old new = do diff --git a/Database/Keys.hs b/Database/Keys.hs index c31f647c09..bff7109135 100644 --- a/Database/Keys.hs +++ b/Database/Keys.hs @@ -235,7 +235,7 @@ reconcileStaged qh = do where go cur indexcache = do (l, cleanup) <- inRepo $ pipeNullSplit diff - changed <- procdiff l False + changed <- procdiff (map decodeBL' l) False void $ liftIO cleanup -- Flush database changes immediately -- so other processes can see them. @@ -262,7 +262,8 @@ reconcileStaged qh = do -- perfect. A file could start with this and not be a -- pointer file. And a pointer file that is replaced with -- a non-pointer file will match this. - , Param $ "-G^" ++ toInternalGitPath (pathSeparator:objectDir) + , Param $ "-G^" ++ fromRawFilePath (toInternalGitPath $ + toRawFilePath (pathSeparator:objectDir)) -- Don't include files that were deleted, because this only -- wants to update information for files that are present -- in the index. @@ -277,7 +278,7 @@ reconcileStaged qh = do procdiff (info:file:rest) changed = case words info of ((':':_srcmode):dstmode:_srcsha:dstsha:_change:[]) -- Only want files, not symlinks - | dstmode /= fmtTreeItemType TreeSymlink -> do + | dstmode /= decodeBS' (fmtTreeItemType TreeSymlink) -> do maybe noop (reconcile (asTopFilePath file)) =<< catKey (Ref dstsha) procdiff rest True @@ -293,11 +294,11 @@ reconcileStaged qh = do caches <- liftIO $ SQL.getInodeCaches ikey (SQL.ReadHandle qh) keyloc <- calcRepo (gitAnnexLocation key) keypopulated <- sameInodeCache keyloc caches - p <- fromRepo $ fromTopFilePath file - filepopulated <- sameInodeCache p caches + p <- fromRepo $ toRawFilePath . fromTopFilePath file + filepopulated <- sameInodeCache (fromRawFilePath p) caches case (keypopulated, filepopulated) of (True, False) -> - populatePointerFile (Restage True) key keyloc p >>= \case + populatePointerFile (Restage True) key (toRawFilePath keyloc) p >>= \case Nothing -> return () Just ic -> liftIO $ SQL.addInodeCaches ikey [ic] (SQL.WriteHandle qh) diff --git a/Git/Command.hs b/Git/Command.hs index 12f69b6201..1db11ab9e4 100644 --- a/Git/Command.hs +++ b/Git/Command.hs @@ -102,7 +102,10 @@ pipeNullSplit params repo = do return (filter (not . L.null) $ L.split 0 s, cleanup) {- Reads lazily, but converts each part to a strict ByteString for - - convenience. -} + - convenience. + - + - FIXME the L.toStrict makes a copy, more expensive than ideal. + -} pipeNullSplit' :: [CommandParam] -> Repo -> IO ([S.ByteString], IO Bool) pipeNullSplit' params repo = do (s, cleanup) <- pipeNullSplit params repo @@ -116,6 +119,9 @@ pipeNullSplitStrict params repo = do pipeNullSplitZombie :: [CommandParam] -> Repo -> IO [L.ByteString] pipeNullSplitZombie params repo = leaveZombie <$> pipeNullSplit params repo +pipeNullSplitZombie' :: [CommandParam] -> Repo -> IO [S.ByteString] +pipeNullSplitZombie' params repo = leaveZombie <$> pipeNullSplit' params repo + {- Doesn't run the cleanup action. A zombie results. -} leaveZombie :: (a, IO Bool) -> a leaveZombie = fst diff --git a/Git/FilePath.hs b/Git/FilePath.hs index fffbea98d4..bb80df4815 100644 --- a/Git/FilePath.hs +++ b/Git/FilePath.hs @@ -12,6 +12,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} module Git.FilePath ( TopFilePath, @@ -33,6 +34,7 @@ import Git import qualified System.FilePath.Posix import GHC.Generics import Control.DeepSeq +import qualified Data.ByteString as S {- A RawFilePath, relative to the top of the git repository. -} newtype TopFilePath = TopFilePath { getTopFilePath :: FilePath } @@ -45,8 +47,9 @@ data BranchFilePath = BranchFilePath Ref TopFilePath deriving (Show, Eq, Ord) {- Git uses the branch:file form to refer to a BranchFilePath -} -descBranchFilePath :: BranchFilePath -> String -descBranchFilePath (BranchFilePath b f) = fromRef b ++ ':' : (getTopFilePath f) +descBranchFilePath :: BranchFilePath -> S.ByteString +descBranchFilePath (BranchFilePath b f) = + encodeBS' (fromRef b) <> ":" <> toRawFilePath (getTopFilePath f) {- Path to a TopFilePath, within the provided git repo. -} fromTopFilePath :: TopFilePath -> Git.Repo -> FilePath diff --git a/Git/Filename.hs b/Git/Filename.hs index 52dce828e3..0b0c4c27bf 100644 --- a/Git/Filename.hs +++ b/Git/Filename.hs @@ -36,5 +36,5 @@ encode :: RawFilePath -> S.ByteString encode s = encodeBS $ "\"" ++ encode_c (decodeBS s) ++ "\"" {- For quickcheck. -} -prop_encode_decode_roundtrip :: RawFilePath -> Bool -prop_encode_decode_roundtrip s = s == decode (encode s) +prop_encode_decode_roundtrip :: FilePath -> Bool +prop_encode_decode_roundtrip s = s == fromRawFilePath (decode (encode (toRawFilePath s))) diff --git a/Git/Ref.hs b/Git/Ref.hs index d0542f4f84..8c8511ae04 100644 --- a/Git/Ref.hs +++ b/Git/Ref.hs @@ -65,8 +65,8 @@ branchRef = underBase "refs/heads" - Prefixing the file with ./ makes this work even if in a subdirectory - of a repo. -} -fileRef :: FilePath -> Ref -fileRef f = Ref $ ":./" ++ f +fileRef :: RawFilePath -> Ref +fileRef f = Ref $ ":./" ++ fromRawFilePath f {- Converts a Ref to refer to the content of the Ref on a given date. -} dateRef :: Ref -> RefDate -> Ref @@ -74,7 +74,7 @@ dateRef (Ref r) (RefDate d) = Ref $ r ++ "@" ++ d {- A Ref that can be used to refer to a file in the repository as it - appears in a given Ref. -} -fileFromRef :: Ref -> FilePath -> Ref +fileFromRef :: Ref -> RawFilePath -> Ref fileFromRef (Ref r) f = let (Ref fr) = fileRef f in Ref (r ++ fr) {- Checks if a ref exists. -} diff --git a/Key.hs b/Key.hs index 22f6d79144..7fe5312cb7 100644 --- a/Key.hs +++ b/Key.hs @@ -78,6 +78,11 @@ instance Arbitrary KeyData where <*> ((abs <$>) <$> arbitrary) -- chunksize cannot be negative <*> ((succ . abs <$>) <$> arbitrary) -- chunknum cannot be 0 or negative +-- AssociatedFile cannot be empty (but can be Nothing) +instance Arbitrary AssociatedFile where + arbitrary = AssociatedFile . fmap toRawFilePath + <$> arbitrary `suchThat` (/= Just "") + instance Arbitrary Key where arbitrary = mkKey . const <$> arbitrary diff --git a/Limit.hs b/Limit.hs index a9647fd27c..7511e39abc 100644 --- a/Limit.hs +++ b/Limit.hs @@ -97,7 +97,7 @@ matchGlobFile glob = go go (MatchingFile fi) = pure $ matchGlob cglob (matchFile fi) go (MatchingInfo p) = matchGlob cglob <$> getInfo (providedFilePath p) go (MatchingKey _ (AssociatedFile Nothing)) = pure False - go (MatchingKey _ (AssociatedFile (Just af))) = pure $ matchGlob cglob af + go (MatchingKey _ (AssociatedFile (Just af))) = pure $ matchGlob cglob (fromRawFilePath af) addMimeType :: String -> Annex () addMimeType = addMagicLimit "mimetype" getMagicMimeType providedMimeType @@ -110,13 +110,13 @@ addMagicLimit limitname querymagic selectprovidedinfo glob = do magic <- liftIO initMagicMime addLimit $ matchMagic limitname querymagic' selectprovidedinfo magic glob where - querymagic' magic f = liftIO (isPointerFile f) >>= \case + querymagic' magic f = liftIO (isPointerFile (toRawFilePath f)) >>= \case -- Avoid getting magic of a pointer file, which would -- wrongly be detected as text. Just _ -> return Nothing -- When the file is an annex symlink, get magic of the -- object file. - Nothing -> isAnnexLink f >>= \case + Nothing -> isAnnexLink (toRawFilePath f) >>= \case Just k -> withObjectLoc k $ querymagic magic Nothing -> querymagic magic f @@ -143,7 +143,7 @@ matchLockStatus :: Bool -> MatchInfo -> Annex Bool matchLockStatus _ (MatchingKey _ _) = pure False matchLockStatus _ (MatchingInfo _) = pure False matchLockStatus wantlocked (MatchingFile fi) = liftIO $ do - islocked <- isPointerFile (currFile fi) >>= \case + islocked <- isPointerFile (toRawFilePath (currFile fi)) >>= \case Just _key -> return False Nothing -> isSymbolicLink <$> getSymbolicLinkStatus (currFile fi) @@ -192,7 +192,7 @@ limitInDir dir = const go where go (MatchingFile fi) = checkf $ matchFile fi go (MatchingKey _ (AssociatedFile Nothing)) = return False - go (MatchingKey _ (AssociatedFile (Just af))) = checkf af + go (MatchingKey _ (AssociatedFile (Just af))) = checkf (fromRawFilePath af) go (MatchingInfo p) = checkf =<< getInfo (providedFilePath p) checkf = return . elem dir . splitPath . takeDirectory @@ -368,7 +368,7 @@ addAccessedWithin duration = do secs = fromIntegral (durationSeconds duration) lookupFileKey :: FileInfo -> Annex (Maybe Key) -lookupFileKey = lookupFile . currFile +lookupFileKey = lookupFile . toRawFilePath . currFile checkKey :: (Key -> Annex Bool) -> MatchInfo -> Annex Bool checkKey a (MatchingFile fi) = lookupFileKey fi >>= maybe (return False) a diff --git a/Limit/Wanted.hs b/Limit/Wanted.hs index adbcafbfba..668614ce28 100644 --- a/Limit/Wanted.hs +++ b/Limit/Wanted.hs @@ -21,6 +21,6 @@ addWantDrop = addLimit $ Right $ const $ checkWant $ wantDrop False Nothing Nothing checkWant :: (AssociatedFile -> Annex Bool) -> MatchInfo -> Annex Bool -checkWant a (MatchingFile fi) = a (AssociatedFile (Just $ matchFile fi)) +checkWant a (MatchingFile fi) = a (AssociatedFile (Just $ toRawFilePath $ matchFile fi)) checkWant a (MatchingKey _ af) = a af checkWant _ (MatchingInfo {}) = return False diff --git a/Logs.hs b/Logs.hs index e7b15be3c6..d612aa8d56 100644 --- a/Logs.hs +++ b/Logs.hs @@ -5,11 +5,15 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Logs where import Annex.Common import Annex.DirHashes +import qualified Data.ByteString as S + {- There are several varieties of log file formats. -} data LogVariety = OldUUIDBasedLog @@ -22,7 +26,7 @@ data LogVariety {- Converts a path from the git-annex branch into one of the varieties - of logs used by git-annex, if it's a known path. -} -getLogVariety :: FilePath -> Maybe LogVariety +getLogVariety :: RawFilePath -> Maybe LogVariety getLogVariety f | f `elem` topLevelOldUUIDBasedLogs = Just OldUUIDBasedLog | f `elem` topLevelNewUUIDBasedLogs = Just NewUUIDBasedLog @@ -34,7 +38,7 @@ getLogVariety f | otherwise = PresenceLog <$> firstJust (presenceLogs f) {- All the old-format uuid-based logs stored in the top of the git-annex branch. -} -topLevelOldUUIDBasedLogs :: [FilePath] +topLevelOldUUIDBasedLogs :: [RawFilePath] topLevelOldUUIDBasedLogs = [ uuidLog , remoteLog @@ -49,161 +53,172 @@ topLevelOldUUIDBasedLogs = ] {- All the new-format uuid-based logs stored in the top of the git-annex branch. -} -topLevelNewUUIDBasedLogs :: [FilePath] +topLevelNewUUIDBasedLogs :: [RawFilePath] topLevelNewUUIDBasedLogs = [ exportLog ] {- All the ways to get a key from a presence log file -} -presenceLogs :: FilePath -> [Maybe Key] +presenceLogs :: RawFilePath -> [Maybe Key] presenceLogs f = [ urlLogFileKey f , locationLogFileKey f ] {- Top-level logs that are neither UUID based nor presence logs. -} -otherLogs :: [FilePath] +otherLogs :: [RawFilePath] otherLogs = [ numcopiesLog , groupPreferredContentLog ] -uuidLog :: FilePath +uuidLog :: RawFilePath uuidLog = "uuid.log" -numcopiesLog :: FilePath +numcopiesLog :: RawFilePath numcopiesLog = "numcopies.log" -configLog :: FilePath +configLog :: RawFilePath configLog = "config.log" -remoteLog :: FilePath +remoteLog :: RawFilePath remoteLog = "remote.log" -trustLog :: FilePath +trustLog :: RawFilePath trustLog = "trust.log" -groupLog :: FilePath +groupLog :: RawFilePath groupLog = "group.log" -preferredContentLog :: FilePath +preferredContentLog :: RawFilePath preferredContentLog = "preferred-content.log" -requiredContentLog :: FilePath +requiredContentLog :: RawFilePath requiredContentLog = "required-content.log" -groupPreferredContentLog :: FilePath +groupPreferredContentLog :: RawFilePath groupPreferredContentLog = "group-preferred-content.log" -scheduleLog :: FilePath +scheduleLog :: RawFilePath scheduleLog = "schedule.log" -activityLog :: FilePath +activityLog :: RawFilePath activityLog = "activity.log" -differenceLog :: FilePath +differenceLog :: RawFilePath differenceLog = "difference.log" -multicastLog :: FilePath +multicastLog :: RawFilePath multicastLog = "multicast.log" -exportLog :: FilePath +exportLog :: RawFilePath exportLog = "export.log" {- The pathname of the location log file for a given key. -} -locationLogFile :: GitConfig -> Key -> String -locationLogFile config key = branchHashDir config key keyFile key ++ ".log" +locationLogFile :: GitConfig -> Key -> RawFilePath +locationLogFile config key = toRawFilePath $ + branchHashDir config key keyFile key ++ ".log" {- The filename of the url log for a given key. -} -urlLogFile :: GitConfig -> Key -> FilePath -urlLogFile config key = branchHashDir config key keyFile key ++ urlLogExt +urlLogFile :: GitConfig -> Key -> RawFilePath +urlLogFile config key = toRawFilePath $ + branchHashDir config key keyFile key ++ decodeBS' urlLogExt {- Old versions stored the urls elsewhere. -} -oldurlLogs :: GitConfig -> Key -> [FilePath] -oldurlLogs config key = +oldurlLogs :: GitConfig -> Key -> [RawFilePath] +oldurlLogs config key = map toRawFilePath [ "remote/web" hdir serializeKey key ++ ".log" , "remote/web" hdir keyFile key ++ ".log" ] where hdir = branchHashDir config key -urlLogExt :: String +urlLogExt :: S.ByteString urlLogExt = ".log.web" {- Does not work on oldurllogs. -} -isUrlLog :: FilePath -> Bool -isUrlLog file = urlLogExt `isSuffixOf` file +isUrlLog :: RawFilePath -> Bool +isUrlLog file = urlLogExt `S.isSuffixOf` file {- The filename of the remote state log for a given key. -} -remoteStateLogFile :: GitConfig -> Key -> FilePath -remoteStateLogFile config key = branchHashDir config key - keyFile key ++ remoteStateLogExt +remoteStateLogFile :: GitConfig -> Key -> RawFilePath +remoteStateLogFile config key = + toRawFilePath (branchHashDir config key keyFile key) + <> remoteStateLogExt -remoteStateLogExt :: String +remoteStateLogExt :: S.ByteString remoteStateLogExt = ".log.rmt" -isRemoteStateLog :: FilePath -> Bool -isRemoteStateLog path = remoteStateLogExt `isSuffixOf` path +isRemoteStateLog :: RawFilePath -> Bool +isRemoteStateLog path = remoteStateLogExt `S.isSuffixOf` path {- The filename of the chunk log for a given key. -} -chunkLogFile :: GitConfig -> Key -> FilePath -chunkLogFile config key = branchHashDir config key keyFile key ++ chunkLogExt +chunkLogFile :: GitConfig -> Key -> RawFilePath +chunkLogFile config key = + toRawFilePath (branchHashDir config key keyFile key) + <> chunkLogExt -chunkLogExt :: String +chunkLogExt :: S.ByteString chunkLogExt = ".log.cnk" -isChunkLog :: FilePath -> Bool -isChunkLog path = chunkLogExt `isSuffixOf` path +isChunkLog :: RawFilePath -> Bool +isChunkLog path = chunkLogExt `S.isSuffixOf` path {- The filename of the metadata log for a given key. -} -metaDataLogFile :: GitConfig -> Key -> FilePath -metaDataLogFile config key = branchHashDir config key keyFile key ++ metaDataLogExt +metaDataLogFile :: GitConfig -> Key -> RawFilePath +metaDataLogFile config key = + toRawFilePath (branchHashDir config key keyFile key) + <> metaDataLogExt -metaDataLogExt :: String +metaDataLogExt :: S.ByteString metaDataLogExt = ".log.met" -isMetaDataLog :: FilePath -> Bool -isMetaDataLog path = metaDataLogExt `isSuffixOf` path +isMetaDataLog :: RawFilePath -> Bool +isMetaDataLog path = metaDataLogExt `S.isSuffixOf` path {- The filename of the remote metadata log for a given key. -} -remoteMetaDataLogFile :: GitConfig -> Key -> FilePath -remoteMetaDataLogFile config key = branchHashDir config key keyFile key ++ remoteMetaDataLogExt +remoteMetaDataLogFile :: GitConfig -> Key -> RawFilePath +remoteMetaDataLogFile config key = + toRawFilePath (branchHashDir config key keyFile key) + <> remoteMetaDataLogExt -remoteMetaDataLogExt :: String +remoteMetaDataLogExt :: S.ByteString remoteMetaDataLogExt = ".log.rmet" -isRemoteMetaDataLog :: FilePath -> Bool -isRemoteMetaDataLog path = remoteMetaDataLogExt `isSuffixOf` path +isRemoteMetaDataLog :: RawFilePath -> Bool +isRemoteMetaDataLog path = remoteMetaDataLogExt `S.isSuffixOf` path {- The filename of the remote content identifier log for a given key. -} -remoteContentIdentifierLogFile :: GitConfig -> Key -> FilePath -remoteContentIdentifierLogFile config key = branchHashDir config key keyFile key ++ remoteContentIdentifierExt +remoteContentIdentifierLogFile :: GitConfig -> Key -> RawFilePath +remoteContentIdentifierLogFile config key = + toRawFilePath (branchHashDir config key keyFile key) + <> remoteContentIdentifierExt -remoteContentIdentifierExt :: String +remoteContentIdentifierExt :: S.ByteString remoteContentIdentifierExt = ".log.cid" -isRemoteContentIdentifierLog :: FilePath -> Bool -isRemoteContentIdentifierLog path = remoteContentIdentifierExt `isSuffixOf` path +isRemoteContentIdentifierLog :: RawFilePath -> Bool +isRemoteContentIdentifierLog path = remoteContentIdentifierExt `S.isSuffixOf` path {- From an extension and a log filename, get the key that it's a log for. -} -extLogFileKey :: String -> FilePath -> Maybe Key +extLogFileKey :: S.ByteString -> RawFilePath -> Maybe Key extLogFileKey expectedext path - | ext == expectedext = fileKey base + | encodeBS' ext == expectedext = fileKey base | otherwise = Nothing where - file = takeFileName path + file = takeFileName (fromRawFilePath path) (base, ext) = splitAt (length file - extlen) file - extlen = length expectedext + extlen = S.length expectedext {- Converts a url log file into a key. - (Does not work on oldurlLogs.) -} -urlLogFileKey :: FilePath -> Maybe Key +urlLogFileKey :: RawFilePath -> Maybe Key urlLogFileKey = extLogFileKey urlLogExt {- Converts a pathname into a key if it's a location log. -} -locationLogFileKey :: FilePath -> Maybe Key +locationLogFileKey :: RawFilePath -> Maybe Key locationLogFileKey path -- Want only xx/yy/foo.log, not .log files in other places. - | length (splitDirectories path) /= 3 = Nothing + | length (splitDirectories (fromRawFilePath path)) /= 3 = Nothing | otherwise = extLogFileKey ".log" path diff --git a/Logs/Export.hs b/Logs/Export.hs index 6ab1c231c7..fd2ebfe504 100644 --- a/Logs/Export.hs +++ b/Logs/Export.hs @@ -37,6 +37,8 @@ import qualified Data.ByteString.Lazy as L import qualified Data.Attoparsec.ByteString.Lazy as A import qualified Data.Attoparsec.ByteString.Char8 as A8 import Data.ByteString.Builder +import Data.Either +import Data.Char -- This constuctor is not itself exported to other modules, to enforce -- consistent use of exportedTreeishes. @@ -176,8 +178,9 @@ logExportExcluded u a = do getExportExcluded :: UUID -> Annex [Git.Tree.TreeItem] getExportExcluded u = do logf <- fromRepo $ gitAnnexExportExcludeLog u - liftIO $ catchDefaultIO [] $ - (map parser . lines) - <$> readFile logf + liftIO $ catchDefaultIO [] $ parser <$> L.readFile logf where - parser = Git.Tree.lsTreeItemToTreeItem . Git.LsTree.parseLsTree + parser = map Git.Tree.lsTreeItemToTreeItem + . rights + . map Git.LsTree.parseLsTree + . L.split (fromIntegral $ ord '\n') diff --git a/Logs/Location.hs b/Logs/Location.hs index d70f364849..66532ae413 100644 --- a/Logs/Location.hs +++ b/Logs/Location.hs @@ -71,7 +71,7 @@ loggedLocationsHistorical = getLoggedLocations . historicalLogInfo loggedLocationsRef :: Ref -> Annex [UUID] loggedLocationsRef ref = map (toUUID . fromLogInfo) . getLog <$> catObject ref -getLoggedLocations :: (FilePath -> Annex [LogInfo]) -> Key -> Annex [UUID] +getLoggedLocations :: (RawFilePath -> Annex [LogInfo]) -> Key -> Annex [UUID] getLoggedLocations getter key = do config <- Annex.getGitConfig map (toUUID . fromLogInfo) <$> getter (locationLogFile config key) diff --git a/Logs/MetaData.hs b/Logs/MetaData.hs index c139e7aa3e..ea1462c61f 100644 --- a/Logs/MetaData.hs +++ b/Logs/MetaData.hs @@ -57,7 +57,7 @@ import qualified Data.Map as M getCurrentMetaData :: Key -> Annex MetaData getCurrentMetaData = getCurrentMetaData' metaDataLogFile -getCurrentMetaData' :: (GitConfig -> Key -> FilePath) -> Key -> Annex MetaData +getCurrentMetaData' :: (GitConfig -> Key -> RawFilePath) -> Key -> Annex MetaData getCurrentMetaData' getlogfile k = do config <- Annex.getGitConfig ls <- S.toAscList <$> readLog (getlogfile config k) @@ -95,7 +95,7 @@ getCurrentRemoteMetaData (RemoteStateHandle u) k = extractRemoteMetaData u <$> addMetaData :: Key -> MetaData -> Annex () addMetaData = addMetaData' metaDataLogFile -addMetaData' :: (GitConfig -> Key -> FilePath) -> Key -> MetaData -> Annex () +addMetaData' :: (GitConfig -> Key -> RawFilePath) -> Key -> MetaData -> Annex () addMetaData' getlogfile k metadata = addMetaDataClocked' getlogfile k metadata =<< liftIO currentVectorClock @@ -106,7 +106,7 @@ addMetaData' getlogfile k metadata = addMetaDataClocked :: Key -> MetaData -> VectorClock -> Annex () addMetaDataClocked = addMetaDataClocked' metaDataLogFile -addMetaDataClocked' :: (GitConfig -> Key -> FilePath) -> Key -> MetaData -> VectorClock -> Annex () +addMetaDataClocked' :: (GitConfig -> Key -> RawFilePath) -> Key -> MetaData -> VectorClock -> Annex () addMetaDataClocked' getlogfile k d@(MetaData m) c | d == emptyMetaData = noop | otherwise = do @@ -151,5 +151,5 @@ copyMetaData oldkey newkey const $ buildLog l return True -readLog :: FilePath -> Annex (Log MetaData) +readLog :: RawFilePath -> Annex (Log MetaData) readLog = parseLog <$$> Annex.Branch.get diff --git a/Logs/PreferredContent/Raw.hs b/Logs/PreferredContent/Raw.hs index fb9393ce6e..fb95b8c264 100644 --- a/Logs/PreferredContent/Raw.hs +++ b/Logs/PreferredContent/Raw.hs @@ -28,7 +28,7 @@ preferredContentSet = setLog preferredContentLog requiredContentSet :: UUID -> PreferredContentExpression -> Annex () requiredContentSet = setLog requiredContentLog -setLog :: FilePath -> UUID -> PreferredContentExpression -> Annex () +setLog :: RawFilePath -> UUID -> PreferredContentExpression -> Annex () setLog logfile uuid@(UUID _) val = do c <- liftIO currentVectorClock Annex.Branch.change logfile $ diff --git a/Logs/Presence.hs b/Logs/Presence.hs index 5987460857..486af7ee13 100644 --- a/Logs/Presence.hs +++ b/Logs/Presence.hs @@ -30,7 +30,7 @@ import Git.Types (RefDate) {- Adds a LogLine to the log, removing any LogLines that are obsoleted by - adding it. -} -addLog :: FilePath -> LogLine -> Annex () +addLog :: RawFilePath -> LogLine -> Annex () addLog file line = Annex.Branch.change file $ \b -> buildLog $ compactLog (line : parseLog b) @@ -38,14 +38,14 @@ addLog file line = Annex.Branch.change file $ \b -> - older timestamp, that LogLine is preserved, rather than updating the log - with a newer timestamp. -} -maybeAddLog :: FilePath -> LogLine -> Annex () +maybeAddLog :: RawFilePath -> LogLine -> Annex () maybeAddLog file line = Annex.Branch.maybeChange file $ \s -> do m <- insertNewStatus line $ logMap $ parseLog s return $ buildLog $ mapLog m {- Reads a log file. - Note that the LogLines returned may be in any order. -} -readLog :: FilePath -> Annex [LogLine] +readLog :: RawFilePath -> Annex [LogLine] readLog = parseLog <$$> Annex.Branch.get {- Generates a new LogLine with the current time. -} @@ -55,10 +55,10 @@ logNow s i = do return $ LogLine c s i {- Reads a log and returns only the info that is still in effect. -} -currentLogInfo :: FilePath -> Annex [LogInfo] +currentLogInfo :: RawFilePath -> Annex [LogInfo] currentLogInfo file = map info <$> currentLog file -currentLog :: FilePath -> Annex [LogLine] +currentLog :: RawFilePath -> Annex [LogLine] currentLog file = filterPresent <$> readLog file {- Reads a historical version of a log and returns the info that was in @@ -66,6 +66,6 @@ currentLog file = filterPresent <$> readLog file - - The date is formatted as shown in gitrevisions man page. -} -historicalLogInfo :: RefDate -> FilePath -> Annex [LogInfo] +historicalLogInfo :: RefDate -> RawFilePath -> Annex [LogInfo] historicalLogInfo refdate file = map info . filterPresent . parseLog <$> Annex.Branch.getHistorical refdate file diff --git a/Logs/SingleValue.hs b/Logs/SingleValue.hs index 6a4e283a14..8edbd50786 100644 --- a/Logs/SingleValue.hs +++ b/Logs/SingleValue.hs @@ -25,13 +25,13 @@ import Annex.VectorClock import qualified Data.Set as S -readLog :: (Ord v, SingleValueSerializable v) => FilePath -> Annex (Log v) +readLog :: (Ord v, SingleValueSerializable v) => RawFilePath -> Annex (Log v) readLog = parseLog <$$> Annex.Branch.get -getLog :: (Ord v, SingleValueSerializable v) => FilePath -> Annex (Maybe v) +getLog :: (Ord v, SingleValueSerializable v) => RawFilePath -> Annex (Maybe v) getLog = newestValue <$$> readLog -setLog :: (SingleValueSerializable v) => FilePath -> v -> Annex () +setLog :: (SingleValueSerializable v) => RawFilePath -> v -> Annex () setLog f v = do c <- liftIO currentVectorClock let ent = LogEntry c v diff --git a/Logs/Transfer.hs b/Logs/Transfer.hs index eec270a9ce..2dabe5cf34 100644 --- a/Logs/Transfer.hs +++ b/Logs/Transfer.hs @@ -31,7 +31,7 @@ describeTransfer :: Transfer -> TransferInfo -> String describeTransfer t info = unwords [ show $ transferDirection t , show $ transferUUID t - , actionItemDesc $ ActionItemAssociatedFile + , decodeBS' $ actionItemDesc $ ActionItemAssociatedFile (associatedFile info) (transferKey t) , show $ bytesComplete info @@ -245,7 +245,7 @@ writeTransferInfo info = unlines #endif -- comes last; arbitrary content , let AssociatedFile afile = associatedFile info - in fromMaybe "" afile + in maybe "" fromRawFilePath afile ] readTransferInfoFile :: Maybe PID -> FilePath -> IO (Maybe TransferInfo) @@ -263,7 +263,7 @@ readTransferInfo mpid s = TransferInfo <*> pure Nothing <*> pure Nothing <*> bytes - <*> pure (AssociatedFile (if null filename then Nothing else Just filename)) + <*> pure (AssociatedFile (if null filename then Nothing else Just (toRawFilePath filename))) <*> pure False where #ifdef mingw32_HOST_OS diff --git a/Logs/Transitions.hs b/Logs/Transitions.hs index 232a47aada..26a7eeb3eb 100644 --- a/Logs/Transitions.hs +++ b/Logs/Transitions.hs @@ -12,6 +12,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Logs.Transitions where import Annex.Common @@ -26,7 +28,7 @@ import qualified Data.ByteString.Lazy as L import qualified Data.Attoparsec.ByteString.Lazy as A import qualified Data.Attoparsec.ByteString.Char8 as A8 -transitionsLog :: FilePath +transitionsLog :: RawFilePath transitionsLog = "transitions.log" data Transition @@ -94,6 +96,6 @@ knownTransitionList = nub . rights . map transition . S.elems {- Typically ran with Annex.Branch.change, but we can't import Annex.Branch - here since it depends on this module. -} -recordTransitions :: (FilePath -> (L.ByteString -> Builder) -> Annex ()) -> Transitions -> Annex () +recordTransitions :: (RawFilePath -> (L.ByteString -> Builder) -> Annex ()) -> Transitions -> Annex () recordTransitions changer t = changer transitionsLog $ buildTransitions . S.union t . parseTransitionsStrictly "local" diff --git a/Logs/Web.hs b/Logs/Web.hs index b057a6580e..a59ea99205 100644 --- a/Logs/Web.hs +++ b/Logs/Web.hs @@ -93,7 +93,7 @@ knownUrls = do Annex.Branch.update Annex.Branch.commit =<< Annex.Branch.commitMessage Annex.Branch.withIndex $ do - top <- fromRepo Git.repoPath + top <- toRawFilePath <$> fromRepo Git.repoPath (l, cleanup) <- inRepo $ Git.LsFiles.stagedDetails [top] r <- mapM getkeyurls l void $ liftIO cleanup diff --git a/Messages.hs b/Messages.hs index a99aff6271..77ebdb9714 100644 --- a/Messages.hs +++ b/Messages.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Messages ( showStart, showStart', @@ -53,6 +55,7 @@ import System.Log.Formatter import System.Log.Handler (setFormatter) import System.Log.Handler.Simple import Control.Concurrent +import qualified Data.ByteString as S import Common import Types @@ -66,21 +69,21 @@ import Messages.Concurrent import qualified Messages.JSON as JSON import qualified Annex -showStart :: String -> FilePath -> Annex () +showStart :: String -> RawFilePath -> Annex () showStart command file = outputMessage json $ - command ++ " " ++ file ++ " " + encodeBS' command <> " " <> file <> " " where json = JSON.start command (Just file) Nothing showStart' :: String -> Maybe String -> Annex () -showStart' command mdesc = outputMessage json $ +showStart' command mdesc = outputMessage json $ encodeBS' $ command ++ (maybe "" (" " ++) mdesc) ++ " " where json = JSON.start command Nothing Nothing showStartKey :: String -> Key -> ActionItem -> Annex () showStartKey command key i = outputMessage json $ - command ++ " " ++ actionItemDesc i ++ " " + encodeBS' command <> " " <> actionItemDesc i <> " " where json = JSON.start command (actionItemWorkTreeFile i) (Just key) @@ -112,7 +115,7 @@ showEndMessage (StartNoMessage _) = const noop showEndMessage (CustomOutput _) = const noop showNote :: String -> Annex () -showNote s = outputMessage (JSON.note s) $ "(" ++ s ++ ") " +showNote s = outputMessage (JSON.note s) $ encodeBS' $ "(" ++ s ++ ") " showAction :: String -> Annex () showAction s = showNote $ s ++ "..." @@ -127,7 +130,7 @@ showSideAction m = Annex.getState Annex.output >>= go Annex.changeState $ \s -> s { Annex.output = st' } | sideActionBlock st == InBlock = return () | otherwise = p - p = outputMessage JSON.none $ "(" ++ m ++ "...)\n" + p = outputMessage JSON.none $ encodeBS' $ "(" ++ m ++ "...)\n" showStoringStateAction :: Annex () showStoringStateAction = showSideAction "recording state in git" @@ -171,7 +174,7 @@ showOutput = unlessM commandProgressDisabled $ outputMessage JSON.none "\n" showLongNote :: String -> Annex () -showLongNote s = outputMessage (JSON.note s) (formatLongNote s) +showLongNote s = outputMessage (JSON.note s) (encodeBS' (formatLongNote s)) formatLongNote :: String -> String formatLongNote s = '\n' : indent s ++ "\n" @@ -179,7 +182,8 @@ formatLongNote s = '\n' : indent s ++ "\n" -- Used by external special remote, displayed same as showLongNote -- to console, but json object containing the info is emitted immediately. showInfo :: String -> Annex () -showInfo s = outputMessage' outputJSON (JSON.info s) (formatLongNote s) +showInfo s = outputMessage' outputJSON (JSON.info s) $ + encodeBS' (formatLongNote s) showEndOk :: Annex () showEndOk = showEndResult True @@ -188,9 +192,9 @@ showEndFail :: Annex () showEndFail = showEndResult False showEndResult :: Bool -> Annex () -showEndResult ok = outputMessage (JSON.end ok) $ endResult ok ++ "\n" +showEndResult ok = outputMessage (JSON.end ok) $ endResult ok <> "\n" -endResult :: Bool -> String +endResult :: Bool -> S.ByteString endResult True = "ok" endResult False = "failed" @@ -238,11 +242,11 @@ showCustom command a = do r <- a outputMessage (JSON.end r) "" -showHeader :: String -> Annex () -showHeader h = outputMessage JSON.none $ (h ++ ": ") +showHeader :: S.ByteString -> Annex () +showHeader h = outputMessage JSON.none (h <> ": ") -showRaw :: String -> Annex () -showRaw s = outputMessage JSON.none (s ++ "\n") +showRaw :: S.ByteString -> Annex () +showRaw s = outputMessage JSON.none (s <> "\n") setupConsole :: IO () setupConsole = do diff --git a/Messages/Internal.hs b/Messages/Internal.hs index edfb38d5d7..79829ac151 100644 --- a/Messages/Internal.hs +++ b/Messages/Internal.hs @@ -14,17 +14,19 @@ import Messages.Concurrent import qualified Messages.JSON as JSON import Messages.JSON (JSONBuilder) +import qualified Data.ByteString as S + withMessageState :: (MessageState -> Annex a) -> Annex a withMessageState a = Annex.getState Annex.output >>= a -outputMessage :: JSONBuilder -> String -> Annex () +outputMessage :: JSONBuilder -> S.ByteString -> Annex () outputMessage = outputMessage' bufferJSON -outputMessage' :: (JSONBuilder -> MessageState -> Annex Bool) -> JSONBuilder -> String -> Annex () +outputMessage' :: (JSONBuilder -> MessageState -> Annex Bool) -> JSONBuilder -> S.ByteString -> Annex () outputMessage' jsonoutputter jsonbuilder msg = withMessageState $ \s -> case outputType s of NormalOutput - | concurrentOutputEnabled s -> concurrentMessage s False msg q - | otherwise -> liftIO $ flushed $ putStr msg + | concurrentOutputEnabled s -> concurrentMessage s False (decodeBS msg) q + | otherwise -> liftIO $ flushed $ S.putStr msg JSONOutput _ -> void $ jsonoutputter jsonbuilder s QuietOutput -> q diff --git a/Messages/JSON.hs b/Messages/JSON.hs index 976baf6e1d..7561c61261 100644 --- a/Messages/JSON.hs +++ b/Messages/JSON.hs @@ -43,6 +43,7 @@ import Key import Utility.Metered import Utility.Percentage import Utility.Aeson +import Utility.FileSystemEncoding -- A global lock to avoid concurrent threads emitting json at the same time. {-# NOINLINE emitLock #-} @@ -63,13 +64,13 @@ type JSONBuilder = Maybe (Object, Bool) -> Maybe (Object, Bool) none :: JSONBuilder none = id -start :: String -> Maybe FilePath -> Maybe Key -> JSONBuilder +start :: String -> Maybe RawFilePath -> Maybe Key -> JSONBuilder start command file key _ = Just (o, False) where Object o = toJSON' $ JSONActionItem { itemCommand = Just command , itemKey = key - , itemFile = file + , itemFile = fromRawFilePath <$> file , itemAdded = Nothing } diff --git a/Messages/Progress.hs b/Messages/Progress.hs index e9b0208363..113c3f5286 100644 --- a/Messages/Progress.hs +++ b/Messages/Progress.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} module Messages.Progress where diff --git a/P2P/Protocol.hs b/P2P/Protocol.hs index ac105f2d21..e9895d3de4 100644 --- a/P2P/Protocol.hs +++ b/P2P/Protocol.hs @@ -22,6 +22,7 @@ import Utility.AuthToken import Utility.Applicative import Utility.PartialPrelude import Utility.Metered +import Utility.FileSystemEncoding import Git.FilePath import Annex.ChangedRefs (ChangedRefs) @@ -166,17 +167,17 @@ instance Proto.Serializable Service where instance Proto.Serializable AssociatedFile where serialize (AssociatedFile Nothing) = "" serialize (AssociatedFile (Just af)) = - toInternalGitPath $ concatMap esc af + decodeBS' $ toInternalGitPath $ encodeBS' $ concatMap esc $ fromRawFilePath af where esc '%' = "%%" esc c | isSpace c = "%" | otherwise = [c] - deserialize s = case fromInternalGitPath $ deesc [] s of + deserialize s = case fromRawFilePath $ fromInternalGitPath $ toRawFilePath $ deesc [] s of [] -> Just (AssociatedFile Nothing) f - | isRelative f -> Just (AssociatedFile (Just f)) + | isRelative f -> Just $ AssociatedFile $ Just $ toRawFilePath f | otherwise -> Nothing where deesc b [] = reverse b diff --git a/Remote/Directory.hs b/Remote/Directory.hs index e5b397b3e9..0387474f9a 100644 --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -295,18 +295,18 @@ renameExportM d _k oldloc newloc = liftIO $ Just <$> go dest = exportPath d newloc exportPath :: FilePath -> ExportLocation -> FilePath -exportPath d loc = d fromExportLocation loc +exportPath d loc = d fromRawFilePath (fromExportLocation loc) {- Removes the ExportLocation's parent directory and its parents, so long as - they're empty, up to but not including the topdir. -} removeExportLocation :: FilePath -> ExportLocation -> IO () removeExportLocation topdir loc = - go (Just $ takeDirectory $ fromExportLocation loc) (Right ()) + go (Just $ takeDirectory $ fromRawFilePath $ fromExportLocation loc) (Right ()) where go _ (Left _e) = return () go Nothing _ = return () go (Just loc') _ = go (upFrom loc') - =<< tryIO (removeDirectory $ exportPath topdir (mkExportLocation loc')) + =<< tryIO (removeDirectory $ exportPath topdir (mkExportLocation (toRawFilePath loc'))) listImportableContentsM :: FilePath -> Annex (Maybe (ImportableContents (ContentIdentifier, ByteSize))) listImportableContentsM dir = catchMaybeIO $ liftIO $ do @@ -319,7 +319,7 @@ listImportableContentsM dir = catchMaybeIO $ liftIO $ do mkContentIdentifier f st >>= \case Nothing -> return Nothing Just cid -> do - relf <- relPathDirToFile dir f + relf <- toRawFilePath <$> relPathDirToFile dir f sz <- getFileSize' f st return $ Just (mkImportLocation relf, (cid, sz)) diff --git a/Remote/Git.hs b/Remote/Git.hs index 9e12dcb52d..7aebe8c24f 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -549,7 +549,7 @@ copyFromRemote'' repo forcersync r st@(State connpool _ _ _) key file dest meter u <- getUUID let AssociatedFile afile = file let fields = (Fields.remoteUUID, fromUUID u) - : maybe [] (\f -> [(Fields.associatedFile, f)]) afile + : maybe [] (\f -> [(Fields.associatedFile, fromRawFilePath f)]) afile Just (cmd, params) <- Ssh.git_annex_shell ConsumeStdin repo "transferinfo" [Param $ serializeKey key] fields diff --git a/Remote/Helper/Ssh.hs b/Remote/Helper/Ssh.hs index cc17220f28..ae4a680d9a 100644 --- a/Remote/Helper/Ssh.hs +++ b/Remote/Helper/Ssh.hs @@ -137,7 +137,7 @@ rsyncParamsRemote unlocked r direction key file (AssociatedFile afile) = do -- Send direct field for unlocked content, for backwards -- compatability. : (Fields.direct, if unlocked then "1" else "") - : maybe [] (\f -> [(Fields.associatedFile, f)]) afile + : maybe [] (\f -> [(Fields.associatedFile, fromRawFilePath f)]) afile repo <- getRepo r Just (shellcmd, shellparams) <- git_annex_shell ConsumeStdin repo (if direction == Download then "sendkey" else "recvkey") diff --git a/Remote/List.hs b/Remote/List.hs index 3e7ca9fa73..49e2710148 100644 --- a/Remote/List.hs +++ b/Remote/List.hs @@ -24,6 +24,7 @@ import qualified Git import qualified Git.Config import qualified Remote.Git +{- import qualified Remote.GCrypt import qualified Remote.P2P #ifdef WITH_S3 @@ -44,10 +45,12 @@ import qualified Remote.Ddar import qualified Remote.GitLFS import qualified Remote.Hook import qualified Remote.External +-} remoteTypes :: [RemoteType] remoteTypes = map adjustExportImportRemoteType [ Remote.Git.remote +{- , Remote.GCrypt.remote , Remote.P2P.remote #ifdef WITH_S3 @@ -68,6 +71,7 @@ remoteTypes = map adjustExportImportRemoteType , Remote.GitLFS.remote , Remote.Hook.remote , Remote.External.remote +-} ] {- Builds a list of all available Remotes. @@ -129,7 +133,9 @@ updateRemote remote = do gitSyncableRemote :: Remote -> Bool gitSyncableRemote r = remotetype r `elem` [ Remote.Git.remote +{- , Remote.GCrypt.remote , Remote.P2P.remote , Remote.GitLFS.remote +-} ] diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs index af26fbc757..566f95bab6 100644 --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -268,22 +268,22 @@ storeExportM :: RsyncOpts -> FilePath -> Key -> ExportLocation -> MeterUpdate -> storeExportM o src _k loc meterupdate = storeGeneric o meterupdate basedest populatedest where - basedest = fromExportLocation loc + basedest = fromRawFilePath (fromExportLocation loc) populatedest = liftIO . createLinkOrCopy src retrieveExportM :: RsyncOpts -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool retrieveExportM o _k loc dest p = rsyncRetrieve o [rsyncurl] dest (Just p) where - rsyncurl = mkRsyncUrl o (fromExportLocation loc) + rsyncurl = mkRsyncUrl o (fromRawFilePath (fromExportLocation loc)) checkPresentExportM :: RsyncOpts -> Key -> ExportLocation -> Annex Bool checkPresentExportM o _k loc = checkPresentGeneric o [rsyncurl] where - rsyncurl = mkRsyncUrl o (fromExportLocation loc) + rsyncurl = mkRsyncUrl o (fromRawFilePath (fromExportLocation loc)) removeExportM :: RsyncOpts -> Key -> ExportLocation -> Annex Bool removeExportM o _k loc = - removeGeneric o (includes (fromExportLocation loc)) + removeGeneric o $ includes $ fromRawFilePath $ fromExportLocation loc where includes f = f : case upFrom f of Nothing -> [] @@ -292,7 +292,7 @@ removeExportM o _k loc = removeExportDirectoryM :: RsyncOpts -> ExportDirectory -> Annex Bool removeExportDirectoryM o ed = removeGeneric o (allbelow d : includes d) where - d = fromExportDirectory ed + d = fromRawFilePath $ fromExportDirectory ed allbelow f = f "***" includes f = f : case upFrom f of Nothing -> [] diff --git a/Test.hs b/Test.hs index 131c985882..bbe0f37431 100644 --- a/Test.hs +++ b/Test.hs @@ -204,12 +204,17 @@ properties = localOption (QuickCheckTests 1000) $ testGroup "QuickCheck" - of git-annex. They are always run before the unitTests. -} initTests :: TestTree initTests = testGroup "Init Tests" + [] +{- [ testCase "init" test_init , testCase "add" test_add ] +-} unitTests :: String -> TestTree unitTests note = testGroup ("Unit Tests " ++ note) + [] +{- [ testCase "add dup" test_add_dup , testCase "add extras" test_add_extras , testCase "export_import" test_export_import @@ -1776,3 +1781,5 @@ test_export_import_subdir = intmpclonerepo $ do -- Make sure that import did not import the file to the top -- of the repo. checkdoesnotexist annexedfile + +-} diff --git a/Test/Framework.hs b/Test/Framework.hs index 93e9e3ad5b..ed1aa67d21 100644 --- a/Test/Framework.hs +++ b/Test/Framework.hs @@ -254,7 +254,7 @@ finalCleanup = whenM (doesDirectoryExist tmpdir) $ do checklink :: FilePath -> Assertion checklink f = ifM (annexeval Config.crippledFileSystem) - ( (isJust <$> annexeval (Annex.Link.getAnnexLinkTarget f)) + ( (isJust <$> annexeval (Annex.Link.getAnnexLinkTarget (toRawFilePath f))) @? f ++ " is not a (crippled) symlink" , do s <- getSymbolicLinkStatus f @@ -312,7 +312,7 @@ checkdangling f = ifM (annexeval Config.crippledFileSystem) checklocationlog :: FilePath -> Bool -> Assertion checklocationlog f expected = do thisuuid <- annexeval Annex.UUID.getUUID - r <- annexeval $ Annex.WorkTree.lookupFile f + r <- annexeval $ Annex.WorkTree.lookupFile (toRawFilePath f) case r of Just k -> do uuids <- annexeval $ Remote.keyLocations k @@ -323,11 +323,11 @@ checklocationlog f expected = do checkbackend :: FilePath -> Types.Backend -> Assertion checkbackend file expected = do b <- annexeval $ maybe (return Nothing) (Backend.getBackend file) - =<< Annex.WorkTree.lookupFile file + =<< Annex.WorkTree.lookupFile (toRawFilePath file) assertEqual ("backend for " ++ file) (Just expected) b checkispointerfile :: FilePath -> Assertion -checkispointerfile f = unlessM (isJust <$> Annex.Link.isPointerFile f) $ +checkispointerfile f = unlessM (isJust <$> Annex.Link.isPointerFile (toRawFilePath f)) $ assertFailure $ f ++ " is not a pointer file" inlocationlog :: FilePath -> Assertion diff --git a/Types/ActionItem.hs b/Types/ActionItem.hs index 1396c93002..fcb8c64345 100644 --- a/Types/ActionItem.hs +++ b/Types/ActionItem.hs @@ -12,15 +12,17 @@ module Types.ActionItem where import Key import Types.Transfer import Git.FilePath +import Utility.FileSystemEncoding import Data.Maybe +import qualified Data.ByteString as S data ActionItem = ActionItemAssociatedFile AssociatedFile Key | ActionItemKey Key | ActionItemBranchFilePath BranchFilePath Key | ActionItemFailedTransfer Transfer TransferInfo - | ActionItemWorkTreeFile FilePath + | ActionItemWorkTreeFile RawFilePath | ActionItemOther (Maybe String) -- Use to avoid more than one thread concurrently processing the -- same Key. @@ -39,10 +41,10 @@ instance MkActionItem (AssociatedFile, Key) where instance MkActionItem (Key, AssociatedFile) where mkActionItem = uncurry $ flip ActionItemAssociatedFile -instance MkActionItem (Key, FilePath) where +instance MkActionItem (Key, RawFilePath) where mkActionItem (key, file) = ActionItemAssociatedFile (AssociatedFile (Just file)) key -instance MkActionItem (FilePath, Key) where +instance MkActionItem (RawFilePath, Key) where mkActionItem (file, key) = mkActionItem (key, file) instance MkActionItem Key where @@ -54,16 +56,16 @@ instance MkActionItem (BranchFilePath, Key) where instance MkActionItem (Transfer, TransferInfo) where mkActionItem = uncurry ActionItemFailedTransfer -actionItemDesc :: ActionItem -> String +actionItemDesc :: ActionItem -> S.ByteString actionItemDesc (ActionItemAssociatedFile (AssociatedFile (Just f)) _) = f actionItemDesc (ActionItemAssociatedFile (AssociatedFile Nothing) k) = - serializeKey k -actionItemDesc (ActionItemKey k) = serializeKey k + serializeKey' k +actionItemDesc (ActionItemKey k) = serializeKey' k actionItemDesc (ActionItemBranchFilePath bfp _) = descBranchFilePath bfp actionItemDesc (ActionItemFailedTransfer t i) = actionItemDesc $ ActionItemAssociatedFile (associatedFile i) (transferKey t) actionItemDesc (ActionItemWorkTreeFile f) = f -actionItemDesc (ActionItemOther s) = fromMaybe "" s +actionItemDesc (ActionItemOther s) = encodeBS' (fromMaybe "" s) actionItemDesc (OnlyActionOn _ ai) = actionItemDesc ai actionItemKey :: ActionItem -> Maybe Key @@ -75,7 +77,7 @@ actionItemKey (ActionItemWorkTreeFile _) = Nothing actionItemKey (ActionItemOther _) = Nothing actionItemKey (OnlyActionOn _ ai) = actionItemKey ai -actionItemWorkTreeFile :: ActionItem -> Maybe FilePath +actionItemWorkTreeFile :: ActionItem -> Maybe RawFilePath actionItemWorkTreeFile (ActionItemAssociatedFile (AssociatedFile af) _) = af actionItemWorkTreeFile (ActionItemWorkTreeFile f) = Just f actionItemWorkTreeFile (OnlyActionOn _ ai) = actionItemWorkTreeFile ai diff --git a/Types/Key.hs b/Types/Key.hs index e83dd57f41..9992fdcabb 100644 --- a/Types/Key.hs +++ b/Types/Key.hs @@ -36,6 +36,7 @@ import Data.ByteString.Builder import Data.ByteString.Builder.Extra import qualified Data.Attoparsec.ByteString as A import qualified Data.Attoparsec.ByteString.Char8 as A8 +import Utility.FileSystemEncoding import Data.List import System.Posix.Types import Foreign.C.Types @@ -200,7 +201,7 @@ splitKeyNameExtension' :: S.ByteString -> (S.ByteString, S.ByteString) splitKeyNameExtension' keyname = S8.span (/= '.') keyname {- A filename may be associated with a Key. -} -newtype AssociatedFile = AssociatedFile (Maybe FilePath) +newtype AssociatedFile = AssociatedFile (Maybe RawFilePath) deriving (Show, Eq, Ord) {- There are several different varieties of keys. -} diff --git a/Types/Transfer.hs b/Types/Transfer.hs index e05b57efbe..fed03cb0a3 100644 --- a/Types/Transfer.hs +++ b/Types/Transfer.hs @@ -15,6 +15,7 @@ import Types.Key import Utility.PID import Utility.QuickCheck import Utility.Url +import Utility.FileSystemEncoding import Data.Time.Clock.POSIX import Control.Concurrent @@ -71,8 +72,7 @@ instance Arbitrary TransferInfo where <*> pure Nothing -- cannot generate a ThreadID <*> pure Nothing -- remote not needed <*> arbitrary - -- associated file cannot be empty (but can be Nothing) - <*> (AssociatedFile <$> arbitrary `suchThat` (/= Just "")) + <*> arbitrary <*> arbitrary class Observable a where @@ -101,7 +101,7 @@ class Transferrable t where descTransfrerrable :: t -> Maybe String instance Transferrable AssociatedFile where - descTransfrerrable (AssociatedFile af) = af + descTransfrerrable (AssociatedFile af) = fromRawFilePath <$> af instance Transferrable URLString where descTransfrerrable = Just diff --git a/Upgrade.hs b/Upgrade.hs index 1cde059521..fed76d838e 100644 --- a/Upgrade.hs +++ b/Upgrade.hs @@ -15,6 +15,7 @@ import qualified Git import Annex.Version import Types.RepoVersion #ifndef mingw32_HOST_OS +{- import qualified Upgrade.V0 import qualified Upgrade.V1 #endif @@ -23,6 +24,7 @@ import qualified Upgrade.V3 import qualified Upgrade.V4 import qualified Upgrade.V5 import qualified Upgrade.V6 +-} import qualified Data.Map as M @@ -72,6 +74,7 @@ upgrade automatic destversion = do ) go _ = return True +{- #ifndef mingw32_HOST_OS up (RepoVersion 0) = Upgrade.V0.upgrade up (RepoVersion 1) = Upgrade.V1.upgrade @@ -84,5 +87,6 @@ upgrade automatic destversion = do up (RepoVersion 4) = Upgrade.V4.upgrade automatic up (RepoVersion 5) = Upgrade.V5.upgrade automatic up (RepoVersion 6) = Upgrade.V6.upgrade automatic +-} up _ = return True diff --git a/Utility/Path.hs b/Utility/Path.hs index 26d66066ad..3f34156e88 100644 --- a/Utility/Path.hs +++ b/Utility/Path.hs @@ -43,6 +43,7 @@ import Utility.Monad import Utility.UserInfo import Utility.Directory import Utility.Split +import Utility.FileSystemEncoding {- Simplifies a path, removing any "." component, collapsing "dir/..", - and removing the trailing path separator. @@ -200,20 +201,21 @@ prop_relPathDirToFile_regressionTest = same_dir_shortcurcuits_at_difference - we stop preserving ordering at that point. Presumably a user passing - that many paths in doesn't care too much about order of the later ones. -} -segmentPaths :: [FilePath] -> [FilePath] -> [[FilePath]] +segmentPaths :: [RawFilePath] -> [RawFilePath] -> [[RawFilePath]] segmentPaths [] new = [new] segmentPaths [_] new = [new] -- optimisation segmentPaths (l:ls) new = found : segmentPaths ls rest where (found, rest) = if length ls < 100 - then partition (l `dirContains`) new - else break (\p -> not (l `dirContains` p)) new + then partition inl new + else break (not . inl) new + inl f = fromRawFilePath l `dirContains` fromRawFilePath f {- This assumes that it's cheaper to call segmentPaths on the result, - than it would be to run the action separately with each path. In - the case of git file list commands, that assumption tends to hold. -} -runSegmentPaths :: ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [[FilePath]] +runSegmentPaths :: ([RawFilePath] -> IO [RawFilePath]) -> [RawFilePath] -> IO [[RawFilePath]] runSegmentPaths a paths = segmentPaths paths <$> a paths {- Converts paths in the home directory to use ~/ -} diff --git a/git-annex.cabal b/git-annex.cabal index 83da5bcb74..1b695b10ae 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -407,16 +407,16 @@ Executable git-annex if flag(S3) Build-Depends: aws (>= 0.20) CPP-Options: -DWITH_S3 - Other-Modules: Remote.S3 + Other-Modules-temp-disabled: Remote.S3 if flag(WebDAV) Build-Depends: DAV (>= 1.0) CPP-Options: -DWITH_WEBDAV - Other-Modules: + Other-Modules-temp-disabled: Remote.WebDAV Remote.WebDAV.DavLocation if flag(S3) || flag(WebDAV) - Other-Modules: + Other-Modules-temp-disabled: Remote.Helper.Http if flag(Assistant) && ! os(solaris) && ! os(gnu) diff --git a/git-annex.hs b/git-annex.hs index 4992f4c76e..30c12995a1 100644 --- a/git-annex.hs +++ b/git-annex.hs @@ -12,7 +12,7 @@ import System.FilePath import Network.Socket (withSocketsDo) import qualified CmdLine.GitAnnex -import qualified CmdLine.GitAnnexShell +--import qualified CmdLine.GitAnnexShell import qualified CmdLine.GitRemoteTorAnnex import qualified Test import qualified Benchmark @@ -33,7 +33,7 @@ main = withSocketsDo $ do run ps =<< getProgName where run ps n = case takeFileName n of - "git-annex-shell" -> CmdLine.GitAnnexShell.run ps + "git-annex-shell" -> error "STUBBED OUT FIXME" -- CmdLine.GitAnnexShell.run ps "git-remote-tor-annex" -> CmdLine.GitRemoteTorAnnex.run ps _ -> CmdLine.GitAnnex.run Test.optParser Test.runner Benchmark.mkGenerator ps diff --git a/stack.yaml b/stack.yaml index d97bf2f263..ca0494c353 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,12 +1,12 @@ flags: git-annex: production: true - assistant: true + assistant: false pairing: true s3: true - webdav: true + webdav: false torrentparser: true - webapp: true + webapp: false magicmime: false dbus: false debuglocks: false From d830386ab20bbca97979641d6f2c788d8a13bc67 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 27 Nov 2019 14:09:11 -0400 Subject: [PATCH 03/42] update based on profiling While L.toStrict copies, profiling showed it was only around 0.3% of git-annex find runtime. Does not seem worth optimising that, which would probably involve either a major refactoring, or a use of UnsafeInterleaveIO. Also, it seems to me that the latter would need to read chunks, and preappend the leftover part to the next chunk. But a strict ByteString append itself is a copy, so I'm not convinced that would be faster than L.toStrict. --- Git/Command.hs | 4 +--- doc/todo/optimize_by_converting_String_to_ByteString.mdwn | 7 +++---- 2 files changed, 4 insertions(+), 7 deletions(-) diff --git a/Git/Command.hs b/Git/Command.hs index 1db11ab9e4..c2477529cf 100644 --- a/Git/Command.hs +++ b/Git/Command.hs @@ -101,10 +101,8 @@ pipeNullSplit params repo = do (s, cleanup) <- pipeReadLazy params repo return (filter (not . L.null) $ L.split 0 s, cleanup) -{- Reads lazily, but converts each part to a strict ByteString for +{- Reads lazily, but copies each part to a strict ByteString for - convenience. - - - - FIXME the L.toStrict makes a copy, more expensive than ideal. -} pipeNullSplit' :: [CommandParam] -> Repo -> IO ([S.ByteString], IO Bool) pipeNullSplit' params repo = do diff --git a/doc/todo/optimize_by_converting_String_to_ByteString.mdwn b/doc/todo/optimize_by_converting_String_to_ByteString.mdwn index 13d29603fc..203da76b91 100644 --- a/doc/todo/optimize_by_converting_String_to_ByteString.mdwn +++ b/doc/todo/optimize_by_converting_String_to_ByteString.mdwn @@ -14,8 +14,9 @@ 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. - It would be good to instrument them with Debug.Trace and find out which - are the hot ones that get called, and focus on those. + 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. * System.FilePath is not available for RawFilePath, and many of the conversions are to get a FilePath in order to use that library. @@ -29,6 +30,4 @@ the `bs` branch has quite a lot of things still needing work, including: windows, so a compatability shim will be needed. (I can't seem to find any library that provides one.) -* Eliminate some Data.ByteString.Lazy.toStrict, which is a slow copy. - * Use ByteString for parsing git config to speed up startup. From 37d0f73e66588dd77b5c07b69a1d6aa3ce71eb05 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 27 Nov 2019 16:38:18 -0400 Subject: [PATCH 04/42] reword comment --- Utility/Split.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Utility/Split.hs b/Utility/Split.hs index f53f964f1d..028218e006 100644 --- a/Utility/Split.hs +++ b/Utility/Split.hs @@ -34,6 +34,6 @@ splitc c s = case break (== c) s of replace :: Eq a => [a] -> [a] -> [a] -> [a] replace old new = intercalate new . split old --- | Only traverses the list once while dropping the last n characters. +-- | Only traverses the list once while dropping the last n items. dropFromEnd :: Int -> [a] -> [a] dropFromEnd n l = zipWith const l (drop n l) From d7833def6620f2cdc3971eab38f3620e050404fb Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 27 Nov 2019 16:54:11 -0400 Subject: [PATCH 05/42] use ByteString for git config The parser and looking up config keys in the map should both be faster due to using ByteString. I had hoped this would speed up startup time, but any improvement to that was too small to measure. Seems worth keeping though. Note that the parser breaks up the ByteString, but a config map ends up pointing to the config as read, which is retained in memory until every value from it is no longer used. This can change memory usage patterns marginally, but won't affect git-annex. --- Annex/Environment.hs | 2 + Annex/Fixup.hs | 5 +- Annex/Init.hs | 1 + Annex/UUID.hs | 4 +- Annex/Version.hs | 1 + CmdLine/GitAnnex.hs | 4 +- CmdLine/GitAnnex/Options.hs | 2 +- Config.hs | 23 ++++-- Config/Smudge.hs | 2 + Git/AutoCorrect.hs | 4 +- Git/Branch.hs | 5 +- Git/Config.hs | 76 ++++++++++++------- Git/ConfigTypes.hs | 9 ++- Git/Construct.hs | 5 +- Git/GCrypt.hs | 20 +++-- Git/Remote.hs | 23 +++--- Git/Types.hs | 4 +- Remote.hs | 8 +- Remote/GCrypt.hs | 18 +++-- Remote/Git.hs | 8 +- Remote/GitLFS.hs | 6 +- Remote/Helper/Special.hs | 10 ++- Test/Framework.hs | 4 +- Types/Difference.hs | 11 ++- Types/GitConfig.hs | 20 +++-- Upgrade/V5/Direct.hs | 4 +- ...ze_by_converting_String_to_ByteString.mdwn | 2 - 27 files changed, 176 insertions(+), 105 deletions(-) diff --git a/Annex/Environment.hs b/Annex/Environment.hs index ea9eda0339..0e101d2e76 100644 --- a/Annex/Environment.hs +++ b/Annex/Environment.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Annex.Environment where import Annex.Common diff --git a/Annex/Fixup.hs b/Annex/Fixup.hs index d167086b09..4585433c72 100644 --- a/Annex/Fixup.hs +++ b/Annex/Fixup.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Annex.Fixup where import Git.Types @@ -17,6 +19,7 @@ import Utility.SafeCommand import Utility.Directory import Utility.Exception import Utility.Monad +import Utility.FileSystemEncoding import Utility.PartialPrelude import System.IO @@ -53,7 +56,7 @@ fixupDirect r@(Repo { location = l@(Local { gitdir = d, worktree = Nothing }) }) { location = l { worktree = Just (parentDir d) } , gitGlobalOpts = gitGlobalOpts r ++ [ Param "-c" - , Param $ coreBare ++ "=" ++ boolConfig False + , Param $ decodeBS' coreBare ++ "=" ++ boolConfig False ] } fixupDirect r = r diff --git a/Annex/Init.hs b/Annex/Init.hs index a762bf690c..38847c4e0d 100644 --- a/Annex/Init.hs +++ b/Annex/Init.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} module Annex.Init ( ensureInitialized, diff --git a/Annex/UUID.hs b/Annex/UUID.hs index 98d0c5219b..23593a46f7 100644 --- a/Annex/UUID.hs +++ b/Annex/UUID.hs @@ -11,6 +11,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Annex.UUID ( getUUID, getRepoUUID, @@ -112,7 +114,7 @@ storeUUIDIn configfield = setConfig configfield . fromUUID {- Only sets the configkey in the Repo; does not change .git/config -} setUUID :: Git.Repo -> UUID -> IO Git.Repo setUUID r u = do - let s = show configkey ++ "=" ++ fromUUID u + let s = encodeBS' $ show configkey ++ "=" ++ fromUUID u Git.Config.store s r -- Dummy uuid for the whole web. Do not alter. diff --git a/Annex/Version.hs b/Annex/Version.hs index 6e0fd4f530..e7cab2a3ac 100644 --- a/Annex/Version.hs +++ b/Annex/Version.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} module Annex.Version where diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs index bfec6f6271..deb723cf1d 100644 --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -124,8 +124,8 @@ import qualified Command.WebApp import qualified Command.Test import qualified Command.FuzzTest import qualified Command.TestRemote -import qualified Command.Benchmark -} +import qualified Command.Benchmark cmds :: Parser TestOptions -> TestRunner -> MkBenchmarkGenerator -> [Command] cmds testoptparser testrunner mkbenchmarkgenerator = @@ -235,9 +235,9 @@ cmds testoptparser testrunner mkbenchmarkgenerator = , Command.Test.cmd testoptparser testrunner , Command.FuzzTest.cmd , Command.TestRemote.cmd +-} , Command.Benchmark.cmd $ mkbenchmarkgenerator $ cmds testoptparser testrunner (\_ _ -> return noop) --} ] run :: Parser TestOptions -> TestRunner -> MkBenchmarkGenerator -> [String] -> IO () diff --git a/CmdLine/GitAnnex/Options.hs b/CmdLine/GitAnnex/Options.hs index 117a876edb..fc25b3c817 100644 --- a/CmdLine/GitAnnex/Options.hs +++ b/CmdLine/GitAnnex/Options.hs @@ -92,7 +92,7 @@ gitAnnexGlobalOptions = commonGlobalOptions ++ where setnumcopies n = Annex.changeState $ \s -> s { Annex.forcenumcopies = Just $ NumCopies n } setuseragent v = Annex.changeState $ \s -> s { Annex.useragent = Just v } - setgitconfig v = Annex.adjustGitRepo $ \r -> Git.Config.store v $ + setgitconfig v = Annex.adjustGitRepo $ \r -> Git.Config.store (encodeBS' v) $ r { gitGlobalOpts = gitGlobalOpts r ++ [Param "-c", Param v] } setdesktopnotify v = Annex.changeState $ \s -> s { Annex.desktopnotify = Annex.desktopnotify s <> v } diff --git a/Config.hs b/Config.hs index cbd82e50f7..94a22f720a 100644 --- a/Config.hs +++ b/Config.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} module Config where @@ -22,25 +23,31 @@ import qualified Types.Remote as Remote import qualified Annex.SpecialRemote.Config as SpecialRemote import qualified Data.Map as M +import qualified Data.ByteString as S -type UnqualifiedConfigKey = String -data ConfigKey = ConfigKey String +type UnqualifiedConfigKey = S.ByteString + +newtype ConfigKey = ConfigKey S.ByteString instance Show ConfigKey where - show (ConfigKey s) = s + show (ConfigKey s) = decodeBS' s {- Looks up a setting in git config. This is not as efficient as using the - GitConfig type. -} -getConfig :: ConfigKey -> String -> Annex String +getConfig :: ConfigKey -> S.ByteString -> Annex S.ByteString getConfig (ConfigKey key) d = fromRepo $ Git.Config.get key d -getConfigMaybe :: ConfigKey -> Annex (Maybe String) +getConfigMaybe :: ConfigKey -> Annex (Maybe S.ByteString) getConfigMaybe (ConfigKey key) = fromRepo $ Git.Config.getMaybe key {- Changes a git config setting in both internal state and .git/config -} setConfig :: ConfigKey -> String -> Annex () setConfig (ConfigKey key) value = do - inRepo $ Git.Command.run [Param "config", Param key, Param value] + inRepo $ Git.Command.run + [ Param "config" + , Param (decodeBS' key) + , Param value + ] reloadConfig reloadConfig :: Annex () @@ -68,11 +75,11 @@ instance RemoteNameable Remote.RemoteConfig where {- A per-remote config setting in git config. -} remoteConfig :: RemoteNameable r => r -> UnqualifiedConfigKey -> ConfigKey remoteConfig r key = ConfigKey $ - "remote." ++ getRemoteName r ++ ".annex-" ++ key + "remote." <> encodeBS' (getRemoteName r) <> ".annex-" <> key {- A global annex setting in git config. -} annexConfig :: UnqualifiedConfigKey -> ConfigKey -annexConfig key = ConfigKey $ "annex." ++ key +annexConfig key = ConfigKey ("annex." <> key) {- Calculates cost for a remote. Either the specific default, or as configured - by remote..annex-cost, or if remote..annex-cost-command diff --git a/Config/Smudge.hs b/Config/Smudge.hs index b81db28139..08568f57c9 100644 --- a/Config/Smudge.hs +++ b/Config/Smudge.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Config.Smudge where import Annex.Common diff --git a/Git/AutoCorrect.hs b/Git/AutoCorrect.hs index c7b0fd2995..ac45a4b367 100644 --- a/Git/AutoCorrect.hs +++ b/Git/AutoCorrect.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Git.AutoCorrect where import Common @@ -44,7 +46,7 @@ fuzzymatches input showchoice choices = fst $ unzip $ -} prepare :: String -> (c -> String) -> [c] -> Maybe Repo -> IO () prepare input showmatch matches r = - case readish . Git.Config.get "help.autocorrect" "0" =<< r of + case readish . decodeBS' . Git.Config.get "help.autocorrect" "0" =<< r of Just n | n == 0 -> list | n < 0 -> warn Nothing diff --git a/Git/Branch.hs b/Git/Branch.hs index ffd9a189d2..21103b65f6 100644 --- a/Git/Branch.hs +++ b/Git/Branch.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} module Git.Branch where @@ -135,8 +136,8 @@ applyCommitMode commitmode ps applyCommitModeForCommitTree :: CommitMode -> [CommandParam] -> Repo -> [CommandParam] applyCommitModeForCommitTree commitmode ps r | commitmode == ManualCommit = - case (Git.Config.getMaybe "commit.gpgsign" r) of - Just s | Git.Config.isTrue s == Just True -> + case Git.Config.getMaybe "commit.gpgsign" r of + Just s | Git.Config.isTrue' s == Just True -> Param "-S":ps _ -> ps' | otherwise = ps' diff --git a/Git/Config.hs b/Git/Config.hs index 9ebd4bd0f5..215c7b40c8 100644 --- a/Git/Config.hs +++ b/Git/Config.hs @@ -1,13 +1,17 @@ {- git repository configuration handling - - - Copyright 2010-2012 Joey Hess + - Copyright 2010-2019 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Git.Config where import qualified Data.Map as M +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 import Data.Char import Common @@ -18,15 +22,15 @@ import qualified Git.Construct import Utility.UserInfo {- Returns a single git config setting, or a default value if not set. -} -get :: String -> String -> Repo -> String +get :: S.ByteString -> S.ByteString -> Repo -> S.ByteString get key defaultValue repo = M.findWithDefault defaultValue key (config repo) {- Returns a list with each line of a multiline config setting. -} -getList :: String -> Repo -> [String] +getList :: S.ByteString -> Repo -> [S.ByteString] getList key repo = M.findWithDefault [] key (fullconfig repo) {- Returns a single git config setting, if set. -} -getMaybe :: String -> Repo -> Maybe String +getMaybe :: S.ByteString -> Repo -> Maybe S.ByteString getMaybe key repo = M.lookup key (config repo) {- Runs git config and populates a repo with its config. @@ -79,14 +83,14 @@ global = do {- Reads git config from a handle and populates a repo with it. -} hRead :: Repo -> Handle -> IO Repo hRead repo h = do - val <- hGetContentsStrict h + val <- S.hGetContents h store val repo {- Stores a git config into a Repo, returning the new version of the Repo. - The git config may be multiple lines, or a single line. - Config settings can be updated incrementally. -} -store :: String -> Repo -> IO Repo +store :: S.ByteString -> Repo -> IO Repo store s repo = do let c = parse s updateLocation $ repo @@ -96,7 +100,7 @@ store s repo = do {- Stores a single config setting in a Repo, returning the new version of - the Repo. Config settings can be updated incrementally. -} -store' :: String -> String -> Repo -> Repo +store' :: S.ByteString -> S.ByteString -> Repo -> Repo store' k v repo = repo { config = M.singleton k v `M.union` config repo , fullconfig = M.unionWith (++) (M.singleton k [v]) (fullconfig repo) @@ -127,49 +131,63 @@ updateLocation' r l = do Just d -> do {- core.worktree is relative to the gitdir -} top <- absPath $ gitdir l - return $ l { worktree = Just $ absPathFrom top d } + let p = absPathFrom top (fromRawFilePath d) + return $ l { worktree = Just p } return $ r { location = l' } {- Parses git config --list or git config --null --list output into a - config map. -} -parse :: String -> M.Map String [String] -parse [] = M.empty +parse :: S.ByteString -> M.Map S.ByteString [S.ByteString] parse s - -- --list output will have an = in the first line - | all ('=' `elem`) (take 1 ls) = sep '=' ls + | S.null s = M.empty + -- --list output will have a '=' in the first line + -- (The first line of --null --list output is the name of a key, + -- which is assumed to never contain '='.) + | S.elem eq firstline = sep eq $ S.split nl s -- --null --list output separates keys from values with newlines - | otherwise = sep '\n' $ splitc '\0' s + | otherwise = sep nl $ S.split 0 s where - ls = lines s - sep c = M.fromListWith (++) . map (\(k,v) -> (k, [v])) . - map (separate (== c)) + nl = fromIntegral (ord '\n') + eq = fromIntegral (ord '=') + firstline = S.takeWhile (/= nl) s + + sep c = M.fromListWith (++) + . map (\(k,v) -> (k, [S.drop 1 v])) + . map (S.break (== c)) {- Checks if a string from git config is a true value. -} isTrue :: String -> Maybe Bool -isTrue s +isTrue = isTrue' . encodeBS' + +isTrue' :: S.ByteString -> Maybe Bool +isTrue' s | s' == "true" = Just True | s' == "false" = Just False | otherwise = Nothing where - s' = map toLower s + s' = S8.map toLower s boolConfig :: Bool -> String boolConfig True = "true" boolConfig False = "false" -isBare :: Repo -> Bool -isBare r = fromMaybe False $ isTrue =<< getMaybe coreBare r +boolConfig' :: Bool -> S.ByteString +boolConfig' True = "true" +boolConfig' False = "false" -coreBare :: String +isBare :: Repo -> Bool +isBare r = fromMaybe False $ isTrue' =<< getMaybe coreBare r + +coreBare :: S.ByteString coreBare = "core.bare" {- Runs a command to get the configuration of a repo, - and returns a repo populated with the configuration, as well as the raw - output of the command. -} -fromPipe :: Repo -> String -> [CommandParam] -> IO (Either SomeException (Repo, String)) +fromPipe :: Repo -> String -> [CommandParam] -> IO (Either SomeException (Repo, S.ByteString)) fromPipe r cmd params = try $ withHandle StdoutHandle createProcessSuccess p $ \h -> do - val <- hGetContentsStrict h + val <- S.hGetContents h r' <- store val r return (r', val) where @@ -177,7 +195,7 @@ fromPipe r cmd params = try $ {- Reads git config from a specified file and returns the repo populated - with the configuration. -} -fromFile :: Repo -> FilePath -> IO (Either SomeException (Repo, String)) +fromFile :: Repo -> FilePath -> IO (Either SomeException (Repo, S.ByteString)) fromFile r f = fromPipe r "git" [ Param "config" , Param "--file" @@ -187,13 +205,13 @@ fromFile r f = fromPipe r "git" {- Changes a git config setting in the specified config file. - (Creates the file if it does not already exist.) -} -changeFile :: FilePath -> String -> String -> IO Bool +changeFile :: FilePath -> S.ByteString -> S.ByteString -> IO Bool changeFile f k v = boolSystem "git" [ Param "config" , Param "--file" , File f - , Param k - , Param v + , Param (decodeBS' k) + , Param (decodeBS' v) ] {- Unsets a git config setting, in both the git repo, @@ -202,10 +220,10 @@ changeFile f k v = boolSystem "git" - If unsetting the config fails, including in a read-only repo, or - when the config is not set, returns Nothing. -} -unset :: String -> Repo -> IO (Maybe Repo) +unset :: S.ByteString -> Repo -> IO (Maybe Repo) unset k r = ifM (Git.Command.runBool ps r) ( return $ Just $ r { config = M.delete k (config r) } , return Nothing ) where - ps = [Param "config", Param "--unset-all", Param k] + ps = [Param "config", Param "--unset-all", Param (decodeBS' k)] diff --git a/Git/ConfigTypes.hs b/Git/ConfigTypes.hs index 2e262c643a..db5a1285d1 100644 --- a/Git/ConfigTypes.hs +++ b/Git/ConfigTypes.hs @@ -5,9 +5,12 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Git.ConfigTypes where import Data.Char +import qualified Data.ByteString.Char8 as S8 import Common import Git @@ -18,7 +21,7 @@ data SharedRepository = UnShared | GroupShared | AllShared | UmaskShared Int getSharedRepository :: Repo -> SharedRepository getSharedRepository r = - case map toLower $ Git.Config.get "core.sharedrepository" "" r of + case S8.map toLower $ Git.Config.get "core.sharedrepository" "" r of "1" -> GroupShared "2" -> AllShared "group" -> GroupShared @@ -26,14 +29,14 @@ getSharedRepository r = "all" -> AllShared "world" -> AllShared "everybody" -> AllShared - v -> maybe UnShared UmaskShared (readish v) + v -> maybe UnShared UmaskShared (readish (decodeBS' v)) data DenyCurrentBranch = UpdateInstead | RefusePush | WarnPush | IgnorePush deriving (Eq) getDenyCurrentBranch :: Repo -> DenyCurrentBranch getDenyCurrentBranch r = - case map toLower $ Git.Config.get "receive.denycurrentbranch" "" r of + case S8.map toLower $ Git.Config.get "receive.denycurrentbranch" "" r of "updateinstead" -> UpdateInstead "warn" -> WarnPush "ignore" -> IgnorePush diff --git a/Git/Construct.hs b/Git/Construct.hs index 7191f33036..44ae822e8b 100644 --- a/Git/Construct.hs +++ b/Git/Construct.hs @@ -28,6 +28,7 @@ import System.Posix.User #endif import qualified Data.Map as M import Network.URI +import qualified Data.ByteString as S import Common import Git.Types @@ -128,7 +129,7 @@ fromRemotes repo = mapM construct remotepairs filterconfig f = filter f $ M.toList $ config repo filterkeys f = filterconfig (\(k,_) -> f k) remotepairs = filterkeys isRemoteKey - construct (k,v) = remoteNamedFromKey k $ fromRemoteLocation v repo + construct (k,v) = remoteNamedFromKey k (fromRemoteLocation (decodeBS' v) repo) {- Sets the name of a remote when constructing the Repo to represent it. -} remoteNamed :: String -> IO Repo -> IO Repo @@ -138,7 +139,7 @@ remoteNamed n constructor = do {- Sets the name of a remote based on the git config key, such as - "remote.foo.url". -} -remoteNamedFromKey :: String -> IO Repo -> IO Repo +remoteNamedFromKey :: S.ByteString -> IO Repo -> IO Repo remoteNamedFromKey = remoteNamed . remoteKeyToRemoteName {- Constructs a new Repo for one of a Repo's remotes using a given diff --git a/Git/GCrypt.hs b/Git/GCrypt.hs index f19b77a98b..94c0b3794a 100644 --- a/Git/GCrypt.hs +++ b/Git/GCrypt.hs @@ -7,6 +7,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Git.GCrypt where import Common @@ -16,6 +18,8 @@ import qualified Git.Config as Config import qualified Git.Command as Command import Utility.Gpg +import qualified Data.ByteString as S + urlScheme :: String urlScheme = "gcrypt:" @@ -75,9 +79,9 @@ type GCryptId = String - which is stored in the repository (in encrypted form) - and cached in a per-remote gcrypt-id configuration setting. -} remoteRepoId :: Repo -> Maybe RemoteName -> Maybe GCryptId -remoteRepoId = getRemoteConfig "gcrypt-id" +remoteRepoId r n = decodeBS' <$> getRemoteConfig "gcrypt-id" r n -getRemoteConfig :: String -> Repo -> Maybe RemoteName -> Maybe String +getRemoteConfig :: S.ByteString -> Repo -> Maybe RemoteName -> Maybe S.ByteString getRemoteConfig field repo remotename = do n <- remotename Config.getMaybe (remoteConfigKey field n) repo @@ -93,17 +97,17 @@ getParticiantList globalconfigrepo repo remotename = KeyIds $ parse $ firstJust where defaultkey = "gcrypt.participants" parse (Just "simple") = [] - parse (Just l) = words l + parse (Just b) = words (decodeBS' b) parse Nothing = [] -remoteParticipantConfigKey :: RemoteName -> String +remoteParticipantConfigKey :: RemoteName -> S.ByteString remoteParticipantConfigKey = remoteConfigKey "gcrypt-participants" -remotePublishParticipantConfigKey :: RemoteName -> String +remotePublishParticipantConfigKey :: RemoteName -> S.ByteString remotePublishParticipantConfigKey = remoteConfigKey "gcrypt-publish-participants" -remoteSigningKey :: RemoteName -> String +remoteSigningKey :: RemoteName -> S.ByteString remoteSigningKey = remoteConfigKey "gcrypt-signingkey" -remoteConfigKey :: String -> RemoteName -> String -remoteConfigKey key remotename = "remote." ++ remotename ++ "." ++ key +remoteConfigKey :: S.ByteString -> RemoteName -> S.ByteString +remoteConfigKey key remotename = "remote." <> encodeBS' remotename <> "." <> key diff --git a/Git/Remote.hs b/Git/Remote.hs index fa336013e7..7ffaf10fd8 100644 --- a/Git/Remote.hs +++ b/Git/Remote.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} module Git.Remote where @@ -15,18 +16,20 @@ import Git.Types import Data.Char import qualified Data.Map as M +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 import Network.URI #ifdef mingw32_HOST_OS import Git.FilePath #endif {- Is a git config key one that specifies the location of a remote? -} -isRemoteKey :: String -> Bool -isRemoteKey k = "remote." `isPrefixOf` k && ".url" `isSuffixOf` k +isRemoteKey :: S.ByteString -> Bool +isRemoteKey k = "remote." `S.isPrefixOf` k && ".url" `S.isSuffixOf` k {- Get a remote's name from the config key that specifies its location. -} -remoteKeyToRemoteName :: String -> RemoteName -remoteKeyToRemoteName k = intercalate "." $ dropFromEnd 1 $ drop 1 $ splitc '.' k +remoteKeyToRemoteName :: S.ByteString -> RemoteName +remoteKeyToRemoteName = decodeBS' . S.intercalate "." . dropFromEnd 1 . drop 1 . S8.split '.' {- Construct a legal git remote name out of an arbitrary input string. - @@ -76,16 +79,16 @@ parseRemoteLocation s repo = ret $ calcloc s -- insteadof config can rewrite remote location calcloc l | null insteadofs = l - | otherwise = replacement ++ drop (length bestvalue) l + | otherwise = replacement ++ drop (S.length bestvalue) l where - replacement = drop (length prefix) $ - take (length bestkey - length suffix) bestkey + replacement = decodeBS' $ S.drop (S.length prefix) $ + S.take (S.length bestkey - S.length suffix) bestkey (bestkey, bestvalue) = maximumBy longestvalue insteadofs longestvalue (_, a) (_, b) = compare b a insteadofs = filterconfig $ \(k, v) -> - prefix `isPrefixOf` k && - suffix `isSuffixOf` k && - v `isPrefixOf` l + prefix `S.isPrefixOf` k && + suffix `S.isSuffixOf` k && + v `S.isPrefixOf` encodeBS l filterconfig f = filter f $ concatMap splitconfigs $ M.toList $ fullconfig repo splitconfigs (k, vs) = map (\v -> (k, v)) vs diff --git a/Git/Types.hs b/Git/Types.hs index 90401db153..961df6eb52 100644 --- a/Git/Types.hs +++ b/Git/Types.hs @@ -35,9 +35,9 @@ data RepoLocation data Repo = Repo { location :: RepoLocation - , config :: M.Map String String + , config :: M.Map S.ByteString S.ByteString -- a given git config key can actually have multiple values - , fullconfig :: M.Map String [String] + , fullconfig :: M.Map S.ByteString [S.ByteString] -- remoteName holds the name used for this repo in some other -- repo's list of remotes, when this repo is such a remote , remoteName :: Maybe RemoteName diff --git a/Remote.hs b/Remote.hs index e54f711acf..363876c29e 100644 --- a/Remote.hs +++ b/Remote.hs @@ -147,10 +147,12 @@ byName' n = go . filter matching <$> remoteList {- Finds the remote or remote group matching the name. -} byNameOrGroup :: RemoteName -> Annex [Remote] -byNameOrGroup n = go =<< getConfigMaybe (ConfigKey ("remotes." ++ n)) +byNameOrGroup n = go =<< getConfigMaybe (ConfigKey ("remotes." <> encodeBS' n)) where - go (Just l) = catMaybes <$> mapM (byName . Just) (splitc ' ' l) - go Nothing = maybeToList <$> byName (Just n) + go (Just l) = catMaybes + <$> mapM (byName . Just) (splitc ' ' (decodeBS' l)) + go Nothing = maybeToList + <$> byName (Just n) {- Only matches remote name, not UUID -} byNameOnly :: RemoteName -> Annex (Maybe Remote) diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs index ff948ba0d6..931adce3b4 100644 --- a/Remote/GCrypt.hs +++ b/Remote/GCrypt.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Remote.GCrypt ( remote, chainGen, @@ -16,6 +18,7 @@ module Remote.GCrypt ( ) where import qualified Data.Map as M +import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import Control.Exception import Data.Default @@ -159,11 +162,12 @@ rsyncTransportToObjects r gc = do rsyncTransport :: Git.Repo -> RemoteGitConfig -> Annex (Annex [CommandParam], String, AccessMethod) rsyncTransport r gc - | "ssh://" `isPrefixOf` loc = sshtransport $ break (== '/') $ drop (length "ssh://") loc + | sshprefix `isPrefixOf` loc = sshtransport $ break (== '/') $ drop (length sshprefix) loc | "//:" `isInfixOf` loc = othertransport | ":" `isInfixOf` loc = sshtransport $ separate (== ':') loc | otherwise = othertransport where + sshprefix = "ssh://" :: String loc = Git.repoLocation r sshtransport (host, path) = do let rsyncpath = if "/~/" `isPrefixOf` path @@ -252,7 +256,7 @@ setupRepo gcryptid r | otherwise = localsetup r where localsetup r' = do - let setconfig k v = liftIO $ Git.Command.run [Param "config", Param k, Param v] r' + let setconfig k v = liftIO $ Git.Command.run [Param "config", Param (decodeBS' k), Param v] r' setconfig coreGCryptId gcryptid setconfig denyNonFastForwards (Git.Config.boolConfig False) return AccessDirect @@ -272,8 +276,8 @@ setupRepo gcryptid r , Param tmpconfig ] liftIO $ do - void $ Git.Config.changeFile tmpconfig coreGCryptId gcryptid - void $ Git.Config.changeFile tmpconfig denyNonFastForwards (Git.Config.boolConfig False) + void $ Git.Config.changeFile tmpconfig coreGCryptId (encodeBS' gcryptid) + void $ Git.Config.changeFile tmpconfig denyNonFastForwards (Git.Config.boolConfig' False) ok <- liftIO $ rsync $ opts ++ [ Param "--recursive" , Param $ tmp ++ "/" @@ -435,7 +439,7 @@ getGCryptUUID fast r = do (genUUIDInNameSpace gCryptNameSpace <$>) . fst <$> getGCryptId fast r dummycfg -coreGCryptId :: String +coreGCryptId :: S.ByteString coreGCryptId = "core.gcrypt-id" {- gcrypt repos set up by git-annex as special remotes have a @@ -457,9 +461,9 @@ getGCryptId fast r gc | otherwise = return (Nothing, r) where extract Nothing = (Nothing, r) - extract (Just r') = (Git.Config.getMaybe coreGCryptId r', r') + extract (Just r') = (decodeBS' <$> Git.Config.getMaybe coreGCryptId r', r') -getConfigViaRsync :: Git.Repo -> RemoteGitConfig -> Annex (Either SomeException (Git.Repo, String)) +getConfigViaRsync :: Git.Repo -> RemoteGitConfig -> Annex (Either SomeException (Git.Repo, S.ByteString)) getConfigViaRsync r gc = do (rsynctransport, rsyncurl, _) <- rsyncTransport r gc opts <- rsynctransport diff --git a/Remote/Git.hs b/Remote/Git.hs index 7aebe8c24f..a04e07cfdd 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} module Remote.Git ( remote, @@ -68,6 +69,7 @@ import Utility.FileMode import Control.Concurrent import Control.Concurrent.MSampleVar import qualified Data.Map as M +import qualified Data.ByteString as S import Network.URI remote :: RemoteType @@ -86,14 +88,14 @@ list autoinit = do rs <- mapM (tweakurl c) =<< Annex.getGitRemotes mapM (configRead autoinit) rs where - annexurl n = "remote." ++ n ++ ".annexurl" + annexurl n = "remote." <> encodeBS' n <> ".annexurl" tweakurl c r = do let n = fromJust $ Git.remoteName r case M.lookup (annexurl n) c of Nothing -> return r Just url -> inRepo $ \g -> Git.Construct.remoteNamed n $ - Git.Construct.fromRemoteLocation url g + Git.Construct.fromRemoteLocation (decodeBS' url) g {- Git remotes are normally set up using standard git command, not - git-annex initremote and enableremote. @@ -254,7 +256,7 @@ tryGitConfigRead autoinit r v <- liftIO $ Git.Config.fromPipe r cmd params case v of Right (r', val) -> do - unless (isUUIDConfigured r' || null val) $ do + unless (isUUIDConfigured r' || S.null val) $ do warning $ "Failed to get annex.uuid configuration of repository " ++ Git.repoDescribe r warning $ "Instead, got: " ++ show val warning $ "This is unexpected; please check the network transport!" diff --git a/Remote/GitLFS.hs b/Remote/GitLFS.hs index 3da33ac55b..73609026ab 100644 --- a/Remote/GitLFS.hs +++ b/Remote/GitLFS.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Remote.GitLFS (remote, gen, configKnownUrl) where import Annex.Common @@ -153,7 +155,7 @@ mySetup _ mu _ c gc = do -- (so it's also usable by git as a non-special remote), -- and set remote.name.annex-git-lfs = true gitConfigSpecialRemote u c' [("git-lfs", "true")] - setConfig (ConfigKey ("remote." ++ getRemoteName c ++ ".url")) url + setConfig (ConfigKey ("remote." <> encodeBS' (getRemoteName c) <> ".url")) url return (c', u) where url = fromMaybe (giveup "Specify url=") (M.lookup "url" c) @@ -187,7 +189,7 @@ configKnownUrl r set k v r' = do let ck@(ConfigKey k') = remoteConfig r' k setConfig ck v - return $ Git.Config.store' k' v r' + return $ Git.Config.store' k' (encodeBS' v) r' data LFSHandle = LFSHandle { downloadEndpoint :: Maybe LFS.Endpoint diff --git a/Remote/Helper/Special.hs b/Remote/Helper/Special.hs index 510793a8db..7f16ec579d 100644 --- a/Remote/Helper/Special.hs +++ b/Remote/Helper/Special.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Remote.Helper.Special ( findSpecialRemotes, gitConfigSpecialRemote, @@ -52,6 +54,7 @@ import Messages.Progress import qualified Git import qualified Git.Construct +import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import qualified Data.Map as M @@ -65,14 +68,15 @@ findSpecialRemotes s = do liftIO $ mapM construct $ remotepairs m where remotepairs = M.toList . M.filterWithKey match - construct (k,_) = Git.Construct.remoteNamedFromKey k (pure Git.Construct.fromUnknown) - match k _ = "remote." `isPrefixOf` k && (".annex-"++s) `isSuffixOf` k + construct (k,_) = Git.Construct.remoteNamedFromKey k + (pure Git.Construct.fromUnknown) + match k _ = "remote." `S.isPrefixOf` k && (".annex-" <> encodeBS' s) `S.isSuffixOf` k {- Sets up configuration for a special remote in .git/config. -} gitConfigSpecialRemote :: UUID -> RemoteConfig -> [(String, String)] -> Annex () gitConfigSpecialRemote u c cfgs = do forM_ cfgs $ \(k, v) -> - setConfig (remoteConfig c k) v + setConfig (remoteConfig c (encodeBS' k)) v storeUUIDIn (remoteConfig c "uuid") u -- RetrievalVerifiableKeysSecure unless overridden by git config. diff --git a/Test/Framework.hs b/Test/Framework.hs index ed1aa67d21..187b54ef0e 100644 --- a/Test/Framework.hs +++ b/Test/Framework.hs @@ -88,8 +88,8 @@ inmainrepo a = do with_ssh_origin :: (Assertion -> Assertion) -> (Assertion -> Assertion) with_ssh_origin cloner a = cloner $ do - origindir <- absPath - =<< annexeval (Config.getConfig (Config.ConfigKey config) "/dev/null") + origindir <- absPath . decodeBS' + =<< annexeval (Config.getConfig (Config.ConfigKey (encodeBS' config)) (toRawFilePath "/dev/null")) let originurl = "localhost:" ++ origindir boolSystem "git" [Param "config", Param config, Param originurl] @? "git config failed" a diff --git a/Types/Difference.hs b/Types/Difference.hs index 774336c18e..678b6f4bf6 100644 --- a/Types/Difference.hs +++ b/Types/Difference.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Types.Difference ( Difference(..), Differences(..), @@ -23,6 +25,7 @@ import qualified Git.Config import Data.Maybe import Data.Monoid +import qualified Data.ByteString as B import qualified Data.Set as S import qualified Data.Semigroup as Sem import Prelude @@ -92,11 +95,11 @@ getDifferences :: Git.Repo -> Differences getDifferences r = mkDifferences $ S.fromList $ mapMaybe getmaybe [minBound .. maxBound] where - getmaybe d = case Git.Config.isTrue =<< Git.Config.getMaybe (differenceConfigKey d) r of + getmaybe d = case Git.Config.isTrue' =<< Git.Config.getMaybe (differenceConfigKey d) r of Just True -> Just d _ -> Nothing -differenceConfigKey :: Difference -> String +differenceConfigKey :: Difference -> B.ByteString differenceConfigKey ObjectHashLower = tunable "objecthashlower" differenceConfigKey OneLevelObjectHash = tunable "objecthash1" differenceConfigKey OneLevelBranchHash = tunable "branchhash1" @@ -104,8 +107,8 @@ differenceConfigKey OneLevelBranchHash = tunable "branchhash1" differenceConfigVal :: Difference -> String differenceConfigVal _ = Git.Config.boolConfig True -tunable :: String -> String -tunable k = "annex.tune." ++ k +tunable :: B.ByteString -> B.ByteString +tunable k = "annex.tune." <> k hasDifference :: Difference -> Differences -> Bool hasDifference _ UnknownDifferences = False diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs index 50aa6f2379..ad058171af 100644 --- a/Types/GitConfig.hs +++ b/Types/GitConfig.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Types.GitConfig ( Configurable(..), GitConfig(..), @@ -199,16 +201,17 @@ extractGitConfig r = GitConfig } where getbool k d = fromMaybe d $ getmaybebool k - getmaybebool k = Git.Config.isTrue =<< getmaybe k + getmaybebool k = Git.Config.isTrue' =<< getmaybe' k getmayberead k = readish =<< getmaybe k - getmaybe k = Git.Config.getMaybe k r - getlist k = Git.Config.getList k r + getmaybe = fmap decodeBS' . getmaybe' + getmaybe' k = Git.Config.getMaybe k r + getlist k = map decodeBS' $ Git.Config.getList k r getwords k = fromMaybe [] $ words <$> getmaybe k configurable d Nothing = DefaultConfig d configurable _ (Just v) = HasConfig v - annex k = "annex." ++ k + annex k = "annex." <> k onemegabyte = 1000000 @@ -340,14 +343,15 @@ extractRemoteGitConfig r remotename = do } where getbool k d = fromMaybe d $ getmaybebool k - getmaybebool k = Git.Config.isTrue =<< getmaybe k + getmaybebool k = Git.Config.isTrue' =<< getmaybe' k getmayberead k = readish =<< getmaybe k - getmaybe k = mplus (Git.Config.getMaybe (key k) r) + getmaybe = fmap decodeBS' . getmaybe' + getmaybe' k = mplus (Git.Config.getMaybe (key k) r) (Git.Config.getMaybe (remotekey k) r) getoptions k = fromMaybe [] $ words <$> getmaybe k - key k = "annex." ++ k - remotekey k = "remote." ++ remotename ++ ".annex-" ++ k + key k = "annex." <> k + remotekey k = "remote." <> encodeBS' remotename <> ".annex-" <> k notempty :: Maybe String -> Maybe String notempty Nothing = Nothing diff --git a/Upgrade/V5/Direct.hs b/Upgrade/V5/Direct.hs index 8b67bb3926..c238101ff3 100644 --- a/Upgrade/V5/Direct.hs +++ b/Upgrade/V5/Direct.hs @@ -7,6 +7,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Upgrade.V5.Direct ( switchHEADBack, setIndirect, @@ -49,7 +51,7 @@ setIndirect = do Nothing -> noop Just wt -> do unsetConfig src - setConfig dest wt + setConfig dest (decodeBS' wt) reloadConfig {- Converts a directBranch back to the original branch. diff --git a/doc/todo/optimize_by_converting_String_to_ByteString.mdwn b/doc/todo/optimize_by_converting_String_to_ByteString.mdwn index 203da76b91..83104bf0dc 100644 --- a/doc/todo/optimize_by_converting_String_to_ByteString.mdwn +++ b/doc/todo/optimize_by_converting_String_to_ByteString.mdwn @@ -29,5 +29,3 @@ the `bs` branch has quite a lot of things still needing work, including: avoiding a conversion. Note that these are only available on unix, not windows, so a compatability shim will be needed. (I can't seem to find any library that provides one.) - -* Use ByteString for parsing git config to speed up startup. From c75600637462dba37dd7d10f9bbaf1613022c4ee Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 2 Dec 2019 10:51:43 -0400 Subject: [PATCH 06/42] fix hacked up AutoMerge module to work again --- Annex/AutoMerge.hs | 39 ++++++++++++++------------------------- 1 file changed, 14 insertions(+), 25 deletions(-) diff --git a/Annex/AutoMerge.hs b/Annex/AutoMerge.hs index 00193d3481..f537081d71 100644 --- a/Annex/AutoMerge.hs +++ b/Annex/AutoMerge.hs @@ -43,8 +43,6 @@ import qualified Data.ByteString.Lazy as L -} autoMergeFrom :: Git.Ref -> Maybe Git.Ref -> [Git.Merge.MergeConfig] -> Annex Bool -> Git.Branch.CommitMode -> Annex Bool autoMergeFrom branch currbranch mergeconfig canresolvemerge commitmode = do - error "STUBBED FIXME" -{- showOutput case currbranch of Nothing -> go Nothing @@ -64,7 +62,6 @@ autoMergeFrom branch currbranch mergeconfig canresolvemerge commitmode = do ( resolveMerge old branch False , return False ) --} {- Resolves a conflicted merge. It's important that any conflicts be - resolved in a way that itself avoids later merge conflicts, since @@ -107,9 +104,7 @@ autoMergeFrom branch currbranch mergeconfig canresolvemerge commitmode = do -} resolveMerge :: Maybe Git.Ref -> Git.Ref -> Bool -> Annex Bool resolveMerge us them inoverlay = do - error "STUBBED FIXME" -{- - top <- if inoverlay + top <- toRawFilePath <$> if inoverlay then pure "." else fromRepo Git.repoPath (fs, cleanup) <- inRepo (LsFiles.unmerged [top]) @@ -127,7 +122,7 @@ resolveMerge us them inoverlay = do unless (null deleted) $ Annex.Queue.addCommand "rm" [Param "--quiet", Param "-f", Param "--"] - deleted + (map fromRawFilePath deleted) void $ liftIO cleanup2 when merged $ do @@ -137,13 +132,10 @@ resolveMerge us them inoverlay = do cleanConflictCruft mergedks' mergedfs' unstagedmap showLongNote "Merge conflict was automatically resolved; you may want to examine the result." return merged --} resolveMerge' :: InodeMap -> Maybe Git.Ref -> Git.Ref -> Bool -> LsFiles.Unmerged -> Annex ([Key], Maybe FilePath) resolveMerge' _ Nothing _ _ _ = return ([], Nothing) resolveMerge' unstagedmap (Just us) them inoverlay u = do - error "STUBBED FIXME" -{- kus <- getkey LsFiles.valUs kthem <- getkey LsFiles.valThem case (kus, kthem) of @@ -177,7 +169,7 @@ resolveMerge' unstagedmap (Just us) them inoverlay u = do -- Neither side is annexed file; cannot resolve. (Nothing, Nothing) -> return ([], Nothing) where - file = LsFiles.unmergedFile u + file = fromRawFilePath $ LsFiles.unmergedFile u getkey select = case select (LsFiles.unmergedSha u) of @@ -210,20 +202,20 @@ resolveMerge' unstagedmap (Just us) them inoverlay u = do makesymlink key dest = do l <- calcRepo $ gitAnnexLink dest key unless inoverlay $ replacewithsymlink dest l - dest' <- stagefile dest + dest' <- toRawFilePath <$> stagefile dest stageSymlink dest' =<< hashSymlink l replacewithsymlink dest link = withworktree dest $ \f -> - replaceFile f $ makeGitLink link + replaceFile f $ makeGitLink link . toRawFilePath makepointer key dest destmode = do unless inoverlay $ unlessM (reuseOldFile unstagedmap key file dest) $ linkFromAnnex key dest destmode >>= \case LinkAnnexFailed -> liftIO $ - writePointerFile dest key destmode + writePointerFile (toRawFilePath dest) key destmode _ -> noop - dest' <- stagefile dest + dest' <- toRawFilePath <$> stagefile dest stagePointerFile dest' destmode =<< hashPointerFile key unless inoverlay $ Database.Keys.addAssociatedFile key @@ -247,7 +239,7 @@ resolveMerge' unstagedmap (Just us) them inoverlay u = do Nothing -> noop Just sha -> do link <- catSymLinkTarget sha - replacewithsymlink item link + replacewithsymlink item (fromRawFilePath link) -- And when grafting in anything else vs a symlink, -- the work tree already contains what we want. (_, Just TreeSymlink) -> noop @@ -273,7 +265,6 @@ resolveMerge' unstagedmap (Just us) them inoverlay u = do [Param "--quiet", Param "-f", Param "--cached", Param "--"] [file] void a return (ks, Just file) --} {- git-merge moves conflicting files away to files - named something like f~HEAD or f~branch or just f, but the @@ -287,8 +278,6 @@ resolveMerge' unstagedmap (Just us) them inoverlay u = do -} cleanConflictCruft :: [Key] -> [FilePath] -> InodeMap -> Annex () cleanConflictCruft resolvedks resolvedfs unstagedmap = do - error "STUBBED FIXME" -{- is <- S.fromList . map (inodeCacheToKey Strongly) . concat <$> mapM Database.Keys.getInodeCaches resolvedks forM_ (M.toList unstagedmap) $ \(i, f) -> @@ -301,11 +290,10 @@ cleanConflictCruft resolvedks resolvedfs unstagedmap = do matchesresolved is i f | S.member f fs || S.member (conflictCruftBase f) fs = anyM id [ pure (S.member i is) - , inks <$> isAnnexLink f - , inks <$> liftIO (isPointerFile f) + , inks <$> isAnnexLink (toRawFilePath f) + , inks <$> liftIO (isPointerFile (toRawFilePath f)) ] | otherwise = return False --} conflictCruftBase :: FilePath -> FilePath conflictCruftBase f = reverse $ drop 1 $ dropWhile (/= '~') $ reverse f @@ -340,13 +328,14 @@ commitResolvedMerge commitmode = inRepo $ Git.Branch.commitCommand commitmode type InodeMap = M.Map InodeCacheKey FilePath -inodeMap :: Annex ([FilePath], IO Bool) -> Annex InodeMap +inodeMap :: Annex ([RawFilePath], IO Bool) -> Annex InodeMap inodeMap getfiles = do (fs, cleanup) <- getfiles fsis <- forM fs $ \f -> do - mi <- withTSDelta (liftIO . genInodeCache f) + let f' = fromRawFilePath f + mi <- withTSDelta (liftIO . genInodeCache f') return $ case mi of Nothing -> Nothing - Just i -> Just (inodeCacheToKey Strongly i, f) + Just i -> Just (inodeCacheToKey Strongly i, f') void $ liftIO cleanup return $ M.fromList $ catMaybes fsis From 65b88a0b9950cfc3debc2abded39e8a184483f4b Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 2 Dec 2019 10:55:11 -0400 Subject: [PATCH 07/42] revert unncessary changes part of the hacking in 067aabdd4899997f10c78388273f28cccf777b66 but did not need to be committed --- stack.yaml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/stack.yaml b/stack.yaml index ca0494c353..d97bf2f263 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,12 +1,12 @@ flags: git-annex: production: true - assistant: false + assistant: true pairing: true s3: true - webdav: false + webdav: true torrentparser: true - webapp: false + webapp: true magicmime: false dbus: false debuglocks: false From f3047d718689b856b4aba24238b86de5c4d00cda Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 2 Dec 2019 10:57:09 -0400 Subject: [PATCH 08/42] include git-annex-shell back in Also pushed ConfigKey down into the Git modules, which is the bulk of the changes. --- Annex/Difference.hs | 2 +- Annex/Environment.hs | 4 ++-- Annex/Fixup.hs | 3 +-- Annex/Init.hs | 4 ++-- Annex/UUID.hs | 20 +++++++++----------- Annex/Version.hs | 1 + Command/ConfigList.hs | 8 +++++--- Command/SendKey.hs | 3 ++- Command/TransferInfo.hs | 3 ++- Config.hs | 11 +++-------- Config/Smudge.hs | 1 + Git/Config.hs | 24 ++++++++++++------------ Git/Construct.hs | 3 +-- Git/GCrypt.hs | 11 ++++++----- Git/Remote.hs | 13 +++++++------ Git/Types.hs | 21 +++++++++++++++++---- Remote.hs | 2 +- Remote/GCrypt.hs | 13 +++++++------ Remote/Git.hs | 2 +- Remote/GitLFS.hs | 6 +++--- Remote/Helper/Special.hs | 5 ++++- Test/Framework.hs | 3 ++- Types/Difference.hs | 7 ++++--- Types/GitConfig.hs | 7 ++++--- Upgrade/V5/Direct.hs | 2 +- git-annex.hs | 4 ++-- 26 files changed, 101 insertions(+), 82 deletions(-) diff --git a/Annex/Difference.hs b/Annex/Difference.hs index be621dc6fc..4d13c7211c 100644 --- a/Annex/Difference.hs +++ b/Annex/Difference.hs @@ -54,5 +54,5 @@ setDifferences = do else return ds ) forM_ (listDifferences ds') $ \d -> - setConfig (ConfigKey $ differenceConfigKey d) (differenceConfigVal d) + setConfig (differenceConfigKey d) (differenceConfigVal d) recordDifferences ds' u diff --git a/Annex/Environment.hs b/Annex/Environment.hs index 0e101d2e76..3da7ce980b 100644 --- a/Annex/Environment.hs +++ b/Annex/Environment.hs @@ -47,6 +47,6 @@ ensureCommit a = either retry return =<< tryNonAsync a where retry _ = do name <- liftIO $ either (const "unknown") id <$> myUserName - setConfig (ConfigKey "user.name") name - setConfig (ConfigKey "user.email") name + setConfig "user.name" name + setConfig "user.email" name a diff --git a/Annex/Fixup.hs b/Annex/Fixup.hs index 4585433c72..547458c08f 100644 --- a/Annex/Fixup.hs +++ b/Annex/Fixup.hs @@ -19,7 +19,6 @@ import Utility.SafeCommand import Utility.Directory import Utility.Exception import Utility.Monad -import Utility.FileSystemEncoding import Utility.PartialPrelude import System.IO @@ -56,7 +55,7 @@ fixupDirect r@(Repo { location = l@(Local { gitdir = d, worktree = Nothing }) }) { location = l { worktree = Just (parentDir d) } , gitGlobalOpts = gitGlobalOpts r ++ [ Param "-c" - , Param $ decodeBS' coreBare ++ "=" ++ boolConfig False + , Param $ fromConfigKey coreBare ++ "=" ++ boolConfig False ] } fixupDirect r = r diff --git a/Annex/Init.hs b/Annex/Init.hs index 38847c4e0d..ac6718dde7 100644 --- a/Annex/Init.hs +++ b/Annex/Init.hs @@ -205,7 +205,7 @@ checkCrippledFileSystem = whenM probeCrippledFileSystem $ do - filesystem. -} whenM (coreSymlinks <$> Annex.getGitConfig) $ do warning "Disabling core.symlinks." - setConfig (ConfigKey "core.symlinks") + setConfig "core.symlinks" (Git.Config.boolConfig False) probeLockSupport :: Annex Bool @@ -275,5 +275,5 @@ initSharedClone True = do - affect it. -} propigateSecureHashesOnly :: Annex () propigateSecureHashesOnly = - maybe noop (setConfig (ConfigKey "annex.securehashesonly")) + maybe noop (setConfig "annex.securehashesonly") =<< getGlobalConfig "annex.securehashesonly" diff --git a/Annex/UUID.hs b/Annex/UUID.hs index 23593a46f7..f3fc4c8acf 100644 --- a/Annex/UUID.hs +++ b/Annex/UUID.hs @@ -14,6 +14,7 @@ {-# LANGUAGE OverloadedStrings #-} module Annex.UUID ( + configkeyUUID, getUUID, getRepoUUID, getUncachedUUID, @@ -34,6 +35,7 @@ import Annex.Common import qualified Annex import qualified Git import qualified Git.Config +import Git.Types import Config import qualified Data.UUID as U @@ -41,8 +43,8 @@ import qualified Data.UUID.V4 as U4 import qualified Data.UUID.V5 as U5 import Data.String -configkey :: ConfigKey -configkey = annexConfig "uuid" +configkeyUUID :: ConfigKey +configkeyUUID = annexConfig "uuid" {- Generates a random UUID, that does not include the MAC address. -} genUUID :: IO UUID @@ -83,20 +85,16 @@ getRepoUUID r = do removeRepoUUID :: Annex () removeRepoUUID = do - unsetConfig configkey + unsetConfig configkeyUUID storeUUID NoUUID getUncachedUUID :: Git.Repo -> UUID -getUncachedUUID = toUUID . Git.Config.get key "" - where - (ConfigKey key) = configkey +getUncachedUUID = toUUID . Git.Config.get configkeyUUID "" -- Does the repo's config have a key for the UUID? -- True even when the key has no value. isUUIDConfigured :: Git.Repo -> Bool -isUUIDConfigured = isJust . Git.Config.getMaybe key - where - (ConfigKey key) = configkey +isUUIDConfigured = isJust . Git.Config.getMaybe configkeyUUID {- Make sure that the repo has an annex.uuid setting. -} prepUUID :: Annex () @@ -106,7 +104,7 @@ prepUUID = whenM ((==) NoUUID <$> getUUID) $ storeUUID :: UUID -> Annex () storeUUID u = do Annex.changeGitConfig $ \c -> c { annexUUID = u } - storeUUIDIn configkey u + storeUUIDIn configkeyUUID u storeUUIDIn :: ConfigKey -> UUID -> Annex () storeUUIDIn configfield = setConfig configfield . fromUUID @@ -114,7 +112,7 @@ storeUUIDIn configfield = setConfig configfield . fromUUID {- Only sets the configkey in the Repo; does not change .git/config -} setUUID :: Git.Repo -> UUID -> IO Git.Repo setUUID r u = do - let s = encodeBS' $ show configkey ++ "=" ++ fromUUID u + let s = encodeBS' $ show configkeyUUID ++ "=" ++ fromUUID u Git.Config.store s r -- Dummy uuid for the whole web. Do not alter. diff --git a/Annex/Version.hs b/Annex/Version.hs index e7cab2a3ac..91295fec92 100644 --- a/Annex/Version.hs +++ b/Annex/Version.hs @@ -12,6 +12,7 @@ module Annex.Version where import Annex.Common import Config +import Git.Types import Types.RepoVersion import qualified Annex diff --git a/Command/ConfigList.hs b/Command/ConfigList.hs index 53b89c3489..793f22df47 100644 --- a/Command/ConfigList.hs +++ b/Command/ConfigList.hs @@ -12,6 +12,7 @@ import Annex.UUID import Annex.Init import qualified Annex.Branch import qualified Git.Config +import Git.Types import Remote.GCrypt (coreGCryptId) import qualified CmdLine.GitAnnexShell.Fields as Fields import CmdLine.GitAnnexShell.Checks @@ -28,11 +29,12 @@ seek = withNothing (commandAction start) start :: CommandStart start = do u <- findOrGenUUID - showConfig "annex.uuid" $ fromUUID u - showConfig coreGCryptId =<< fromRepo (Git.Config.get coreGCryptId "") + showConfig configkeyUUID $ fromUUID u + showConfig coreGCryptId . decodeBS' + =<< fromRepo (Git.Config.get coreGCryptId mempty) stop where - showConfig k v = liftIO $ putStrLn $ k ++ "=" ++ v + showConfig k v = liftIO $ putStrLn $ fromConfigKey k ++ "=" ++ v {- The repository may not yet have a UUID; automatically initialize it - when there's a git-annex branch available or if the autoinit field was diff --git a/Command/SendKey.hs b/Command/SendKey.hs index 57832cee92..aa7aa092f7 100644 --- a/Command/SendKey.hs +++ b/Command/SendKey.hs @@ -46,7 +46,8 @@ start key = do fieldTransfer :: Direction -> Key -> (MeterUpdate -> Annex Bool) -> CommandStart fieldTransfer direction key a = do liftIO $ debugM "fieldTransfer" "transfer start" - afile <- AssociatedFile <$> Fields.getField Fields.associatedFile + afile <- AssociatedFile . (fmap toRawFilePath) + <$> Fields.getField Fields.associatedFile ok <- maybe (a $ const noop) -- Using noRetry here because we're the sender. (\u -> runner (Transfer direction (toUUID u) (fromKey id key)) afile noRetry a) diff --git a/Command/TransferInfo.hs b/Command/TransferInfo.hs index 520d79b479..402f1ef8ec 100644 --- a/Command/TransferInfo.hs +++ b/Command/TransferInfo.hs @@ -41,7 +41,8 @@ start (k:[]) = do case deserializeKey k of Nothing -> error "bad key" (Just key) -> whenM (inAnnex key) $ do - afile <- AssociatedFile <$> Fields.getField Fields.associatedFile + afile <- AssociatedFile . (fmap toRawFilePath) + <$> Fields.getField Fields.associatedFile u <- maybe (error "missing remoteuuid") toUUID <$> Fields.getField Fields.remoteUUID let t = Transfer diff --git a/Config.hs b/Config.hs index 94a22f720a..e3925c9746 100644 --- a/Config.hs +++ b/Config.hs @@ -27,18 +27,13 @@ import qualified Data.ByteString as S type UnqualifiedConfigKey = S.ByteString -newtype ConfigKey = ConfigKey S.ByteString - -instance Show ConfigKey where - show (ConfigKey s) = decodeBS' s - {- Looks up a setting in git config. This is not as efficient as using the - GitConfig type. -} getConfig :: ConfigKey -> S.ByteString -> Annex S.ByteString -getConfig (ConfigKey key) d = fromRepo $ Git.Config.get key d +getConfig key d = fromRepo $ Git.Config.get key d getConfigMaybe :: ConfigKey -> Annex (Maybe S.ByteString) -getConfigMaybe (ConfigKey key) = fromRepo $ Git.Config.getMaybe key +getConfigMaybe key = fromRepo $ Git.Config.getMaybe key {- Changes a git config setting in both internal state and .git/config -} setConfig :: ConfigKey -> String -> Annex () @@ -55,7 +50,7 @@ reloadConfig = Annex.changeGitRepo =<< inRepo Git.Config.reRead {- Unsets a git config setting. (Leaves it in state.) -} unsetConfig :: ConfigKey -> Annex () -unsetConfig (ConfigKey key) = void $ inRepo $ Git.Config.unset key +unsetConfig key = void $ inRepo $ Git.Config.unset key class RemoteNameable r where getRemoteName :: r -> RemoteName diff --git a/Config/Smudge.hs b/Config/Smudge.hs index 08568f57c9..68e39c4b8d 100644 --- a/Config/Smudge.hs +++ b/Config/Smudge.hs @@ -13,6 +13,7 @@ import Annex.Common import qualified Annex import qualified Git import qualified Git.Command +import Git.Types import Config configureSmudgeFilter :: Annex () diff --git a/Git/Config.hs b/Git/Config.hs index 215c7b40c8..8e42314bc1 100644 --- a/Git/Config.hs +++ b/Git/Config.hs @@ -22,15 +22,15 @@ import qualified Git.Construct import Utility.UserInfo {- Returns a single git config setting, or a default value if not set. -} -get :: S.ByteString -> S.ByteString -> Repo -> S.ByteString +get :: ConfigKey -> S.ByteString -> Repo -> S.ByteString get key defaultValue repo = M.findWithDefault defaultValue key (config repo) {- Returns a list with each line of a multiline config setting. -} -getList :: S.ByteString -> Repo -> [S.ByteString] +getList :: ConfigKey -> Repo -> [S.ByteString] getList key repo = M.findWithDefault [] key (fullconfig repo) {- Returns a single git config setting, if set. -} -getMaybe :: S.ByteString -> Repo -> Maybe S.ByteString +getMaybe :: ConfigKey -> Repo -> Maybe S.ByteString getMaybe key repo = M.lookup key (config repo) {- Runs git config and populates a repo with its config. @@ -100,7 +100,7 @@ store s repo = do {- Stores a single config setting in a Repo, returning the new version of - the Repo. Config settings can be updated incrementally. -} -store' :: S.ByteString -> S.ByteString -> Repo -> Repo +store' :: ConfigKey -> S.ByteString -> Repo -> Repo store' k v repo = repo { config = M.singleton k v `M.union` config repo , fullconfig = M.unionWith (++) (M.singleton k [v]) (fullconfig repo) @@ -137,7 +137,7 @@ updateLocation' r l = do {- Parses git config --list or git config --null --list output into a - config map. -} -parse :: S.ByteString -> M.Map S.ByteString [S.ByteString] +parse :: S.ByteString -> M.Map ConfigKey [S.ByteString] parse s | S.null s = M.empty -- --list output will have a '=' in the first line @@ -152,7 +152,7 @@ parse s firstline = S.takeWhile (/= nl) s sep c = M.fromListWith (++) - . map (\(k,v) -> (k, [S.drop 1 v])) + . map (\(k,v) -> (ConfigKey k, [S.drop 1 v])) . map (S.break (== c)) {- Checks if a string from git config is a true value. -} @@ -178,7 +178,7 @@ boolConfig' False = "false" isBare :: Repo -> Bool isBare r = fromMaybe False $ isTrue' =<< getMaybe coreBare r -coreBare :: S.ByteString +coreBare :: ConfigKey coreBare = "core.bare" {- Runs a command to get the configuration of a repo, @@ -205,8 +205,8 @@ fromFile r f = fromPipe r "git" {- Changes a git config setting in the specified config file. - (Creates the file if it does not already exist.) -} -changeFile :: FilePath -> S.ByteString -> S.ByteString -> IO Bool -changeFile f k v = boolSystem "git" +changeFile :: FilePath -> ConfigKey -> S.ByteString -> IO Bool +changeFile f (ConfigKey k) v = boolSystem "git" [ Param "config" , Param "--file" , File f @@ -220,9 +220,9 @@ changeFile f k v = boolSystem "git" - If unsetting the config fails, including in a read-only repo, or - when the config is not set, returns Nothing. -} -unset :: S.ByteString -> Repo -> IO (Maybe Repo) -unset k r = ifM (Git.Command.runBool ps r) - ( return $ Just $ r { config = M.delete k (config r) } +unset :: ConfigKey -> Repo -> IO (Maybe Repo) +unset ck@(ConfigKey k) r = ifM (Git.Command.runBool ps r) + ( return $ Just $ r { config = M.delete ck (config r) } , return Nothing ) where diff --git a/Git/Construct.hs b/Git/Construct.hs index 44ae822e8b..3c907b5840 100644 --- a/Git/Construct.hs +++ b/Git/Construct.hs @@ -28,7 +28,6 @@ import System.Posix.User #endif import qualified Data.Map as M import Network.URI -import qualified Data.ByteString as S import Common import Git.Types @@ -139,7 +138,7 @@ remoteNamed n constructor = do {- Sets the name of a remote based on the git config key, such as - "remote.foo.url". -} -remoteNamedFromKey :: S.ByteString -> IO Repo -> IO Repo +remoteNamedFromKey :: ConfigKey -> IO Repo -> IO Repo remoteNamedFromKey = remoteNamed . remoteKeyToRemoteName {- Constructs a new Repo for one of a Repo's remotes using a given diff --git a/Git/GCrypt.hs b/Git/GCrypt.hs index 94c0b3794a..7b9b46d423 100644 --- a/Git/GCrypt.hs +++ b/Git/GCrypt.hs @@ -100,14 +100,15 @@ getParticiantList globalconfigrepo repo remotename = KeyIds $ parse $ firstJust parse (Just b) = words (decodeBS' b) parse Nothing = [] -remoteParticipantConfigKey :: RemoteName -> S.ByteString +remoteParticipantConfigKey :: RemoteName -> ConfigKey remoteParticipantConfigKey = remoteConfigKey "gcrypt-participants" -remotePublishParticipantConfigKey :: RemoteName -> S.ByteString +remotePublishParticipantConfigKey :: RemoteName -> ConfigKey remotePublishParticipantConfigKey = remoteConfigKey "gcrypt-publish-participants" -remoteSigningKey :: RemoteName -> S.ByteString +remoteSigningKey :: RemoteName -> ConfigKey remoteSigningKey = remoteConfigKey "gcrypt-signingkey" -remoteConfigKey :: S.ByteString -> RemoteName -> S.ByteString -remoteConfigKey key remotename = "remote." <> encodeBS' remotename <> "." <> key +remoteConfigKey :: S.ByteString -> RemoteName -> ConfigKey +remoteConfigKey key remotename = ConfigKey $ + "remote." <> encodeBS' remotename <> "." <> key diff --git a/Git/Remote.hs b/Git/Remote.hs index 7ffaf10fd8..08e67fd624 100644 --- a/Git/Remote.hs +++ b/Git/Remote.hs @@ -24,12 +24,13 @@ import Git.FilePath #endif {- Is a git config key one that specifies the location of a remote? -} -isRemoteKey :: S.ByteString -> Bool -isRemoteKey k = "remote." `S.isPrefixOf` k && ".url" `S.isSuffixOf` k +isRemoteKey :: ConfigKey -> Bool +isRemoteKey (ConfigKey k) = "remote." `S.isPrefixOf` k && ".url" `S.isSuffixOf` k {- Get a remote's name from the config key that specifies its location. -} -remoteKeyToRemoteName :: S.ByteString -> RemoteName -remoteKeyToRemoteName = decodeBS' . S.intercalate "." . dropFromEnd 1 . drop 1 . S8.split '.' +remoteKeyToRemoteName :: ConfigKey -> RemoteName +remoteKeyToRemoteName (ConfigKey k) = decodeBS' $ + S.intercalate "." $ dropFromEnd 1 $ drop 1 $ S8.split '.' k {- Construct a legal git remote name out of an arbitrary input string. - @@ -83,9 +84,9 @@ parseRemoteLocation s repo = ret $ calcloc s where replacement = decodeBS' $ S.drop (S.length prefix) $ S.take (S.length bestkey - S.length suffix) bestkey - (bestkey, bestvalue) = maximumBy longestvalue insteadofs + (ConfigKey bestkey, bestvalue) = maximumBy longestvalue insteadofs longestvalue (_, a) (_, b) = compare b a - insteadofs = filterconfig $ \(k, v) -> + insteadofs = filterconfig $ \(ConfigKey k, v) -> prefix `S.isPrefixOf` k && suffix `S.isSuffixOf` k && v `S.isPrefixOf` encodeBS l diff --git a/Git/Types.hs b/Git/Types.hs index 961df6eb52..c8688c625c 100644 --- a/Git/Types.hs +++ b/Git/Types.hs @@ -1,6 +1,6 @@ {- git data types - - - Copyright 2010-2018 Joey Hess + - Copyright 2010-2019 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -10,11 +10,12 @@ module Git.Types where import Network.URI +import Data.String import qualified Data.Map as M import qualified Data.ByteString as S import System.Posix.Types import Utility.SafeCommand - +import Utility.FileSystemEncoding {- Support repositories on local disk, and repositories accessed via an URL. - @@ -35,9 +36,9 @@ data RepoLocation data Repo = Repo { location :: RepoLocation - , config :: M.Map S.ByteString S.ByteString + , config :: M.Map ConfigKey S.ByteString -- a given git config key can actually have multiple values - , fullconfig :: M.Map S.ByteString [S.ByteString] + , fullconfig :: M.Map ConfigKey [S.ByteString] -- remoteName holds the name used for this repo in some other -- repo's list of remotes, when this repo is such a remote , remoteName :: Maybe RemoteName @@ -48,6 +49,18 @@ data Repo = Repo , gitGlobalOpts :: [CommandParam] } deriving (Show, Eq, Ord) +newtype ConfigKey = ConfigKey S.ByteString + deriving (Ord, Eq) + +fromConfigKey :: ConfigKey -> String +fromConfigKey (ConfigKey s) = decodeBS' s + +instance Show ConfigKey where + show = fromConfigKey + +instance IsString ConfigKey where + fromString = ConfigKey . encodeBS' + type RemoteName = String {- A git ref. Can be a sha1, or a branch or tag name. -} diff --git a/Remote.hs b/Remote.hs index 363876c29e..771e9b67ba 100644 --- a/Remote.hs +++ b/Remote.hs @@ -74,7 +74,7 @@ import Logs.Web import Remote.List import Config import Config.DynamicConfig -import Git.Types (RemoteName) +import Git.Types (RemoteName, ConfigKey(..)) import Utility.Aeson {- Map from UUIDs of Remotes to a calculated value. -} diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs index 931adce3b4..7fe83a0a5a 100644 --- a/Remote/GCrypt.hs +++ b/Remote/GCrypt.hs @@ -30,6 +30,7 @@ import Types.GitConfig import Types.Crypto import Types.Creds import Types.Transfer +import Git.Types (ConfigKey(..), fromConfigKey) import qualified Git import qualified Git.Command import qualified Git.Config @@ -99,7 +100,7 @@ gen baser u c gc rs = do (Just remotename, Just c') -> do setGcryptEncryption c' remotename storeUUIDIn (remoteConfig baser "uuid") u' - setConfig (ConfigKey $ Git.GCrypt.remoteConfigKey "gcrypt-id" remotename) gcryptid + setConfig (Git.GCrypt.remoteConfigKey "gcrypt-id" remotename) gcryptid gen' r u' c' gc rs _ -> do warning $ "not using unknown gcrypt repository pointed to by remote " ++ Git.repoDescribe r @@ -256,7 +257,7 @@ setupRepo gcryptid r | otherwise = localsetup r where localsetup r' = do - let setconfig k v = liftIO $ Git.Command.run [Param "config", Param (decodeBS' k), Param v] r' + let setconfig k v = liftIO $ Git.Command.run [Param "config", Param (fromConfigKey k), Param v] r' setconfig coreGCryptId gcryptid setconfig denyNonFastForwards (Git.Config.boolConfig False) return AccessDirect @@ -293,7 +294,7 @@ setupRepo gcryptid r (\f p -> liftIO (boolSystem f p), return False) "gcryptsetup" [ Param gcryptid ] [] - denyNonFastForwards = "receive.denyNonFastForwards" + denyNonFastForwards = ConfigKey "receive.denyNonFastForwards" accessShell :: Remote -> Bool accessShell = accessShellConfig . gitconfig @@ -330,7 +331,7 @@ setGcryptEncryption c remotename = do Nothing -> noop Just (KeyIds { keyIds = ks}) -> do setConfig participants (unwords ks) - let signingkey = ConfigKey $ Git.GCrypt.remoteSigningKey remotename + let signingkey = Git.GCrypt.remoteSigningKey remotename cmd <- gpgCmd <$> Annex.getGitConfig skeys <- M.keys <$> liftIO (secretKeys cmd) case filter (`elem` ks) skeys of @@ -339,7 +340,7 @@ setGcryptEncryption c remotename = do setConfig (remoteconfig Git.GCrypt.remotePublishParticipantConfigKey) (Git.Config.boolConfig True) where - remoteconfig n = ConfigKey $ n remotename + remoteconfig n = n remotename store :: Remote -> Remote.Rsync.RsyncOpts -> Storer store r rsyncopts k s p = do @@ -439,7 +440,7 @@ getGCryptUUID fast r = do (genUUIDInNameSpace gCryptNameSpace <$>) . fst <$> getGCryptId fast r dummycfg -coreGCryptId :: S.ByteString +coreGCryptId :: ConfigKey coreGCryptId = "core.gcrypt-id" {- gcrypt repos set up by git-annex as special remotes have a diff --git a/Remote/Git.hs b/Remote/Git.hs index a04e07cfdd..f4f2ddfcb1 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -88,7 +88,7 @@ list autoinit = do rs <- mapM (tweakurl c) =<< Annex.getGitRemotes mapM (configRead autoinit) rs where - annexurl n = "remote." <> encodeBS' n <> ".annexurl" + annexurl n = Git.ConfigKey ("remote." <> encodeBS' n <> ".annexurl") tweakurl c r = do let n = fromJust $ Git.remoteName r case M.lookup (annexurl n) c of diff --git a/Remote/GitLFS.hs b/Remote/GitLFS.hs index 73609026ab..624f90c3e7 100644 --- a/Remote/GitLFS.hs +++ b/Remote/GitLFS.hs @@ -155,7 +155,7 @@ mySetup _ mu _ c gc = do -- (so it's also usable by git as a non-special remote), -- and set remote.name.annex-git-lfs = true gitConfigSpecialRemote u c' [("git-lfs", "true")] - setConfig (ConfigKey ("remote." <> encodeBS' (getRemoteName c) <> ".url")) url + setConfig (Git.ConfigKey ("remote." <> encodeBS' (getRemoteName c) <> ".url")) url return (c', u) where url = fromMaybe (giveup "Specify url=") (M.lookup "url" c) @@ -187,8 +187,8 @@ configKnownUrl r set "config-uuid" (fromUUID cu) r' Nothing -> return r' set k v r' = do - let ck@(ConfigKey k') = remoteConfig r' k - setConfig ck v + let k' = remoteConfig r' k + setConfig k' v return $ Git.Config.store' k' (encodeBS' v) r' data LFSHandle = LFSHandle diff --git a/Remote/Helper/Special.hs b/Remote/Helper/Special.hs index 7f16ec579d..40934c6f08 100644 --- a/Remote/Helper/Special.hs +++ b/Remote/Helper/Special.hs @@ -53,6 +53,7 @@ import Annex.Content import Messages.Progress import qualified Git import qualified Git.Construct +import Git.Types import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L @@ -70,7 +71,9 @@ findSpecialRemotes s = do remotepairs = M.toList . M.filterWithKey match construct (k,_) = Git.Construct.remoteNamedFromKey k (pure Git.Construct.fromUnknown) - match k _ = "remote." `S.isPrefixOf` k && (".annex-" <> encodeBS' s) `S.isSuffixOf` k + match (ConfigKey k) _ = + "remote." `S.isPrefixOf` k + && (".annex-" <> encodeBS' s) `S.isSuffixOf` k {- Sets up configuration for a special remote in .git/config. -} gitConfigSpecialRemote :: UUID -> RemoteConfig -> [(String, String)] -> Annex () diff --git a/Test/Framework.hs b/Test/Framework.hs index 187b54ef0e..b02bcc384c 100644 --- a/Test/Framework.hs +++ b/Test/Framework.hs @@ -23,6 +23,7 @@ import qualified Types.RepoVersion import qualified Backend import qualified Git.CurrentRepo import qualified Git.Construct +import qualified Git.Types import qualified Types.KeySource import qualified Types.Backend import qualified Types @@ -89,7 +90,7 @@ inmainrepo a = do with_ssh_origin :: (Assertion -> Assertion) -> (Assertion -> Assertion) with_ssh_origin cloner a = cloner $ do origindir <- absPath . decodeBS' - =<< annexeval (Config.getConfig (Config.ConfigKey (encodeBS' config)) (toRawFilePath "/dev/null")) + =<< annexeval (Config.getConfig (Git.Types.ConfigKey (encodeBS' config)) (toRawFilePath "/dev/null")) let originurl = "localhost:" ++ origindir boolSystem "git" [Param "config", Param config, Param originurl] @? "git config failed" a diff --git a/Types/Difference.hs b/Types/Difference.hs index 678b6f4bf6..a974e332a5 100644 --- a/Types/Difference.hs +++ b/Types/Difference.hs @@ -22,6 +22,7 @@ module Types.Difference ( import Utility.PartialPrelude import qualified Git import qualified Git.Config +import Git.Types import Data.Maybe import Data.Monoid @@ -99,7 +100,7 @@ getDifferences r = mkDifferences $ S.fromList $ Just True -> Just d _ -> Nothing -differenceConfigKey :: Difference -> B.ByteString +differenceConfigKey :: Difference -> ConfigKey differenceConfigKey ObjectHashLower = tunable "objecthashlower" differenceConfigKey OneLevelObjectHash = tunable "objecthash1" differenceConfigKey OneLevelBranchHash = tunable "branchhash1" @@ -107,8 +108,8 @@ differenceConfigKey OneLevelBranchHash = tunable "branchhash1" differenceConfigVal :: Difference -> String differenceConfigVal _ = Git.Config.boolConfig True -tunable :: B.ByteString -> B.ByteString -tunable k = "annex.tune." <> k +tunable :: B.ByteString -> ConfigKey +tunable k = ConfigKey ("annex.tune." <> k) hasDifference :: Difference -> Differences -> Bool hasDifference _ UnknownDifferences = False diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs index ad058171af..73dd70cfcc 100644 --- a/Types/GitConfig.hs +++ b/Types/GitConfig.hs @@ -211,7 +211,7 @@ extractGitConfig r = GitConfig configurable d Nothing = DefaultConfig d configurable _ (Just v) = HasConfig v - annex k = "annex." <> k + annex k = ConfigKey $ "annex." <> k onemegabyte = 1000000 @@ -350,8 +350,9 @@ extractRemoteGitConfig r remotename = do (Git.Config.getMaybe (remotekey k) r) getoptions k = fromMaybe [] $ words <$> getmaybe k - key k = "annex." <> k - remotekey k = "remote." <> encodeBS' remotename <> ".annex-" <> k + key k = ConfigKey $ "annex." <> k + remotekey k = ConfigKey $ + "remote." <> encodeBS' remotename <> ".annex-" <> k notempty :: Maybe String -> Maybe String notempty Nothing = Nothing diff --git a/Upgrade/V5/Direct.hs b/Upgrade/V5/Direct.hs index c238101ff3..2e6ca9b0b4 100644 --- a/Upgrade/V5/Direct.hs +++ b/Upgrade/V5/Direct.hs @@ -46,7 +46,7 @@ setIndirect = do -- unset it when enabling direct mode, caching in -- core.indirect-worktree moveconfig indirectworktree coreworktree - setConfig (ConfigKey Git.Config.coreBare) val + setConfig Git.Config.coreBare val moveconfig src dest = getConfigMaybe src >>= \case Nothing -> noop Just wt -> do diff --git a/git-annex.hs b/git-annex.hs index 30c12995a1..4992f4c76e 100644 --- a/git-annex.hs +++ b/git-annex.hs @@ -12,7 +12,7 @@ import System.FilePath import Network.Socket (withSocketsDo) import qualified CmdLine.GitAnnex ---import qualified CmdLine.GitAnnexShell +import qualified CmdLine.GitAnnexShell import qualified CmdLine.GitRemoteTorAnnex import qualified Test import qualified Benchmark @@ -33,7 +33,7 @@ main = withSocketsDo $ do run ps =<< getProgName where run ps n = case takeFileName n of - "git-annex-shell" -> error "STUBBED OUT FIXME" -- CmdLine.GitAnnexShell.run ps + "git-annex-shell" -> CmdLine.GitAnnexShell.run ps "git-remote-tor-annex" -> CmdLine.GitRemoteTorAnnex.run ps _ -> CmdLine.GitAnnex.run Test.optParser Test.runner Benchmark.mkGenerator ps From 1100e0d3c92f73445816a670a0ab55f8c556c0a6 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 2 Dec 2019 12:01:20 -0400 Subject: [PATCH 09/42] include upgrade code back in Remaining things that need to be fixed up to get this branch into a basically mergeable state: remotes, commands, and the assistant --- Upgrade.hs | 5 ----- Upgrade/V1.hs | 4 ++-- Upgrade/V2.hs | 6 +++--- Upgrade/V5.hs | 10 ++++++---- 4 files changed, 11 insertions(+), 14 deletions(-) diff --git a/Upgrade.hs b/Upgrade.hs index fed76d838e..457fab180b 100644 --- a/Upgrade.hs +++ b/Upgrade.hs @@ -15,7 +15,6 @@ import qualified Git import Annex.Version import Types.RepoVersion #ifndef mingw32_HOST_OS -{- import qualified Upgrade.V0 import qualified Upgrade.V1 #endif @@ -24,7 +23,6 @@ import qualified Upgrade.V3 import qualified Upgrade.V4 import qualified Upgrade.V5 import qualified Upgrade.V6 --} import qualified Data.Map as M @@ -74,7 +72,6 @@ upgrade automatic destversion = do ) go _ = return True -{- #ifndef mingw32_HOST_OS up (RepoVersion 0) = Upgrade.V0.upgrade up (RepoVersion 1) = Upgrade.V1.upgrade @@ -87,6 +84,4 @@ upgrade automatic destversion = do up (RepoVersion 4) = Upgrade.V4.upgrade automatic up (RepoVersion 5) = Upgrade.V5.upgrade automatic up (RepoVersion 6) = Upgrade.V6.upgrade automatic --} up _ = return True - diff --git a/Upgrade/V1.hs b/Upgrade/V1.hs index 0d41dde2a5..fd46108dd5 100644 --- a/Upgrade/V1.hs +++ b/Upgrade/V1.hs @@ -84,8 +84,8 @@ updateSymlinks :: Annex () updateSymlinks = do showAction "updating symlinks" top <- fromRepo Git.repoPath - (files, cleanup) <- inRepo $ LsFiles.inRepo [top] - forM_ files fixlink + (files, cleanup) <- inRepo $ LsFiles.inRepo [toRawFilePath top] + forM_ files (fixlink . fromRawFilePath) void $ liftIO cleanup where fixlink f = do diff --git a/Upgrade/V2.hs b/Upgrade/V2.hs index ffac8e49aa..9b29783e9d 100644 --- a/Upgrade/V2.hs +++ b/Upgrade/V2.hs @@ -50,7 +50,7 @@ upgrade = do e <- liftIO $ doesDirectoryExist old when e $ do config <- Annex.getGitConfig - mapM_ (\(k, f) -> inject f $ locationLogFile config k) =<< locationLogs + mapM_ (\(k, f) -> inject f $ fromRawFilePath $ locationLogFile config k) =<< locationLogs mapM_ (\f -> inject f f) =<< logFiles old saveState False @@ -76,13 +76,13 @@ locationLogs = do where tryDirContents d = catchDefaultIO [] $ dirContents d islogfile f = maybe Nothing (\k -> Just (k, f)) $ - locationLogFileKey f + locationLogFileKey (toRawFilePath f) inject :: FilePath -> FilePath -> Annex () inject source dest = do old <- fromRepo olddir new <- liftIO (readFile $ old source) - Annex.Branch.change dest $ \prev -> + Annex.Branch.change (toRawFilePath dest) $ \prev -> encodeBL $ unlines $ nub $ lines (decodeBL prev) ++ lines new logFiles :: FilePath -> Annex [FilePath] diff --git a/Upgrade/V5.hs b/Upgrade/V5.hs index 5d331c8787..ba897399f2 100644 --- a/Upgrade/V5.hs +++ b/Upgrade/V5.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Upgrade.V5 where import Annex.Common @@ -106,7 +108,7 @@ convertDirect = do upgradeDirectWorkTree :: Annex () upgradeDirectWorkTree = do top <- fromRepo Git.repoPath - (l, clean) <- inRepo $ Git.LsFiles.stagedDetails [top] + (l, clean) <- inRepo $ Git.LsFiles.stagedDetails [toRawFilePath top] forM_ l go void $ liftIO clean where @@ -119,11 +121,11 @@ upgradeDirectWorkTree = do Just k -> do stagePointerFile f Nothing =<< hashPointerFile k ifM (isJust <$> getAnnexLinkTarget f) - ( writepointer f k - , fromdirect f k + ( writepointer (fromRawFilePath f) k + , fromdirect (fromRawFilePath f) k ) Database.Keys.addAssociatedFile k - =<< inRepo (toTopFilePath f) + =<< inRepo (toTopFilePath (fromRawFilePath f)) go _ = noop fromdirect f k = ifM (Direct.goodContent k f) From 650a631ef849b286ebafe5f27599f32b28b639a8 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 2 Dec 2019 12:26:33 -0400 Subject: [PATCH 10/42] include all remotes back in --- Remote/Adb.hs | 4 ++-- Remote/Bup.hs | 12 +++++++----- Remote/External.hs | 2 ++ Remote/External/Types.hs | 8 ++++---- Remote/Hook.hs | 11 ++++++----- Remote/List.hs | 6 ------ Remote/S3.hs | 6 ++++-- Remote/WebDAV.hs | 2 +- Remote/WebDAV/DavLocation.hs | 7 +++++-- 9 files changed, 31 insertions(+), 27 deletions(-) diff --git a/Remote/Adb.hs b/Remote/Adb.hs index 50e708826a..03e3819cff 100644 --- a/Remote/Adb.hs +++ b/Remote/Adb.hs @@ -269,7 +269,7 @@ listImportableContentsM serial adir = liftIO $ let (stat, fn) = separate (== '\t') l sz = fromMaybe 0 (readish (takeWhile (/= ' ') stat)) cid = ContentIdentifier (encodeBS' stat) - loc = mkImportLocation $ + loc = mkImportLocation $ toRawFilePath $ Posix.makeRelative (fromAndroidPath adir) fn in Just (loc, (cid, sz)) mk _ = Nothing @@ -331,7 +331,7 @@ checkPresentExportWithContentIdentifierM serial adir _k loc knowncids = androidExportLocation :: AndroidPath -> ExportLocation -> AndroidPath androidExportLocation adir loc = AndroidPath $ - fromAndroidPath adir ++ "/" ++ fromExportLocation loc + fromAndroidPath adir ++ "/" ++ fromRawFilePath (fromExportLocation loc) -- | List all connected Android devices. enumerateAdbConnected :: IO [AndroidSerial] diff --git a/Remote/Bup.hs b/Remote/Bup.hs index ba06939c8e..dfce6a188d 100644 --- a/Remote/Bup.hs +++ b/Remote/Bup.hs @@ -1,6 +1,6 @@ {- Using bup as a remote. - - - Copyright 2011-2014 Joey Hess + - Copyright 2011-2019 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -8,6 +8,7 @@ module Remote.Bup (remote) where import qualified Data.Map as M +import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import Data.ByteString.Lazy.UTF8 (fromString) @@ -15,6 +16,7 @@ import Annex.Common import qualified Annex import Types.Remote import Types.Creds +import Git.Types (fromConfigKey) import qualified Git import qualified Git.Command import qualified Git.Config @@ -207,12 +209,12 @@ storeBupUUID u buprepo = do then do showAction "storing uuid" unlessM (onBupRemote r boolSystem "git" - [Param "config", Param "annex.uuid", Param v]) $ + [Param "config", Param (fromConfigKey configkeyUUID), Param v]) $ giveup "ssh failed" else liftIO $ do r' <- Git.Config.read r - let olduuid = Git.Config.get "annex.uuid" "" r' - when (olduuid == "") $ + let olduuid = Git.Config.get configkeyUUID mempty r' + when (S.null olduuid) $ Git.Command.run [ Param "config" , Param "annex.uuid" @@ -248,7 +250,7 @@ getBupUUID r u | otherwise = liftIO $ do ret <- tryIO $ Git.Config.read r case ret of - Right r' -> return (toUUID $ Git.Config.get "annex.uuid" "" r', r') + Right r' -> return (toUUID $ Git.Config.get configkeyUUID mempty r', r') Left _ -> return (NoUUID, r) {- Converts a bup remote path spec into a Git.Repo. There are some diff --git a/Remote/External.hs b/Remote/External.hs index 09af889e93..c172bc71cd 100644 --- a/Remote/External.hs +++ b/Remote/External.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Remote.External (remote) where import Remote.External.Types diff --git a/Remote/External/Types.hs b/Remote/External/Types.hs index 7592764117..b9785cb140 100644 --- a/Remote/External/Types.hs +++ b/Remote/External/Types.hs @@ -384,12 +384,12 @@ instance Proto.Serializable URI where deserialize = parseURI instance Proto.Serializable ExportLocation where - serialize = fromExportLocation - deserialize = Just . mkExportLocation + serialize = fromRawFilePath . fromExportLocation + deserialize = Just . mkExportLocation . toRawFilePath instance Proto.Serializable ExportDirectory where - serialize = fromExportDirectory - deserialize = Just . mkExportDirectory + serialize = fromRawFilePath . fromExportDirectory + deserialize = Just . mkExportDirectory . toRawFilePath instance Proto.Serializable ExtensionList where serialize (ExtensionList l) = unwords l diff --git a/Remote/Hook.hs b/Remote/Hook.hs index 83c5e8ebc0..1cc426f466 100644 --- a/Remote/Hook.hs +++ b/Remote/Hook.hs @@ -11,6 +11,7 @@ import Annex.Common import Types.Remote import Types.Creds import qualified Git +import Git.Types (fromConfigKey) import Config import Config.Cost import Annex.UUID @@ -107,19 +108,19 @@ hookEnv action k f = Just <$> mergeenv (fileenv f ++ keyenv) lookupHook :: HookName -> Action -> Annex (Maybe String) lookupHook hookname action = do - command <- getConfig (annexConfig hook) "" + command <- decodeBS' <$> getConfig hook mempty if null command then do - fallback <- getConfig (annexConfig hookfallback) "" + fallback <- decodeBS' <$> getConfig hookfallback mempty if null fallback then do - warning $ "missing configuration for " ++ hook ++ " or " ++ hookfallback + warning $ "missing configuration for " ++ fromConfigKey hook ++ " or " ++ fromConfigKey hookfallback return Nothing else return $ Just fallback else return $ Just command where - hook = hookname ++ "-" ++ action ++ "-hook" - hookfallback = hookname ++ "-hook" + hook = annexConfig $ encodeBS' $ hookname ++ "-" ++ action ++ "-hook" + hookfallback = annexConfig $ encodeBS' $ hookname ++ "-hook" runHook :: HookName -> Action -> Key -> Maybe FilePath -> Annex Bool -> Annex Bool runHook hook action k f a = maybe (return False) run =<< lookupHook hook action diff --git a/Remote/List.hs b/Remote/List.hs index 49e2710148..3e7ca9fa73 100644 --- a/Remote/List.hs +++ b/Remote/List.hs @@ -24,7 +24,6 @@ import qualified Git import qualified Git.Config import qualified Remote.Git -{- import qualified Remote.GCrypt import qualified Remote.P2P #ifdef WITH_S3 @@ -45,12 +44,10 @@ import qualified Remote.Ddar import qualified Remote.GitLFS import qualified Remote.Hook import qualified Remote.External --} remoteTypes :: [RemoteType] remoteTypes = map adjustExportImportRemoteType [ Remote.Git.remote -{- , Remote.GCrypt.remote , Remote.P2P.remote #ifdef WITH_S3 @@ -71,7 +68,6 @@ remoteTypes = map adjustExportImportRemoteType , Remote.GitLFS.remote , Remote.Hook.remote , Remote.External.remote --} ] {- Builds a list of all available Remotes. @@ -133,9 +129,7 @@ updateRemote remote = do gitSyncableRemote :: Remote -> Bool gitSyncableRemote r = remotetype r `elem` [ Remote.Git.remote -{- , Remote.GCrypt.remote , Remote.P2P.remote , Remote.GitLFS.remote --} ] diff --git a/Remote/S3.hs b/Remote/S3.hs index cd0a3c205e..55d0b85fde 100644 --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -881,7 +881,8 @@ getBucketObject c = munge . serializeKey _ -> getFilePrefix c ++ s getBucketExportLocation :: RemoteConfig -> ExportLocation -> BucketObject -getBucketExportLocation c loc = getFilePrefix c ++ fromExportLocation loc +getBucketExportLocation c loc = + getFilePrefix c ++ fromRawFilePath (fromExportLocation loc) getBucketImportLocation :: RemoteConfig -> BucketObject -> Maybe ImportLocation getBucketImportLocation c obj @@ -889,7 +890,8 @@ getBucketImportLocation c obj | obj == uuidfile = Nothing -- Only import files that are under the fileprefix, when -- one is configured. - | prefix `isPrefixOf` obj = Just $ mkImportLocation $ drop prefixlen obj + | prefix `isPrefixOf` obj = Just $ mkImportLocation $ + toRawFilePath $ drop prefixlen obj | otherwise = Nothing where prefix = getFilePrefix c diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs index 9204495317..08c3d528cc 100644 --- a/Remote/WebDAV.hs +++ b/Remote/WebDAV.hs @@ -229,7 +229,7 @@ removeExportDav r _k loc = case exportLocation loc of removeExportDirectoryDav :: Remote -> ExportDirectory -> Annex Bool removeExportDirectoryDav r dir = withDAVHandle r $ \mh -> runExport mh $ \_dav -> do - let d = fromExportDirectory dir + let d = fromRawFilePath $ fromExportDirectory dir debugDav $ "delContent " ++ d safely (inLocation d delContentM) >>= maybe (return False) (const $ return True) diff --git a/Remote/WebDAV/DavLocation.hs b/Remote/WebDAV/DavLocation.hs index 2f78923be5..4464ed2d36 100644 --- a/Remote/WebDAV/DavLocation.hs +++ b/Remote/WebDAV/DavLocation.hs @@ -17,6 +17,7 @@ import Utility.Url (URLString) #ifdef mingw32_HOST_OS import Utility.Split #endif +import Utility.FileSystemEncoding import System.FilePath.Posix -- for manipulating url paths import Network.Protocol.HTTP.DAV (inDAVLocation, DAVT) @@ -50,10 +51,12 @@ keyLocation k = keyDir k ++ keyFile k - those. -} exportLocation :: ExportLocation -> Either String DavLocation exportLocation l = - let p = fromExportLocation l - in if any (`elem` p) ['#', '?'] + let p = fromRawFilePath $ fromExportLocation l + in if any (`elem` p) illegalinurl then Left ("Cannot store file containing '#' or '?' on webdav: " ++ p) else Right p + where + illegalinurl = ['#', '?'] :: [Char] {- Where we store temporary data for a key as it's being uploaded. -} keyTmpLocation :: Key -> DavLocation From b88f89c1ef230419c8abe1957dde744354485ce3 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 4 Dec 2019 13:15:34 -0400 Subject: [PATCH 11/42] 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. From 6535aea49a402b9ca08fc1070358374e5e0eb618 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 4 Dec 2019 14:14:35 -0400 Subject: [PATCH 12/42] optimisation This was already optimised before, but profiling found that delEntry was around 1.5% of the total runtime of git-annex whereis. It was being called once per environment variable per file processed. Fixed by better caching. Since withIndexFile is almost always run with the same .git/annex/index file, it can cache the modified environment, rather than re-modifying it each time called. --- Annex.hs | 2 +- Annex/GitOverlay.hs | 30 +++++++++++++++--------------- 2 files changed, 16 insertions(+), 16 deletions(-) diff --git a/Annex.hs b/Annex.hs index 9eb4c5f391..b35836ffb3 100644 --- a/Annex.hs +++ b/Annex.hs @@ -147,7 +147,7 @@ data AnnexState = AnnexState , activeremotes :: MVar (M.Map (Types.Remote.RemoteA Annex) Integer) , keysdbhandle :: Maybe Keys.DbHandle , cachedcurrentbranch :: (Maybe (Maybe Git.Branch, Maybe Adjustment)) - , cachedgitenv :: Maybe [(String, String)] + , cachedgitenv :: Maybe (FilePath, [(String, String)]) , urloptions :: Maybe UrlOptions } diff --git a/Annex/GitOverlay.hs b/Annex/GitOverlay.hs index de355217d2..0b3e9c2b88 100644 --- a/Annex/GitOverlay.hs +++ b/Annex/GitOverlay.hs @@ -14,7 +14,6 @@ import Git import Git.Types import Git.Index import Git.Env -import Utility.Env import qualified Annex import qualified Annex.Queue @@ -23,28 +22,29 @@ withIndexFile :: FilePath -> Annex a -> Annex a withIndexFile f a = do f' <- liftIO $ indexEnvVal f withAltRepo - (usecachedgitenv $ \g -> liftIO $ addGitEnv g indexEnv f') + (usecachedgitenv f' $ \g -> addGitEnv g indexEnv f') (\g g' -> g' { gitEnv = gitEnv g }) a where -- This is an optimisation. Since withIndexFile is run repeatedly, - -- and addGitEnv uses the slow getEnvironment when gitEnv is Nothing, - -- we cache the environment the first time, and reuse it in - -- subsequent calls. + -- typically with the same file, and addGitEnv uses the slow + -- getEnvironment when gitEnv is Nothing, and has to do a + -- nontrivial amount of work, we cache the modified environment + -- the first time, and reuse it in subsequent calls for the same + -- index file. -- -- (This could be done at another level; eg when creating the -- Git object in the first place, but it's more efficient to let - -- the enviroment be inherited in all calls to git where it + -- the environment be inherited in all calls to git where it -- does not need to be modified.) - usecachedgitenv m g = case gitEnv g of - Just _ -> m g - Nothing -> do - e <- Annex.withState $ \s -> case Annex.cachedgitenv s of - Nothing -> do - e <- getEnvironment - return (s { Annex.cachedgitenv = Just e }, e) - Just e -> return (s, e) - m (g { gitEnv = Just e }) + usecachedgitenv f' m g = case gitEnv g of + Just _ -> liftIO $ m g + Nothing -> Annex.withState $ \s -> case Annex.cachedgitenv s of + Just (cachedf, cachede) | f' == cachedf -> + return (s, g { gitEnv = Just cachede }) + _ -> do + g' <- m g + return (s { Annex.cachedgitenv = (,) <$> Just f' <*> gitEnv g' }, g') {- Runs an action using a different git work tree. - From 3c7fd09ec820bae90dcc783b2533a2915a9caf8c Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 5 Dec 2019 11:40:10 -0400 Subject: [PATCH 13/42] get many more commands building again about half are building now --- CmdLine/GitAnnex.hs | 20 +++++++++----------- Command/EnableRemote.hs | 2 ++ Command/ExamineKey.hs | 2 +- Command/Find.hs | 3 ++- Command/Fix.hs | 17 +++++++++-------- Command/FromKey.hs | 6 +++--- Command/InitRemote.hs | 2 ++ Command/Lock.hs | 22 +++++++++++----------- Command/LookupKey.hs | 7 ++++--- Command/MetaData.hs | 10 +++++----- Command/Multicast.hs | 2 +- Command/PreCommit.hs | 4 ++-- Command/ReKey.hs | 32 ++++++++++++++++---------------- Command/Smudge.hs | 14 +++++++------- Command/TransferKeys.hs | 4 ++-- Command/Unlock.hs | 15 ++++++++------- Command/Unused.hs | 11 ++++++----- Command/View.hs | 5 +++-- Git/Repair.hs | 14 +++++++------- 19 files changed, 100 insertions(+), 92 deletions(-) diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs index fd1953faf2..daef02d85f 100644 --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -20,15 +20,12 @@ 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 @@ -51,9 +48,7 @@ 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 @@ -70,6 +65,7 @@ import qualified Command.AddUnused import qualified Command.Unlock import qualified Command.Lock import qualified Command.PreCommit +{- import qualified Command.PostReceive -} import qualified Command.Find @@ -120,7 +116,9 @@ import qualified Command.Forget import qualified Command.P2P import qualified Command.Proxy import qualified Command.DiffDriver +-} import qualified Command.Smudge +{- import qualified Command.Undo import qualified Command.Version import qualified Command.RemoteDaemon @@ -146,11 +144,9 @@ cmds testoptparser testrunner mkbenchmarkgenerator = , Command.Move.cmd , Command.Copy.cmd , Command.Fsck.cmd -{- , Command.Unlock.cmd , Command.Unlock.editcmd , Command.Lock.cmd --} , Command.Sync.cmd {- , Command.Mirror.cmd @@ -160,7 +156,6 @@ cmds testoptparser testrunner mkbenchmarkgenerator = -} , Command.Import.cmd , Command.Export.cmd -{- , Command.Init.cmd , Command.Describe.cmd , Command.InitRemote.cmd @@ -168,13 +163,14 @@ 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 +-} , Command.PreCommit.cmd +{- , Command.PostReceive.cmd , Command.NumCopies.cmd , Command.Trust.cmd @@ -189,6 +185,7 @@ cmds testoptparser testrunner mkbenchmarkgenerator = , Command.Ungroup.cmd , Command.Config.cmd , Command.Vicfg.cmd +-} , Command.LookupKey.cmd , Command.CalcKey.cmd , Command.ContentLocation.cmd @@ -217,7 +214,6 @@ cmds testoptparser testrunner mkbenchmarkgenerator = , Command.Unused.cmd , Command.DropUnused.cmd , Command.AddUnused.cmd --} , Command.Find.cmd {- , Command.FindRef.cmd @@ -240,7 +236,9 @@ cmds testoptparser testrunner mkbenchmarkgenerator = , Command.P2P.cmd , Command.Proxy.cmd , Command.DiffDriver.cmd +-} , Command.Smudge.cmd +{- , Command.Undo.cmd , Command.Version.cmd , Command.RemoteDaemon.cmd diff --git a/Command/EnableRemote.hs b/Command/EnableRemote.hs index 8cf86ea5ed..f43ab68f8b 100644 --- a/Command/EnableRemote.hs +++ b/Command/EnableRemote.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Command.EnableRemote where import Command diff --git a/Command/ExamineKey.hs b/Command/ExamineKey.hs index 9cb8defb9c..040fd15f32 100644 --- a/Command/ExamineKey.hs +++ b/Command/ExamineKey.hs @@ -22,5 +22,5 @@ cmd = noCommit $ noMessages $ dontCheck repoExists $ run :: Maybe Utility.Format.Format -> String -> Annex Bool run format p = do let k = fromMaybe (giveup "bad key") $ deserializeKey p - showFormatted format (serializeKey k) (keyVars k) + showFormatted format (serializeKey' k) (keyVars k) return True diff --git a/Command/Find.hs b/Command/Find.hs index 06dcd86fd7..9ed9583c6b 100644 --- a/Command/Find.hs +++ b/Command/Find.hs @@ -9,6 +9,7 @@ module Command.Find where import Data.Default import qualified Data.Map as M +import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import Command @@ -76,7 +77,7 @@ startKeys o (key, ActionItemBranchFilePath (BranchFilePath _ topf) _) = start o (toRawFilePath (getTopFilePath topf)) key startKeys _ _ = stop -showFormatted :: Maybe Utility.Format.Format -> RawFilePath -> [(String, String)] -> Annex () +showFormatted :: Maybe Utility.Format.Format -> S.ByteString -> [(String, String)] -> Annex () showFormatted format unformatted vars = unlessM (showFullJSON $ JSONChunk vars) $ case format of diff --git a/Command/Fix.hs b/Command/Fix.hs index c3f818b01b..537a66f6d3 100644 --- a/Command/Fix.hs +++ b/Command/Fix.hs @@ -37,13 +37,14 @@ seek ps = unlessM crippledFileSystem $ do data FixWhat = FixSymlinks | FixAll -start :: FixWhat -> FilePath -> Key -> CommandStart +start :: FixWhat -> RawFilePath -> Key -> CommandStart start fixwhat file key = do - currlink <- liftIO $ catchMaybeIO $ readSymbolicLink file - wantlink <- calcRepo $ gitAnnexLink file key + currlink <- liftIO $ catchMaybeIO $ readSymbolicLink $ fromRawFilePath file + wantlink <- calcRepo $ gitAnnexLink (fromRawFilePath file) key case currlink of Just l - | l /= wantlink -> fixby $ fixSymlink file wantlink + | l /= wantlink -> fixby $ + fixSymlink (fromRawFilePath file) wantlink | otherwise -> stop Nothing -> case fixwhat of FixAll -> fixthin @@ -52,15 +53,15 @@ start fixwhat file key = do fixby = starting "fix" (mkActionItem (key, file)) fixthin = do obj <- calcRepo $ gitAnnexLocation key - stopUnless (isUnmodified key file <&&> isUnmodified key obj) $ do + stopUnless (isUnmodified key (fromRawFilePath file) <&&> isUnmodified key obj) $ do thin <- annexThin <$> Annex.getGitConfig - fs <- liftIO $ catchMaybeIO $ getFileStatus file + fs <- liftIO $ catchMaybeIO $ getFileStatus (fromRawFilePath file) os <- liftIO $ catchMaybeIO $ getFileStatus obj case (linkCount <$> fs, linkCount <$> os, thin) of (Just 1, Just 1, True) -> - fixby $ makeHardLink file key + fixby $ makeHardLink (fromRawFilePath file) key (Just n, Just n', False) | n > 1 && n == n' -> - fixby $ breakHardLink file key obj + fixby $ breakHardLink (fromRawFilePath file) key obj _ -> stop breakHardLink :: FilePath -> Key -> FilePath -> CommandPerform diff --git a/Command/FromKey.hs b/Command/FromKey.hs index 45b37f94d9..f3e7487272 100644 --- a/Command/FromKey.hs +++ b/Command/FromKey.hs @@ -51,7 +51,7 @@ seekBatch fmt = batchInput fmt parse commandAction in if not (null keyname) && not (null file) then Right $ go file (keyOpt keyname) else Left "Expected pairs of key and filename" - go file key = starting "fromkey" (mkActionItem (key, file)) $ + go file key = starting "fromkey" (mkActionItem (key, toRawFilePath file)) $ perform key file start :: Bool -> (String, FilePath) -> CommandStart @@ -61,7 +61,7 @@ start force (keyname, file) = do inbackend <- inAnnex key unless inbackend $ giveup $ "key ("++ keyname ++") is not present in backend (use --force to override this sanity check)" - starting "fromkey" (mkActionItem (key, file)) $ + starting "fromkey" (mkActionItem (key, toRawFilePath file)) $ perform key file -- From user input to a Key. @@ -80,7 +80,7 @@ keyOpt s = case parseURI s of Nothing -> giveup $ "bad key/url " ++ s perform :: Key -> FilePath -> CommandPerform -perform key file = lookupFileNotHidden file >>= \case +perform key file = lookupFileNotHidden (toRawFilePath file) >>= \case Nothing -> ifM (liftIO $ doesFileExist file) ( hasothercontent , do diff --git a/Command/InitRemote.hs b/Command/InitRemote.hs index 00ba46dc90..09aee869dc 100644 --- a/Command/InitRemote.hs +++ b/Command/InitRemote.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Command.InitRemote where import qualified Data.Map as M diff --git a/Command/Lock.hs b/Command/Lock.hs index 2f2eab21b4..cb104225f6 100644 --- a/Command/Lock.hs +++ b/Command/Lock.hs @@ -32,7 +32,7 @@ seek ps = do l <- workTreeItems ps withFilesInGit (commandAction . (whenAnnexed startNew)) l -startNew :: FilePath -> Key -> CommandStart +startNew :: RawFilePath -> Key -> CommandStart startNew file key = ifM (isJust <$> isAnnexLink file) ( stop , starting "lock" (mkActionItem (key, file)) $ @@ -43,7 +43,7 @@ startNew file key = ifM (isJust <$> isAnnexLink file) | key' == key = cont | otherwise = errorModified go Nothing = - ifM (isUnmodified key file) + ifM (isUnmodified key (fromRawFilePath file)) ( cont , ifM (Annex.getState Annex.force) ( cont @@ -52,11 +52,11 @@ startNew file key = ifM (isJust <$> isAnnexLink file) ) cont = performNew file key -performNew :: FilePath -> Key -> CommandPerform +performNew :: RawFilePath -> Key -> CommandPerform performNew file key = do lockdown =<< calcRepo (gitAnnexLocation key) - addLink file key - =<< withTSDelta (liftIO . genInodeCache file) + addLink (fromRawFilePath file) key + =<< withTSDelta (liftIO . genInodeCache (fromRawFilePath file)) next $ cleanupNew file key where lockdown obj = do @@ -70,7 +70,7 @@ performNew file key = do -- It's ok if the file is hard linked to obj, but if some other -- associated file is, we need to break that link to lock down obj. breakhardlink obj = whenM (catchBoolIO $ (> 1) . linkCount <$> liftIO (getFileStatus obj)) $ do - mfc <- withTSDelta (liftIO . genInodeCache file) + mfc <- withTSDelta (liftIO . genInodeCache (fromRawFilePath file)) unlessM (sameInodeCache obj (maybeToList mfc)) $ do modifyContent obj $ replaceFile obj $ \tmp -> do unlessM (checkedCopyFile key obj tmp Nothing) $ @@ -92,21 +92,21 @@ performNew file key = do lostcontent = logStatus key InfoMissing -cleanupNew :: FilePath -> Key -> CommandCleanup +cleanupNew :: RawFilePath -> Key -> CommandCleanup cleanupNew file key = do - Database.Keys.removeAssociatedFile key =<< inRepo (toTopFilePath file) + Database.Keys.removeAssociatedFile key =<< inRepo (toTopFilePath (fromRawFilePath file)) return True -startOld :: FilePath -> CommandStart +startOld :: RawFilePath -> CommandStart startOld file = do unlessM (Annex.getState Annex.force) errorModified starting "lock" (ActionItemWorkTreeFile file) $ performOld file -performOld :: FilePath -> CommandPerform +performOld :: RawFilePath -> CommandPerform performOld file = do - Annex.Queue.addCommand "checkout" [Param "--"] [file] + Annex.Queue.addCommand "checkout" [Param "--"] [fromRawFilePath file] next $ return True errorModified :: a diff --git a/Command/LookupKey.hs b/Command/LookupKey.hs index 11fa0c9461..1525046f2d 100644 --- a/Command/LookupKey.hs +++ b/Command/LookupKey.hs @@ -29,11 +29,12 @@ run _ file = seekSingleGitFile file >>= \case -- To support absolute filenames, pass through git ls-files. -- But, this plumbing command does not recurse through directories. -seekSingleGitFile :: FilePath -> Annex (Maybe FilePath) +seekSingleGitFile :: FilePath -> Annex (Maybe RawFilePath) seekSingleGitFile file = do - (l, cleanup) <- inRepo (Git.LsFiles.inRepo [file]) + (l, cleanup) <- inRepo (Git.LsFiles.inRepo [toRawFilePath file]) r <- case l of - (f:[]) | takeFileName f == takeFileName file -> return (Just f) + (f:[]) | takeFileName (fromRawFilePath f) == takeFileName file -> + return (Just f) _ -> return Nothing void $ liftIO cleanup return r diff --git a/Command/MetaData.hs b/Command/MetaData.hs index d1c7e50607..e0b86e5302 100644 --- a/Command/MetaData.hs +++ b/Command/MetaData.hs @@ -92,7 +92,7 @@ seek o = case batchOption o of ) _ -> giveup "--batch is currently only supported in --json mode" -start :: VectorClock -> MetaDataOptions -> FilePath -> Key -> CommandStart +start :: VectorClock -> MetaDataOptions -> RawFilePath -> Key -> CommandStart start c o file k = startKeys c o (k, mkActionItem (k, afile)) where afile = AssociatedFile (Just file) @@ -147,7 +147,7 @@ instance FromJSON MetaDataFields where fieldsField :: T.Text fieldsField = T.pack "fields" -parseJSONInput :: String -> Either String (Either FilePath Key, MetaData) +parseJSONInput :: String -> Either String (Either RawFilePath Key, MetaData) parseJSONInput i = do v <- eitherDecode (BU.fromString i) let m = case itemAdded v of @@ -155,16 +155,16 @@ parseJSONInput i = do Just (MetaDataFields m') -> m' case (itemKey v, itemFile v) of (Just k, _) -> Right (Right k, m) - (Nothing, Just f) -> Right (Left f, m) + (Nothing, Just f) -> Right (Left (toRawFilePath f), m) (Nothing, Nothing) -> Left "JSON input is missing either file or key" -startBatch :: (Either FilePath Key, MetaData) -> CommandStart +startBatch :: (Either RawFilePath Key, MetaData) -> CommandStart startBatch (i, (MetaData m)) = case i of Left f -> do mk <- lookupFile f case mk of Just k -> go k (mkActionItem (k, AssociatedFile (Just f))) - Nothing -> giveup $ "not an annexed file: " ++ f + Nothing -> giveup $ "not an annexed file: " ++ fromRawFilePath f Right k -> go k (mkActionItem k) where go k ai = starting "metadata" ai $ do diff --git a/Command/Multicast.hs b/Command/Multicast.hs index 6c6d2c418b..97966984a1 100644 --- a/Command/Multicast.hs +++ b/Command/Multicast.hs @@ -137,7 +137,7 @@ send ups fs = do mk <- lookupFile f case mk of Nothing -> noop - Just k -> withObjectLoc k (addlist f) + Just k -> withObjectLoc k (addlist (fromRawFilePath f)) liftIO $ hClose h serverkey <- uftpKey diff --git a/Command/PreCommit.hs b/Command/PreCommit.hs index 8c366ec14b..ad39953e3c 100644 --- a/Command/PreCommit.hs +++ b/Command/PreCommit.hs @@ -53,11 +53,11 @@ seek ps = lockPreCommitHook $ do (removeViewMetaData v) addViewMetaData :: View -> ViewedFile -> Key -> CommandStart -addViewMetaData v f k = starting "metadata" (mkActionItem (k, f)) $ +addViewMetaData v f k = starting "metadata" (mkActionItem (k, toRawFilePath f)) $ next $ changeMetaData k $ fromView v f removeViewMetaData :: View -> ViewedFile -> Key -> CommandStart -removeViewMetaData v f k = starting "metadata" (mkActionItem (k, f)) $ +removeViewMetaData v f k = starting "metadata" (mkActionItem (k, toRawFilePath f)) $ next $ changeMetaData k $ unsetMetaData $ fromView v f changeMetaData :: Key -> MetaData -> CommandCleanup diff --git a/Command/ReKey.hs b/Command/ReKey.hs index 6670298ae5..b9eac59232 100644 --- a/Command/ReKey.hs +++ b/Command/ReKey.hs @@ -38,13 +38,13 @@ optParser desc = ReKeyOptions -- Split on the last space, since a FilePath can contain whitespace, -- but a Key very rarely does. -batchParser :: String -> Either String (FilePath, Key) +batchParser :: String -> Either String (RawFilePath, Key) batchParser s = case separate (== ' ') (reverse s) of (rk, rf) | null rk || null rf -> Left "Expected: \"file key\"" | otherwise -> case deserializeKey (reverse rk) of Nothing -> Left "bad key" - Just k -> Right (reverse rf, k) + Just k -> Right (toRawFilePath (reverse rf), k) seek :: ReKeyOptions -> CommandSeek seek o = case batchOption o of @@ -52,9 +52,9 @@ seek o = case batchOption o of NoBatch -> withPairs (commandAction . start . parsekey) (reKeyThese o) where parsekey (file, skey) = - (file, fromMaybe (giveup "bad key") (deserializeKey skey)) + (toRawFilePath file, fromMaybe (giveup "bad key") (deserializeKey skey)) -start :: (FilePath, Key) -> CommandStart +start :: (RawFilePath, Key) -> CommandStart start (file, newkey) = ifAnnexed file go stop where go oldkey @@ -62,19 +62,19 @@ start (file, newkey) = ifAnnexed file go stop | otherwise = starting "rekey" (ActionItemWorkTreeFile file) $ perform file oldkey newkey -perform :: FilePath -> Key -> Key -> CommandPerform +perform :: RawFilePath -> Key -> Key -> CommandPerform perform file oldkey newkey = do ifM (inAnnex oldkey) ( unlessM (linkKey file oldkey newkey) $ giveup "failed creating link from old to new key" , unlessM (Annex.getState Annex.force) $ - giveup $ file ++ " is not available (use --force to override)" + giveup $ fromRawFilePath file ++ " is not available (use --force to override)" ) next $ cleanup file oldkey newkey {- Make a hard link to the old key content (when supported), - to avoid wasting disk space. -} -linkKey :: FilePath -> Key -> Key -> Annex Bool +linkKey :: RawFilePath -> Key -> Key -> Annex Bool linkKey file oldkey newkey = ifM (isJust <$> isAnnexLink file) {- If the object file is already hardlinked to elsewhere, a hard - link won't be made by getViaTmpFromDisk, but a copy instead. @@ -89,40 +89,40 @@ linkKey file oldkey newkey = ifM (isJust <$> isAnnexLink file) - it's hard linked to the old key, that link must be broken. -} oldobj <- calcRepo (gitAnnexLocation oldkey) v <- tryNonAsync $ do - st <- liftIO $ getFileStatus file + st <- liftIO $ getFileStatus (fromRawFilePath file) when (linkCount st > 1) $ do freezeContent oldobj - replaceFile file $ \tmp -> do + replaceFile (fromRawFilePath file) $ \tmp -> do unlessM (checkedCopyFile oldkey oldobj tmp Nothing) $ error "can't lock old key" thawContent tmp - ic <- withTSDelta (liftIO . genInodeCache file) + ic <- withTSDelta (liftIO . genInodeCache (fromRawFilePath file)) case v of Left e -> do warning (show e) return False Right () -> do - r <- linkToAnnex newkey file ic + r <- linkToAnnex newkey (fromRawFilePath file) ic return $ case r of LinkAnnexFailed -> False LinkAnnexOk -> True LinkAnnexNoop -> True ) -cleanup :: FilePath -> Key -> Key -> CommandCleanup +cleanup :: RawFilePath -> Key -> Key -> CommandCleanup cleanup file oldkey newkey = do ifM (isJust <$> isAnnexLink file) ( do -- Update symlink to use the new key. - liftIO $ removeFile file - addLink file newkey Nothing + liftIO $ removeFile (fromRawFilePath file) + addLink (fromRawFilePath file) newkey Nothing , do - mode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus file + mode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus (fromRawFilePath file) liftIO $ whenM (isJust <$> isPointerFile file) $ writePointerFile file newkey mode stagePointerFile file mode =<< hashPointerFile newkey Database.Keys.removeAssociatedFile oldkey - =<< inRepo (toTopFilePath file) + =<< inRepo (toTopFilePath (fromRawFilePath file)) ) whenM (inAnnex newkey) $ logStatus newkey InfoPresent diff --git a/Command/Smudge.hs b/Command/Smudge.hs index 7191461bd2..30e2f2d168 100644 --- a/Command/Smudge.hs +++ b/Command/Smudge.hs @@ -86,9 +86,9 @@ clean file = do ( liftIO $ L.hPut stdout b , case parseLinkTargetOrPointerLazy b of Just k -> do - getMoveRaceRecovery k file + getMoveRaceRecovery k (toRawFilePath file) liftIO $ L.hPut stdout b - Nothing -> go b =<< catKeyFile file + Nothing -> go b =<< catKeyFile (toRawFilePath file) ) stop where @@ -187,10 +187,10 @@ emitPointer = S.putStr . formatPointer -- This also handles the case where a copy of a pointer file is made, -- then git-annex gets the content, and later git add is run on -- the pointer copy. It will then be populated with the content. -getMoveRaceRecovery :: Key -> FilePath -> Annex () +getMoveRaceRecovery :: Key -> RawFilePath -> Annex () getMoveRaceRecovery k file = void $ tryNonAsync $ whenM (inAnnex k) $ do - obj <- calcRepo (gitAnnexLocation k) + obj <- toRawFilePath <$> calcRepo (gitAnnexLocation k) -- Cannot restage because git add is running and has -- the index locked. populatePointerFile (Restage False) k obj file >>= \case @@ -204,11 +204,11 @@ update = do updateSmudged :: Restage -> Annex () updateSmudged restage = streamSmudged $ \k topf -> do - f <- fromRepo $ fromTopFilePath topf + f <- toRawFilePath <$> fromRepo (fromTopFilePath topf) whenM (inAnnex k) $ do - obj <- calcRepo (gitAnnexLocation k) + obj <- toRawFilePath <$> calcRepo (gitAnnexLocation k) unlessM (isJust <$> populatePointerFile restage k obj f) $ liftIO (isPointerFile f) >>= \case Just k' | k' == k -> toplevelWarning False $ - "unable to populate worktree file " ++ f + "unable to populate worktree file " ++ fromRawFilePath f _ -> noop diff --git a/Command/TransferKeys.hs b/Command/TransferKeys.hs index 2d3cbaef49..9fa233fb90 100644 --- a/Command/TransferKeys.hs +++ b/Command/TransferKeys.hs @@ -116,10 +116,10 @@ instance TCSerialized Direction where deserialize _ = Nothing instance TCSerialized AssociatedFile where - serialize (AssociatedFile (Just f)) = f + serialize (AssociatedFile (Just f)) = fromRawFilePath f serialize (AssociatedFile Nothing) = "" deserialize "" = Just (AssociatedFile Nothing) - deserialize f = Just (AssociatedFile (Just f)) + deserialize f = Just (AssociatedFile (Just (toRawFilePath f))) instance TCSerialized RemoteName where serialize n = n diff --git a/Command/Unlock.hs b/Command/Unlock.hs index 2fc605c6de..31f8a26cf5 100644 --- a/Command/Unlock.hs +++ b/Command/Unlock.hs @@ -31,17 +31,18 @@ seek ps = withFilesInGit (commandAction . whenAnnexed start) =<< workTreeItems p {- Before v6, the unlock subcommand replaces the symlink with a copy of - the file's content. In v6 and above, it converts the file from a symlink - to a pointer. -} -start :: FilePath -> Key -> CommandStart +start :: RawFilePath -> Key -> CommandStart start file key = ifM (isJust <$> isAnnexLink file) ( starting "unlock" (mkActionItem (key, AssociatedFile (Just file))) $ perform file key , stop ) -perform :: FilePath -> Key -> CommandPerform +perform :: RawFilePath -> Key -> CommandPerform perform dest key = do - destmode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus dest - replaceFile dest $ \tmp -> + destmode <- liftIO $ catchMaybeIO $ fileMode + <$> getFileStatus (fromRawFilePath dest) + replaceFile (fromRawFilePath dest) $ \tmp -> ifM (inAnnex key) ( do r <- linkFromAnnex key tmp destmode @@ -49,12 +50,12 @@ perform dest key = do LinkAnnexOk -> return () LinkAnnexNoop -> return () LinkAnnexFailed -> error "unlock failed" - , liftIO $ writePointerFile tmp key destmode + , liftIO $ writePointerFile (toRawFilePath tmp) key destmode ) next $ cleanup dest key destmode -cleanup :: FilePath -> Key -> Maybe FileMode -> CommandCleanup +cleanup :: RawFilePath -> Key -> Maybe FileMode -> CommandCleanup cleanup dest key destmode = do stagePointerFile dest destmode =<< hashPointerFile key - Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath dest) + Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath (fromRawFilePath dest)) return True diff --git a/Command/Unused.hs b/Command/Unused.hs index 95f953395d..345111ec81 100644 --- a/Command/Unused.hs +++ b/Command/Unused.hs @@ -192,10 +192,10 @@ withKeysReferencedM a = withKeysReferenced' Nothing () calla calla k _ _ = a k {- Folds an action over keys and files referenced in a particular directory. -} -withKeysFilesReferencedIn :: FilePath -> v -> (Key -> FilePath -> v -> Annex v) -> Annex v +withKeysFilesReferencedIn :: FilePath -> v -> (Key -> RawFilePath -> v -> Annex v) -> Annex v withKeysFilesReferencedIn = withKeysReferenced' . Just -withKeysReferenced' :: Maybe FilePath -> v -> (Key -> FilePath -> v -> Annex v) -> Annex v +withKeysReferenced' :: Maybe FilePath -> v -> (Key -> RawFilePath -> v -> Annex v) -> Annex v withKeysReferenced' mdir initial a = do (files, clean) <- getfiles r <- go initial files @@ -207,9 +207,9 @@ withKeysReferenced' mdir initial a = do ( return ([], return True) , do top <- fromRepo Git.repoPath - inRepo $ LsFiles.allFiles [top] + inRepo $ LsFiles.allFiles [toRawFilePath top] ) - Just dir -> inRepo $ LsFiles.inRepo [dir] + Just dir -> inRepo $ LsFiles.inRepo [toRawFilePath dir] go v [] = return v go v (f:fs) = do mk <- lookupFile f @@ -221,7 +221,8 @@ withKeysReferenced' mdir initial a = do withKeysReferencedDiffGitRefs :: RefSpec -> (Key -> Annex ()) -> Annex () withKeysReferencedDiffGitRefs refspec a = do - rs <- relevantrefs <$> inRepo (Git.Command.pipeReadStrict [Param "show-ref"]) + rs <- relevantrefs . decodeBS' + <$> inRepo (Git.Command.pipeReadStrict [Param "show-ref"]) shaHead <- maybe (return Nothing) (inRepo . Git.Ref.sha) =<< inRepo Git.Branch.currentUnsafe let haveHead = any (\(shaRef, _) -> Just shaRef == shaHead) rs diff --git a/Command/View.hs b/Command/View.hs index 88b9a4866d..58e7a8c8b0 100644 --- a/Command/View.hs +++ b/Command/View.hs @@ -101,7 +101,8 @@ checkoutViewBranch view mkbranch = do - removed.) -} top <- liftIO . absPath =<< fromRepo Git.repoPath (l, cleanup) <- inRepo $ - LsFiles.notInRepoIncludingEmptyDirectories False [top] + LsFiles.notInRepoIncludingEmptyDirectories False + [toRawFilePath top] forM_ l (removeemptydir top) liftIO $ void cleanup unlessM (liftIO $ doesDirectoryExist here) $ do @@ -109,7 +110,7 @@ checkoutViewBranch view mkbranch = do return ok where removeemptydir top d = do - p <- inRepo $ toTopFilePath d + p <- inRepo $ toTopFilePath $ fromRawFilePath d liftIO $ tryIO $ removeDirectory (top getTopFilePath p) cwdmissing top = unlines [ "This view does not include the subdirectory you are currently in." diff --git a/Git/Repair.hs b/Git/Repair.hs index 734c884f60..6031f4dd73 100644 --- a/Git/Repair.hs +++ b/Git/Repair.hs @@ -284,7 +284,7 @@ findUncorruptedCommit missing goodcommits branch r = do , Param "--format=%H" , Param (fromRef branch) ] r - let branchshas = catMaybes $ map (extractSha . decodeBS) ls + let branchshas = catMaybes $ map (extractSha . decodeBL) ls reflogshas <- RefLog.get branch r -- XXX Could try a bit harder here, and look -- for uncorrupted old commits in branches in the @@ -313,7 +313,7 @@ verifyCommit missing goodcommits commit r , Param "--format=%H %T" , Param (fromRef commit) ] r - let committrees = map (parse . decodeBS) ls + let committrees = map (parse . decodeBL) ls if any isNothing committrees || null committrees then do void cleanup @@ -342,7 +342,7 @@ verifyTree missing treesha r | S.member treesha missing = return False | otherwise = do (ls, cleanup) <- pipeNullSplit (LsTree.lsTreeParams LsTree.LsTreeRecursive treesha []) r - let objshas = map (LsTree.sha . LsTree.parseLsTree) ls + let objshas = mapMaybe (LsTree.sha <$$> eitherToMaybe . LsTree.parseLsTree) ls if any (`S.member` missing) objshas then do void cleanup @@ -366,7 +366,7 @@ checkIndex r = do - itself is not corrupt. -} checkIndexFast :: Repo -> IO Bool checkIndexFast r = do - (indexcontents, cleanup) <- LsFiles.stagedDetails [repoPath r] r + (indexcontents, cleanup) <- LsFiles.stagedDetails [toRawFilePath (repoPath r)] r length indexcontents `seq` cleanup missingIndex :: Repo -> IO Bool @@ -375,7 +375,7 @@ missingIndex r = not <$> doesFileExist (localGitDir r "index") {- Finds missing and ok files staged in the index. -} partitionIndex :: Repo -> IO ([LsFiles.StagedDetails], [LsFiles.StagedDetails], IO Bool) partitionIndex r = do - (indexcontents, cleanup) <- LsFiles.stagedDetails [repoPath r] r + (indexcontents, cleanup) <- LsFiles.stagedDetails [toRawFilePath (repoPath r)] r l <- forM indexcontents $ \i -> case i of (_file, Just sha, Just _mode) -> (,) <$> isMissing sha r <*> pure i _ -> pure (False, i) @@ -394,12 +394,12 @@ rewriteIndex r UpdateIndex.streamUpdateIndex r =<< (catMaybes <$> mapM reinject good) void cleanup - return $ map fst3 bad + return $ map (fromRawFilePath . fst3) bad where reinject (file, Just sha, Just mode) = case toTreeItemType mode of Nothing -> return Nothing Just treeitemtype -> Just <$> - UpdateIndex.stageFile sha treeitemtype file r + UpdateIndex.stageFile sha treeitemtype (fromRawFilePath file) r reinject _ = return Nothing newtype GoodCommits = GoodCommits (S.Set Sha) From 718fa83da64b2881b18e2dfe134b3c8991c7e607 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 5 Dec 2019 11:46:55 -0400 Subject: [PATCH 14/42] mention optimisations --- CHANGELOG | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/CHANGELOG b/CHANGELOG index c762e7ec65..66ae7e8bdc 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,9 +1,13 @@ git-annex (7.20191115) UNRELEASED; urgency=medium + * Sped up many git-annex commands that operate on many files, by + using ByteStrings. Some commands like find got up to 60% faster. * Sped up many git-annex commands that operate on many files, by avoiding reserialization of keys. - find is 7% faster; whereis is 3% faster; and git-annex get when - all files are already present is 5% faster + find got 7% faster; whereis 3% faster; and git-annex get when + all files are already present got 5% faster + * Sped up many git-annex commands that query the git-annex branch. + In particular whereis got 1.5% faster. * Stop displaying rsync progress, and use git-annex's own progress display for local-to-local repo transfers. * git-lfs: The url provided to initremote/enableremote will now be From c20f4704a7813ed90ffd4b7be7a7de6192f9eac5 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 5 Dec 2019 14:36:43 -0400 Subject: [PATCH 15/42] all commands building except for assistant also, changed ConfigValue to a newtype, and moved it into Git.Config. --- Annex/Init.hs | 3 ++- CmdLine/GitAnnex.hs | 24 ------------------------ Command/AddUrl.hs | 14 +++++++------- Command/Config.hs | 31 +++++++++++++++++-------------- Command/ConfigList.hs | 2 +- Command/DiffDriver.hs | 4 ++-- Command/FuzzTest.hs | 11 ++++++----- Command/ImportFeed.hs | 6 +++--- Command/Info.hs | 18 ++++++++++-------- Command/Inprogress.hs | 2 +- Command/List.hs | 6 +++--- Command/Log.hs | 10 +++++----- Command/Migrate.hs | 10 +++++----- Command/Mirror.hs | 4 ++-- Command/P2P.hs | 2 ++ Command/RmUrl.hs | 6 ++++-- Command/TestRemote.hs | 6 +++--- Command/Undo.hs | 4 ++-- Command/Vicfg.hs | 9 +++++---- Config.hs | 4 ++-- Git/AutoCorrect.hs | 2 +- Git/Config.hs | 26 +++++++++++++------------- Git/ConfigTypes.hs | 35 ++++++++++++++++++++--------------- Git/Construct.hs | 2 +- Git/GCrypt.hs | 8 ++++---- Git/Remote.hs | 4 ++-- Git/Types.hs | 21 +++++++++++++++++++-- Logs/Config.hs | 21 +++++++++++---------- Remote.hs | 4 ++-- Remote/Bup.hs | 4 ++-- Remote/GCrypt.hs | 4 ++-- Remote/Git.hs | 2 +- Remote/GitLFS.hs | 2 +- Remote/Hook.hs | 6 +++--- Test.hs | 15 ++++----------- Test/Framework.hs | 5 +++-- Types/GitConfig.hs | 6 +++--- Types/UUID.hs | 7 +++++++ Upgrade/V5/Direct.hs | 2 +- git-annex.cabal | 9 +++++---- 40 files changed, 187 insertions(+), 174 deletions(-) diff --git a/Annex/Init.hs b/Annex/Init.hs index c034bfac0c..3accd18ff3 100644 --- a/Annex/Init.hs +++ b/Annex/Init.hs @@ -23,6 +23,7 @@ import qualified Annex import qualified Git import qualified Git.Config import qualified Git.Objects +import Git.Types (fromConfigValue) import qualified Annex.Branch import Logs.UUID import Logs.Trust.Basic @@ -275,5 +276,5 @@ initSharedClone True = do - affect it. -} propigateSecureHashesOnly :: Annex () propigateSecureHashesOnly = - maybe noop (setConfig "annex.securehashesonly" . decodeBS') + maybe noop (setConfig "annex.securehashesonly" . fromConfigValue) =<< getGlobalConfig "annex.securehashesonly" diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs index daef02d85f..9fc0d272ae 100644 --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -65,15 +65,10 @@ import qualified Command.AddUnused import qualified Command.Unlock import qualified Command.Lock import qualified Command.PreCommit -{- 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 @@ -97,17 +92,13 @@ 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 @@ -116,9 +107,7 @@ import qualified Command.Forget import qualified Command.P2P import qualified Command.Proxy import qualified Command.DiffDriver --} import qualified Command.Smudge -{- import qualified Command.Undo import qualified Command.Version import qualified Command.RemoteDaemon @@ -132,7 +121,6 @@ import qualified Command.WebApp import qualified Command.Test import qualified Command.FuzzTest import qualified Command.TestRemote --} import qualified Command.Benchmark cmds :: Parser TestOptions -> TestRunner -> MkBenchmarkGenerator -> [Command] @@ -148,12 +136,10 @@ cmds testoptparser testrunner mkbenchmarkgenerator = , 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 @@ -165,12 +151,9 @@ cmds testoptparser testrunner mkbenchmarkgenerator = , Command.Multicast.cmd , Command.Reinject.cmd , Command.Unannex.cmd -{- , Command.Uninit.cmd , Command.Reinit.cmd --} , Command.PreCommit.cmd -{- , Command.PostReceive.cmd , Command.NumCopies.cmd , Command.Trust.cmd @@ -185,7 +168,6 @@ cmds testoptparser testrunner mkbenchmarkgenerator = , Command.Ungroup.cmd , Command.Config.cmd , Command.Vicfg.cmd --} , Command.LookupKey.cmd , Command.CalcKey.cmd , Command.ContentLocation.cmd @@ -215,11 +197,8 @@ cmds testoptparser testrunner mkbenchmarkgenerator = , Command.DropUnused.cmd , Command.AddUnused.cmd , Command.Find.cmd -{- , Command.FindRef.cmd --} , Command.Whereis.cmd -{- , Command.List.cmd , Command.Log.cmd , Command.Merge.cmd @@ -236,9 +215,7 @@ cmds testoptparser testrunner mkbenchmarkgenerator = , Command.P2P.cmd , Command.Proxy.cmd , Command.DiffDriver.cmd --} , Command.Smudge.cmd -{- , Command.Undo.cmd , Command.Version.cmd , Command.RemoteDaemon.cmd @@ -252,7 +229,6 @@ cmds testoptparser testrunner mkbenchmarkgenerator = , Command.Test.cmd testoptparser testrunner , Command.FuzzTest.cmd , Command.TestRemote.cmd --} , Command.Benchmark.cmd $ mkbenchmarkgenerator $ cmds testoptparser testrunner (\_ _ -> return noop) ] diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs index a968aae9d5..1d814037e5 100644 --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -156,7 +156,7 @@ startRemote r o file uri sz = do performRemote r o uri file' sz performRemote :: Remote -> AddUrlOptions -> URLString -> FilePath -> Maybe Integer -> CommandPerform -performRemote r o uri file sz = ifAnnexed file adduri geturi +performRemote r o uri file sz = ifAnnexed (toRawFilePath file) adduri geturi where loguri = setDownloader uri OtherDownloader adduri = addUrlChecked o loguri file (Remote.uuid r) checkexistssize @@ -180,7 +180,7 @@ downloadRemoteFile r o uri file sz = checkCanAdd file $ do setTempUrl urlkey loguri let downloader = \dest p -> fst <$> Remote.retrieveKeyFile r urlkey - (AssociatedFile (Just file)) dest p + (AssociatedFile (Just (toRawFilePath file))) dest p ret <- downloadWith downloader urlkey (Remote.uuid r) loguri file removeTempUrl urlkey return ret @@ -212,7 +212,7 @@ startWeb o urlstring = go $ fromMaybe bad $ parseURI urlstring performWeb o urlstring file urlinfo performWeb :: AddUrlOptions -> URLString -> FilePath -> Url.UrlInfo -> CommandPerform -performWeb o url file urlinfo = ifAnnexed file addurl geturl +performWeb o url file urlinfo = ifAnnexed (toRawFilePath file) addurl geturl where geturl = next $ isJust <$> addUrlFile (downloadOptions o) url urlinfo file addurl = addUrlChecked o url file webUUID $ \k -> @@ -258,7 +258,7 @@ addUrlFile o url urlinfo file = downloadWeb :: DownloadOptions -> URLString -> Url.UrlInfo -> FilePath -> Annex (Maybe Key) downloadWeb o url urlinfo file = - go =<< downloadWith' downloader urlkey webUUID url (AssociatedFile (Just file)) + go =<< downloadWith' downloader urlkey webUUID url (AssociatedFile (Just (toRawFilePath file))) where urlkey = addSizeUrlKey urlinfo $ Backend.URL.fromUrl url Nothing downloader f p = downloadUrl urlkey p [url] f @@ -278,7 +278,7 @@ downloadWeb o url urlinfo file = -- first, and check if that is already an annexed file, -- to avoid unnecessary work in that case. | otherwise = youtubeDlFileNameHtmlOnly url >>= \case - Right dest -> ifAnnexed dest + Right dest -> ifAnnexed (toRawFilePath dest) (alreadyannexed dest) (dl dest) Left _ -> normalfinish tmp @@ -345,7 +345,7 @@ downloadWith :: (FilePath -> MeterUpdate -> Annex Bool) -> Key -> UUID -> URLStr downloadWith downloader dummykey u url file = go =<< downloadWith' downloader dummykey u url afile where - afile = AssociatedFile (Just file) + afile = AssociatedFile (Just (toRawFilePath file)) go Nothing = return Nothing go (Just tmp) = finishDownloadWith tmp u url file @@ -401,7 +401,7 @@ addWorkTree u url file key mtmp = case mtmp of -- than the work tree file. liftIO $ renameFile file tmp go - else void $ Command.Add.addSmall file + else void $ Command.Add.addSmall (toRawFilePath file) where go = do maybeShowJSON $ JSONChunk [("key", serializeKey key)] diff --git a/Command/Config.hs b/Command/Config.hs index 15ab85daeb..6764ca5e92 100644 --- a/Command/Config.hs +++ b/Command/Config.hs @@ -10,6 +10,9 @@ module Command.Config where import Command import Logs.Config import Config +import Git.Types (ConfigKey(..), fromConfigValue) + +import qualified Data.ByteString as S cmd :: Command cmd = noMessages $ command "config" SectionSetup @@ -17,9 +20,9 @@ cmd = noMessages $ command "config" SectionSetup paramNothing (seek <$$> optParser) data Action - = SetConfig ConfigName ConfigValue - | GetConfig ConfigName - | UnsetConfig ConfigName + = SetConfig ConfigKey ConfigValue + | GetConfig ConfigKey + | UnsetConfig ConfigKey type Name = String type Value = String @@ -48,19 +51,19 @@ optParser _ = setconfig <|> getconfig <|> unsetconfig ) seek :: Action -> CommandSeek -seek (SetConfig name val) = commandAction $ - startingUsualMessages name (ActionItemOther (Just val)) $ do - setGlobalConfig name val - setConfig (ConfigKey name) val +seek (SetConfig ck@(ConfigKey name) val) = commandAction $ + startingUsualMessages (decodeBS' name) (ActionItemOther (Just (fromConfigValue val))) $ do + setGlobalConfig ck val + setConfig ck (fromConfigValue val) next $ return True -seek (UnsetConfig name) = commandAction $ - startingUsualMessages name (ActionItemOther (Just "unset")) $do - unsetGlobalConfig name - unsetConfig (ConfigKey name) +seek (UnsetConfig ck@(ConfigKey name)) = commandAction $ + startingUsualMessages (decodeBS' name) (ActionItemOther (Just "unset")) $do + unsetGlobalConfig ck + unsetConfig ck next $ return True -seek (GetConfig name) = commandAction $ +seek (GetConfig ck) = commandAction $ startingCustomOutput (ActionItemOther Nothing) $ do - getGlobalConfig name >>= \case + getGlobalConfig ck >>= \case Nothing -> return () - Just v -> liftIO $ putStrLn v + Just (ConfigValue v) -> liftIO $ S.putStrLn v next $ return True diff --git a/Command/ConfigList.hs b/Command/ConfigList.hs index 793f22df47..bb33f7102b 100644 --- a/Command/ConfigList.hs +++ b/Command/ConfigList.hs @@ -30,7 +30,7 @@ start :: CommandStart start = do u <- findOrGenUUID showConfig configkeyUUID $ fromUUID u - showConfig coreGCryptId . decodeBS' + showConfig coreGCryptId . fromConfigValue =<< fromRepo (Git.Config.get coreGCryptId mempty) stop where diff --git a/Command/DiffDriver.hs b/Command/DiffDriver.hs index f4251c0929..ecc05ca093 100644 --- a/Command/DiffDriver.hs +++ b/Command/DiffDriver.hs @@ -85,9 +85,9 @@ fixupReq req@(Req {}) = check rOldFile rOldMode (\r f -> r { rOldFile = f }) req >>= check rNewFile rNewMode (\r f -> r { rNewFile = f }) where - check getfile getmode setfile r = case readTreeItemType (getmode r) of + check getfile getmode setfile r = case readTreeItemType (encodeBS' (getmode r)) of Just TreeSymlink -> do - v <- getAnnexLinkTarget' (getfile r) False + v <- getAnnexLinkTarget' (toRawFilePath (getfile r)) False case parseLinkTargetOrPointer =<< v of Nothing -> return r Just k -> withObjectLoc k (pure . setfile r) diff --git a/Command/FuzzTest.hs b/Command/FuzzTest.hs index 5e0812516e..ba232f3167 100644 --- a/Command/FuzzTest.hs +++ b/Command/FuzzTest.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Command.FuzzTest where import Command @@ -13,6 +15,7 @@ import qualified Git.Config import Config import Utility.ThreadScheduler import Utility.DiskFree +import Git.Types (fromConfigKey) import Data.Time.Clock import System.Random (getStdRandom, random, randomR) @@ -32,25 +35,23 @@ start :: CommandStart start = do guardTest logf <- fromRepo gitAnnexFuzzTestLogFile - showStart "fuzztest" logf + showStart "fuzztest" (toRawFilePath logf) logh <- liftIO $ openFile logf WriteMode void $ forever $ fuzz logh stop guardTest :: Annex () -guardTest = unlessM (fromMaybe False . Git.Config.isTrue <$> getConfig key "") $ +guardTest = unlessM (fromMaybe False . Git.Config.isTrue' <$> getConfig key mempty) $ giveup $ unlines [ "Running fuzz tests *writes* to and *deletes* files in" , "this repository, and pushes those changes to other" , "repositories! This is a developer tool, not something" , "to play with." , "" - , "Refusing to run fuzz tests, since " ++ keyname ++ " is not set!" + , "Refusing to run fuzz tests, since " ++ fromConfigKey key ++ " is not set!" ] where key = annexConfig "eat-my-repository" - (ConfigKey keyname) = key - fuzz :: Handle -> Annex () fuzz logh = do diff --git a/Command/ImportFeed.hs b/Command/ImportFeed.hs index 2eca658649..dc4fb8749c 100644 --- a/Command/ImportFeed.hs +++ b/Command/ImportFeed.hs @@ -67,7 +67,7 @@ seek o = do getFeed :: ImportFeedOptions -> Cache -> URLString -> CommandSeek getFeed opts cache url = do - showStart "importfeed" url + showStart' "importfeed" (Just url) downloadFeed url >>= \case Nothing -> showEndResult =<< feedProblem url "downloading the feed failed" @@ -222,7 +222,7 @@ performDownload opts cache todownload = case location todownload of case dest of Nothing -> return True Just f -> do - showStart "addurl" url + showStart' "addurl" (Just url) ks <- getter f if null ks then do @@ -244,7 +244,7 @@ performDownload opts cache todownload = case location todownload of - to be re-downloaded. -} makeunique url n file = ifM alreadyexists ( ifM forced - ( ifAnnexed f checksameurl tryanother + ( ifAnnexed (toRawFilePath f) checksameurl tryanother , tryanother ) , return $ Just f diff --git a/Command/Info.hs b/Command/Info.hs index 0c429dee72..a0099ca06d 100644 --- a/Command/Info.hs +++ b/Command/Info.hs @@ -152,7 +152,7 @@ itemInfo o p = ifM (isdir p) v' <- Remote.nameToUUID' p case v' of Right u -> uuidInfo o u - Left _ -> ifAnnexed p + Left _ -> ifAnnexed (toRawFilePath p) (fileInfo o p) (treeishInfo o p) ) @@ -161,7 +161,7 @@ itemInfo o p = ifM (isdir p) noInfo :: String -> Annex () noInfo s = do - showStart "info" s + showStart "info" (encodeBS' s) showNote $ "not a directory or an annexed file or a treeish or a remote or a uuid" showEndFail @@ -311,8 +311,8 @@ showStat :: Stat -> StatState () showStat s = maybe noop calc =<< s where calc (desc, a) = do - (lift . showHeader) desc - lift . showRaw =<< a + (lift . showHeader . encodeBS') desc + lift . showRaw . encodeBS' =<< a repo_list :: TrustLevel -> Stat repo_list level = stat n $ nojson $ lift $ do @@ -435,7 +435,7 @@ transfer_list = stat desc $ nojson $ lift $ do desc = "transfers in progress" line uuidmap t i = unwords [ formatDirection (transferDirection t) ++ "ing" - , actionItemDesc $ mkActionItem + , fromRawFilePath $ actionItemDesc $ mkActionItem (transferKey t, associatedFile i) , if transferDirection t == Upload then "to" else "from" , maybe (fromUUID $ transferUUID t) Remote.name $ @@ -444,7 +444,7 @@ transfer_list = stat desc $ nojson $ lift $ do jsonify t i = object $ map (\(k, v) -> (packString k, v)) $ [ ("transfer", toJSON' (formatDirection (transferDirection t))) , ("key", toJSON' (transferKey t)) - , ("file", toJSON' afile) + , ("file", toJSON' (fromRawFilePath <$> afile)) , ("remote", toJSON' (fromUUID (transferUUID t) :: String)) ] where @@ -566,7 +566,7 @@ getDirStatInfo o dir = do where initial = (emptyKeyInfo, emptyKeyInfo, emptyNumCopiesStats, M.empty) update matcher fast key file vs@(presentdata, referenceddata, numcopiesstats, repodata) = - ifM (matcher $ MatchingFile $ FileInfo file file) + ifM (matcher $ MatchingFile $ FileInfo file' file') ( do !presentdata' <- ifM (inAnnex key) ( return $ addKey key presentdata @@ -577,11 +577,13 @@ getDirStatInfo o dir = do then return (numcopiesstats, repodata) else do locs <- Remote.keyLocations key - nc <- updateNumCopiesStats file numcopiesstats locs + nc <- updateNumCopiesStats file' numcopiesstats locs return (nc, updateRepoData key locs repodata) return $! (presentdata', referenceddata', numcopiesstats', repodata') , return vs ) + where + file' = fromRawFilePath file getTreeStatInfo :: InfoOptions -> Git.Ref -> Annex (Maybe StatInfo) getTreeStatInfo o r = do diff --git a/Command/Inprogress.hs b/Command/Inprogress.hs index e571fa8d3b..45d68da745 100644 --- a/Command/Inprogress.hs +++ b/Command/Inprogress.hs @@ -42,7 +42,7 @@ seek o = do (commandAction . (whenAnnexed (start s))) =<< workTreeItems (inprogressFiles o) -start :: S.Set Key -> FilePath -> Key -> CommandStart +start :: S.Set Key -> RawFilePath -> Key -> CommandStart start s _file k | S.member k s = start' k | otherwise = stop diff --git a/Command/List.hs b/Command/List.hs index ae9e6a70f1..7b41a304ec 100644 --- a/Command/List.hs +++ b/Command/List.hs @@ -72,7 +72,7 @@ getList o printHeader :: [(UUID, RemoteName, TrustLevel)] -> Annex () printHeader l = liftIO $ putStrLn $ lheader $ map (\(_, n, t) -> (n, t)) l -start :: [(UUID, RemoteName, TrustLevel)] -> FilePath -> Key -> CommandStart +start :: [(UUID, RemoteName, TrustLevel)] -> RawFilePath -> Key -> CommandStart start l file key = do ls <- S.fromList <$> keyLocations key liftIO $ putStrLn $ format (map (\(u, _, t) -> (t, S.member u ls)) l) file @@ -88,8 +88,8 @@ lheader remotes = unlines (zipWith formatheader [0..] remotes) ++ pipes (length trust UnTrusted = " (untrusted)" trust _ = "" -format :: [(TrustLevel, Present)] -> FilePath -> String -format remotes file = thereMap ++ " " ++ file +format :: [(TrustLevel, Present)] -> RawFilePath -> String +format remotes file = thereMap ++ " " ++ fromRawFilePath file where thereMap = concatMap there remotes there (UnTrusted, True) = "x" diff --git a/Command/Log.hs b/Command/Log.hs index 554afa947a..19ededcc02 100644 --- a/Command/Log.hs +++ b/Command/Log.hs @@ -92,10 +92,10 @@ seek o = do ([], True) -> commandAction (startAll o outputter) (_, True) -> giveup "Cannot specify both files and --all" -start :: LogOptions -> (FilePath -> Outputter) -> FilePath -> Key -> CommandStart +start :: LogOptions -> (FilePath -> Outputter) -> RawFilePath -> Key -> CommandStart start o outputter file key = do (changes, cleanup) <- getKeyLog key (passthruOptions o) - showLogIncremental (outputter file) changes + showLogIncremental (outputter (fromRawFilePath file)) changes void $ liftIO cleanup stop @@ -201,7 +201,7 @@ getKeyLog key os = do top <- fromRepo Git.repoPath p <- liftIO $ relPathCwdToFile top config <- Annex.getGitConfig - let logfile = p locationLogFile config key + let logfile = p fromRawFilePath (locationLogFile config key) getGitLog [logfile] (Param "--remove-empty" : os) {- Streams the git log for all git-annex branch changes. -} @@ -220,7 +220,7 @@ getGitLog fs os = do [ Param $ Git.fromRef Annex.Branch.fullname , Param "--" ] ++ map Param fs - return (parseGitRawLog ls, cleanup) + return (parseGitRawLog (map decodeBL' ls), cleanup) -- Parses chunked git log --raw output, which looks something like: -- @@ -250,7 +250,7 @@ parseGitRawLog = parse epoch (tss, cl') -> (parseTimeStamp tss, cl') mrc = do (old, new) <- parseRawChangeLine cl - key <- locationLogFileKey c2 + key <- locationLogFileKey (toRawFilePath c2) return $ RefChange { changetime = ts , oldref = old diff --git a/Command/Migrate.hs b/Command/Migrate.hs index ca65cbef1e..0f964bb749 100644 --- a/Command/Migrate.hs +++ b/Command/Migrate.hs @@ -28,16 +28,16 @@ cmd = withGlobalOptions [annexedMatchingOptions] $ seek :: CmdParams -> CommandSeek seek = withFilesInGit (commandAction . (whenAnnexed start)) <=< workTreeItems -start :: FilePath -> Key -> CommandStart +start :: RawFilePath -> Key -> CommandStart start file key = do forced <- Annex.getState Annex.force - v <- Backend.getBackend file key + v <- Backend.getBackend (fromRawFilePath file) key case v of Nothing -> stop Just oldbackend -> do exists <- inAnnex key newbackend <- maybe defaultBackend return - =<< chooseBackend file + =<< chooseBackend (fromRawFilePath file) if (newbackend /= oldbackend || upgradableKey oldbackend key || forced) && exists then starting "migrate" (mkActionItem (key, file)) $ perform file key oldbackend newbackend @@ -63,7 +63,7 @@ upgradableKey backend key = isNothing (fromKey keySize key) || backendupgradable - data cannot get corrupted after the fsck but before the new key is - generated. -} -perform :: FilePath -> Key -> Backend -> Backend -> CommandPerform +perform :: RawFilePath -> Key -> Backend -> Backend -> CommandPerform perform file oldkey oldbackend newbackend = go =<< genkey (fastMigrate oldbackend) where go Nothing = stop @@ -85,7 +85,7 @@ perform file oldkey oldbackend newbackend = go =<< genkey (fastMigrate oldbacken genkey Nothing = do content <- calcRepo $ gitAnnexLocation oldkey let source = KeySource - { keyFilename = file + { keyFilename = fromRawFilePath file , contentLocation = content , inodeCache = Nothing } diff --git a/Command/Mirror.hs b/Command/Mirror.hs index be7b7c5920..ecfff8fdba 100644 --- a/Command/Mirror.hs +++ b/Command/Mirror.hs @@ -47,7 +47,7 @@ seek o = startConcurrency transferStages $ (withFilesInGit (commandAction . (whenAnnexed $ start o))) =<< workTreeItems (mirrorFiles o) -start :: MirrorOptions -> FilePath -> Key -> CommandStart +start :: MirrorOptions -> RawFilePath -> Key -> CommandStart start o file k = startKey o afile (k, ai) where afile = AssociatedFile (Just file) @@ -75,4 +75,4 @@ startKey o afile (key, ai) = case fromToOptions o of where getnumcopies = case afile of AssociatedFile Nothing -> getNumCopies - AssociatedFile (Just af) -> getFileNumCopies af + AssociatedFile (Just af) -> getFileNumCopies (fromRawFilePath af) diff --git a/Command/P2P.hs b/Command/P2P.hs index ae86f59076..e1896c7a3f 100644 --- a/Command/P2P.hs +++ b/Command/P2P.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Command.P2P where import Command diff --git a/Command/RmUrl.hs b/Command/RmUrl.hs index 3d8d8ca2df..04c3165ce5 100644 --- a/Command/RmUrl.hs +++ b/Command/RmUrl.hs @@ -42,9 +42,11 @@ batchParser s = case separate (== ' ') (reverse s) of | otherwise -> Right (reverse rf, reverse ru) start :: (FilePath, URLString) -> CommandStart -start (file, url) = flip whenAnnexed file $ \_ key -> - starting "rmurl" (mkActionItem (key, AssociatedFile (Just file))) $ +start (file, url) = flip whenAnnexed file' $ \_ key -> + starting "rmurl" (mkActionItem (key, AssociatedFile (Just file'))) $ next $ cleanup url key + where + file' = toRawFilePath file cleanup :: String -> Key -> CommandCleanup cleanup url key = do diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs index eef6ccaea1..292697a781 100644 --- a/Command/TestRemote.hs +++ b/Command/TestRemote.hs @@ -236,7 +236,7 @@ testExportTree st (Just _) ea k1 k2 = ] where testexportdirectory = "testremote-export" - testexportlocation = mkExportLocation (testexportdirectory "location") + testexportlocation = mkExportLocation (toRawFilePath (testexportdirectory "location")) check desc a = testCase desc $ Annex.eval st (Annex.setOutput QuietOutput >> a) @? "failed" storeexport k = do @@ -252,7 +252,7 @@ testExportTree st (Just _) ea k1 k2 = removeexport k = Remote.removeExport ea k testexportlocation removeexportdirectory = case Remote.removeExportDirectory ea of Nothing -> return True - Just a -> a (mkExportDirectory testexportdirectory) + Just a -> a (mkExportDirectory (toRawFilePath testexportdirectory)) testUnavailable :: Annex.AnnexState -> Remote -> Key -> [TestTree] testUnavailable st r k = @@ -326,7 +326,7 @@ randKey sz = withTmpFile "randkey" $ \f h -> do return k getReadonlyKey :: Remote -> FilePath -> Annex Key -getReadonlyKey r f = lookupFile f >>= \case +getReadonlyKey r f = lookupFile (toRawFilePath f) >>= \case Nothing -> giveup $ f ++ " is not an annexed file" Just k -> do unlessM (inAnnex k) $ diff --git a/Command/Undo.hs b/Command/Undo.hs index 8a1939394e..fd4b3b263d 100644 --- a/Command/Undo.hs +++ b/Command/Undo.hs @@ -27,9 +27,9 @@ seek :: CmdParams -> CommandSeek seek ps = do -- Safety first; avoid any undo that would touch files that are not -- in the index. - (fs, cleanup) <- inRepo $ LsFiles.notInRepo False ps + (fs, cleanup) <- inRepo $ LsFiles.notInRepo False (map toRawFilePath ps) unless (null fs) $ - giveup $ "Cannot undo changes to files that are not checked into git: " ++ unwords fs + giveup $ "Cannot undo changes to files that are not checked into git: " ++ unwords (map fromRawFilePath fs) void $ liftIO $ cleanup -- Committing staged changes before undo allows later diff --git a/Command/Vicfg.hs b/Command/Vicfg.hs index 4e842f4ea7..70bccac542 100644 --- a/Command/Vicfg.hs +++ b/Command/Vicfg.hs @@ -31,6 +31,7 @@ import Types.StandardGroups import Types.ScheduledActivity import Types.NumCopies import Remote +import Git.Types (ConfigKey(..), fromConfigKey, fromConfigValue) cmd :: Command cmd = command "vicfg" SectionSetup "edit configuration in git-annex branch" @@ -70,7 +71,7 @@ data Cfg = Cfg , cfgRequiredContentMap :: M.Map UUID PreferredContentExpression , cfgGroupPreferredContentMap :: M.Map Group PreferredContentExpression , cfgScheduleMap :: M.Map UUID [ScheduledActivity] - , cfgGlobalConfigs :: M.Map ConfigName ConfigValue + , cfgGlobalConfigs :: M.Map ConfigKey ConfigValue , cfgNumCopies :: Maybe NumCopies } @@ -218,9 +219,9 @@ genCfg cfg descs = unlines $ intercalate [""] [ com "Other global configuration" ] (\(s, g) -> gline g s) - (\g -> gline g "") + (\g -> gline g mempty) where - gline g val = [ unwords ["config", g, "=", val] ] + gline k v = [ unwords ["config", fromConfigKey k, "=", fromConfigValue v] ] line setting u val = [ com $ "(for " ++ fromUUIDDesc (fromMaybe mempty (M.lookup u descs)) ++ ")" @@ -308,7 +309,7 @@ parseCfg defcfg = go [] defcfg . lines let m = M.insert u l (cfgScheduleMap cfg) in Right $ cfg { cfgScheduleMap = m } | setting == "config" = - let m = M.insert f val (cfgGlobalConfigs cfg) + let m = M.insert (ConfigKey (encodeBS' f)) (ConfigValue (encodeBS' val)) (cfgGlobalConfigs cfg) in Right $ cfg { cfgGlobalConfigs = m } | setting == "numcopies" = case readish val of Nothing -> Left "parse error (expected an integer)" diff --git a/Config.hs b/Config.hs index e3925c9746..68c657aa47 100644 --- a/Config.hs +++ b/Config.hs @@ -29,10 +29,10 @@ type UnqualifiedConfigKey = S.ByteString {- Looks up a setting in git config. This is not as efficient as using the - GitConfig type. -} -getConfig :: ConfigKey -> S.ByteString -> Annex S.ByteString +getConfig :: ConfigKey -> ConfigValue -> Annex ConfigValue getConfig key d = fromRepo $ Git.Config.get key d -getConfigMaybe :: ConfigKey -> Annex (Maybe S.ByteString) +getConfigMaybe :: ConfigKey -> Annex (Maybe ConfigValue) getConfigMaybe key = fromRepo $ Git.Config.getMaybe key {- Changes a git config setting in both internal state and .git/config -} diff --git a/Git/AutoCorrect.hs b/Git/AutoCorrect.hs index ac45a4b367..06823a182f 100644 --- a/Git/AutoCorrect.hs +++ b/Git/AutoCorrect.hs @@ -46,7 +46,7 @@ fuzzymatches input showchoice choices = fst $ unzip $ -} prepare :: String -> (c -> String) -> [c] -> Maybe Repo -> IO () prepare input showmatch matches r = - case readish . decodeBS' . Git.Config.get "help.autocorrect" "0" =<< r of + case readish . fromConfigValue . Git.Config.get "help.autocorrect" "0" =<< r of Just n | n == 0 -> list | n < 0 -> warn Nothing diff --git a/Git/Config.hs b/Git/Config.hs index 8e42314bc1..5276e46835 100644 --- a/Git/Config.hs +++ b/Git/Config.hs @@ -21,16 +21,16 @@ import qualified Git.Command import qualified Git.Construct import Utility.UserInfo -{- Returns a single git config setting, or a default value if not set. -} -get :: ConfigKey -> S.ByteString -> Repo -> S.ByteString -get key defaultValue repo = M.findWithDefault defaultValue key (config repo) +{- Returns a single git config setting, or a fallback value if not set. -} +get :: ConfigKey -> ConfigValue -> Repo -> ConfigValue +get key fallback repo = M.findWithDefault fallback key (config repo) -{- Returns a list with each line of a multiline config setting. -} -getList :: ConfigKey -> Repo -> [S.ByteString] +{- Returns a list of values. -} +getList :: ConfigKey -> Repo -> [ConfigValue] getList key repo = M.findWithDefault [] key (fullconfig repo) {- Returns a single git config setting, if set. -} -getMaybe :: ConfigKey -> Repo -> Maybe S.ByteString +getMaybe :: ConfigKey -> Repo -> Maybe ConfigValue getMaybe key repo = M.lookup key (config repo) {- Runs git config and populates a repo with its config. @@ -100,7 +100,7 @@ store s repo = do {- Stores a single config setting in a Repo, returning the new version of - the Repo. Config settings can be updated incrementally. -} -store' :: ConfigKey -> S.ByteString -> Repo -> Repo +store' :: ConfigKey -> ConfigValue -> Repo -> Repo store' k v repo = repo { config = M.singleton k v `M.union` config repo , fullconfig = M.unionWith (++) (M.singleton k [v]) (fullconfig repo) @@ -128,7 +128,7 @@ updateLocation' :: Repo -> RepoLocation -> IO Repo updateLocation' r l = do l' <- case getMaybe "core.worktree" r of Nothing -> return l - Just d -> do + Just (ConfigValue d) -> do {- core.worktree is relative to the gitdir -} top <- absPath $ gitdir l let p = absPathFrom top (fromRawFilePath d) @@ -137,7 +137,7 @@ updateLocation' r l = do {- Parses git config --list or git config --null --list output into a - config map. -} -parse :: S.ByteString -> M.Map ConfigKey [S.ByteString] +parse :: S.ByteString -> M.Map ConfigKey [ConfigValue] parse s | S.null s = M.empty -- --list output will have a '=' in the first line @@ -152,15 +152,15 @@ parse s firstline = S.takeWhile (/= nl) s sep c = M.fromListWith (++) - . map (\(k,v) -> (ConfigKey k, [S.drop 1 v])) + . map (\(k,v) -> (ConfigKey k, [ConfigValue (S.drop 1 v)])) . map (S.break (== c)) {- Checks if a string from git config is a true value. -} isTrue :: String -> Maybe Bool -isTrue = isTrue' . encodeBS' +isTrue = isTrue' . ConfigValue . encodeBS' -isTrue' :: S.ByteString -> Maybe Bool -isTrue' s +isTrue' :: ConfigValue -> Maybe Bool +isTrue' (ConfigValue s) | s' == "true" = Just True | s' == "false" = Just False | otherwise = Nothing diff --git a/Git/ConfigTypes.hs b/Git/ConfigTypes.hs index db5a1285d1..f01a2cef40 100644 --- a/Git/ConfigTypes.hs +++ b/Git/ConfigTypes.hs @@ -14,6 +14,7 @@ import qualified Data.ByteString.Char8 as S8 import Common import Git +import Git.Types import qualified Git.Config data SharedRepository = UnShared | GroupShared | AllShared | UmaskShared Int @@ -21,23 +22,27 @@ data SharedRepository = UnShared | GroupShared | AllShared | UmaskShared Int getSharedRepository :: Repo -> SharedRepository getSharedRepository r = - case S8.map toLower $ Git.Config.get "core.sharedrepository" "" r of - "1" -> GroupShared - "2" -> AllShared - "group" -> GroupShared - "true" -> GroupShared - "all" -> AllShared - "world" -> AllShared - "everybody" -> AllShared - v -> maybe UnShared UmaskShared (readish (decodeBS' v)) + case Git.Config.getMaybe "core.sharedrepository" r of + Nothing -> UnShared + Just (ConfigValue v) -> case S8.map toLower v of + "1" -> GroupShared + "2" -> AllShared + "group" -> GroupShared + "true" -> GroupShared + "all" -> AllShared + "world" -> AllShared + "everybody" -> AllShared + _ -> maybe UnShared UmaskShared (readish (decodeBS' v)) data DenyCurrentBranch = UpdateInstead | RefusePush | WarnPush | IgnorePush deriving (Eq) getDenyCurrentBranch :: Repo -> DenyCurrentBranch -getDenyCurrentBranch r = - case S8.map toLower $ Git.Config.get "receive.denycurrentbranch" "" r of - "updateinstead" -> UpdateInstead - "warn" -> WarnPush - "ignore" -> IgnorePush - _ -> RefusePush +getDenyCurrentBranch r = + case Git.Config.getMaybe "receive.denycurrentbranch" r of + Just (ConfigValue v) -> case S8.map toLower v of + "updateinstead" -> UpdateInstead + "warn" -> WarnPush + "ignore" -> IgnorePush + _ -> RefusePush + Nothing -> RefusePush diff --git a/Git/Construct.hs b/Git/Construct.hs index 3c907b5840..7a58a5d444 100644 --- a/Git/Construct.hs +++ b/Git/Construct.hs @@ -128,7 +128,7 @@ fromRemotes repo = mapM construct remotepairs filterconfig f = filter f $ M.toList $ config repo filterkeys f = filterconfig (\(k,_) -> f k) remotepairs = filterkeys isRemoteKey - construct (k,v) = remoteNamedFromKey k (fromRemoteLocation (decodeBS' v) repo) + construct (k,v) = remoteNamedFromKey k (fromRemoteLocation (fromConfigValue v) repo) {- Sets the name of a remote when constructing the Repo to represent it. -} remoteNamed :: String -> IO Repo -> IO Repo diff --git a/Git/GCrypt.hs b/Git/GCrypt.hs index 7b9b46d423..7a70a2eaf8 100644 --- a/Git/GCrypt.hs +++ b/Git/GCrypt.hs @@ -79,9 +79,9 @@ type GCryptId = String - which is stored in the repository (in encrypted form) - and cached in a per-remote gcrypt-id configuration setting. -} remoteRepoId :: Repo -> Maybe RemoteName -> Maybe GCryptId -remoteRepoId r n = decodeBS' <$> getRemoteConfig "gcrypt-id" r n +remoteRepoId r n = fromConfigValue <$> getRemoteConfig "gcrypt-id" r n -getRemoteConfig :: S.ByteString -> Repo -> Maybe RemoteName -> Maybe S.ByteString +getRemoteConfig :: S.ByteString -> Repo -> Maybe RemoteName -> Maybe ConfigValue getRemoteConfig field repo remotename = do n <- remotename Config.getMaybe (remoteConfigKey field n) repo @@ -96,8 +96,8 @@ getParticiantList globalconfigrepo repo remotename = KeyIds $ parse $ firstJust ] where defaultkey = "gcrypt.participants" - parse (Just "simple") = [] - parse (Just b) = words (decodeBS' b) + parse (Just (ConfigValue "simple")) = [] + parse (Just (ConfigValue b)) = words (decodeBS' b) parse Nothing = [] remoteParticipantConfigKey :: RemoteName -> ConfigKey diff --git a/Git/Remote.hs b/Git/Remote.hs index 08e67fd624..5ff88a84fd 100644 --- a/Git/Remote.hs +++ b/Git/Remote.hs @@ -84,9 +84,9 @@ parseRemoteLocation s repo = ret $ calcloc s where replacement = decodeBS' $ S.drop (S.length prefix) $ S.take (S.length bestkey - S.length suffix) bestkey - (ConfigKey bestkey, bestvalue) = maximumBy longestvalue insteadofs + (ConfigKey bestkey, ConfigValue bestvalue) = maximumBy longestvalue insteadofs longestvalue (_, a) (_, b) = compare b a - insteadofs = filterconfig $ \(ConfigKey k, v) -> + insteadofs = filterconfig $ \(ConfigKey k, ConfigValue v) -> prefix `S.isPrefixOf` k && suffix `S.isSuffixOf` k && v `S.isPrefixOf` encodeBS l diff --git a/Git/Types.hs b/Git/Types.hs index c8688c625c..45adc1f377 100644 --- a/Git/Types.hs +++ b/Git/Types.hs @@ -6,11 +6,13 @@ -} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Git.Types where import Network.URI import Data.String +import Data.Default import qualified Data.Map as M import qualified Data.ByteString as S import System.Posix.Types @@ -36,9 +38,9 @@ data RepoLocation data Repo = Repo { location :: RepoLocation - , config :: M.Map ConfigKey S.ByteString + , config :: M.Map ConfigKey ConfigValue -- a given git config key can actually have multiple values - , fullconfig :: M.Map ConfigKey [S.ByteString] + , fullconfig :: M.Map ConfigKey [ConfigValue] -- remoteName holds the name used for this repo in some other -- repo's list of remotes, when this repo is such a remote , remoteName :: Maybe RemoteName @@ -52,15 +54,30 @@ data Repo = Repo newtype ConfigKey = ConfigKey S.ByteString deriving (Ord, Eq) +newtype ConfigValue = ConfigValue S.ByteString + deriving (Ord, Eq, Semigroup, Monoid) + +instance Default ConfigValue where + def = ConfigValue mempty + fromConfigKey :: ConfigKey -> String fromConfigKey (ConfigKey s) = decodeBS' s instance Show ConfigKey where show = fromConfigKey +fromConfigValue :: ConfigValue -> String +fromConfigValue (ConfigValue s) = decodeBS' s + +instance Show ConfigValue where + show = fromConfigValue + instance IsString ConfigKey where fromString = ConfigKey . encodeBS' +instance IsString ConfigValue where + fromString = ConfigValue . encodeBS' + type RemoteName = String {- A git ref. Can be a sha1, or a branch or tag name. -} diff --git a/Logs/Config.hs b/Logs/Config.hs index 068a12a061..1271c9826c 100644 --- a/Logs/Config.hs +++ b/Logs/Config.hs @@ -6,8 +6,8 @@ -} module Logs.Config ( - ConfigKey, - ConfigValue, + ConfigKey(..), + ConfigValue(..), setGlobalConfig, unsetGlobalConfig, getGlobalConfig, @@ -18,7 +18,7 @@ import Annex.Common import Logs import Logs.MapLog import qualified Annex.Branch -import Git.Types (ConfigKey(..)) +import Git.Types (ConfigKey(..), ConfigValue(..)) import qualified Data.Map as M import qualified Data.ByteString as S @@ -26,8 +26,6 @@ import qualified Data.ByteString.Lazy as L import qualified Data.Attoparsec.ByteString.Lazy as A import Data.ByteString.Builder -type ConfigValue = S.ByteString - setGlobalConfig :: ConfigKey -> ConfigValue -> Annex () setGlobalConfig name new = do curr <- getGlobalConfig name @@ -44,7 +42,8 @@ unsetGlobalConfig :: ConfigKey -> Annex () unsetGlobalConfig name = do curr <- getGlobalConfig name when (curr /= Nothing) $ - setGlobalConfig' name mempty -- set to empty string to unset + -- set to empty string to unset + setGlobalConfig' name (ConfigValue mempty) -- Reads the global config log every time. getGlobalConfig :: ConfigKey -> Annex (Maybe ConfigValue) @@ -53,15 +52,17 @@ getGlobalConfig name = M.lookup name <$> loadGlobalConfig buildGlobalConfig :: MapLog ConfigKey ConfigValue -> Builder buildGlobalConfig = buildMapLog configkeybuilder valuebuilder where - configkeybuilder (ConfigKey f) = byteString f - valuebuilder = byteString + configkeybuilder (ConfigKey k) = byteString k + valuebuilder (ConfigValue v) = byteString v parseGlobalConfig :: L.ByteString -> MapLog ConfigKey ConfigValue parseGlobalConfig = parseMapLog configkeyparser valueparser where configkeyparser = ConfigKey <$> A.takeByteString - valueparser = A.takeByteString + valueparser = ConfigValue <$> A.takeByteString loadGlobalConfig :: Annex (M.Map ConfigKey ConfigValue) -loadGlobalConfig = M.filter (not . S.null) . simpleMap . parseGlobalConfig +loadGlobalConfig = M.filter (\(ConfigValue v) -> not (S.null v)) + . simpleMap + . parseGlobalConfig <$> Annex.Branch.get configLog diff --git a/Remote.hs b/Remote.hs index 771e9b67ba..fb096736ee 100644 --- a/Remote.hs +++ b/Remote.hs @@ -74,7 +74,7 @@ import Logs.Web import Remote.List import Config import Config.DynamicConfig -import Git.Types (RemoteName, ConfigKey(..)) +import Git.Types (RemoteName, ConfigKey(..), fromConfigValue) import Utility.Aeson {- Map from UUIDs of Remotes to a calculated value. -} @@ -150,7 +150,7 @@ byNameOrGroup :: RemoteName -> Annex [Remote] byNameOrGroup n = go =<< getConfigMaybe (ConfigKey ("remotes." <> encodeBS' n)) where go (Just l) = catMaybes - <$> mapM (byName . Just) (splitc ' ' (decodeBS' l)) + <$> mapM (byName . Just) (splitc ' ' (fromConfigValue l)) go Nothing = maybeToList <$> byName (Just n) diff --git a/Remote/Bup.hs b/Remote/Bup.hs index dfce6a188d..8fa00cbc41 100644 --- a/Remote/Bup.hs +++ b/Remote/Bup.hs @@ -16,7 +16,7 @@ import Annex.Common import qualified Annex import Types.Remote import Types.Creds -import Git.Types (fromConfigKey) +import Git.Types (ConfigValue(..), fromConfigKey) import qualified Git import qualified Git.Command import qualified Git.Config @@ -213,7 +213,7 @@ storeBupUUID u buprepo = do giveup "ssh failed" else liftIO $ do r' <- Git.Config.read r - let olduuid = Git.Config.get configkeyUUID mempty r' + let ConfigValue olduuid = Git.Config.get configkeyUUID mempty r' when (S.null olduuid) $ Git.Command.run [ Param "config" diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs index 7fe83a0a5a..4682637eaf 100644 --- a/Remote/GCrypt.hs +++ b/Remote/GCrypt.hs @@ -30,7 +30,7 @@ import Types.GitConfig import Types.Crypto import Types.Creds import Types.Transfer -import Git.Types (ConfigKey(..), fromConfigKey) +import Git.Types (ConfigKey(..), fromConfigKey, fromConfigValue) import qualified Git import qualified Git.Command import qualified Git.Config @@ -462,7 +462,7 @@ getGCryptId fast r gc | otherwise = return (Nothing, r) where extract Nothing = (Nothing, r) - extract (Just r') = (decodeBS' <$> Git.Config.getMaybe coreGCryptId r', r') + extract (Just r') = (fromConfigValue <$> Git.Config.getMaybe coreGCryptId r', r') getConfigViaRsync :: Git.Repo -> RemoteGitConfig -> Annex (Either SomeException (Git.Repo, S.ByteString)) getConfigViaRsync r gc = do diff --git a/Remote/Git.hs b/Remote/Git.hs index f4f2ddfcb1..7dc85aa629 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -95,7 +95,7 @@ list autoinit = do Nothing -> return r Just url -> inRepo $ \g -> Git.Construct.remoteNamed n $ - Git.Construct.fromRemoteLocation (decodeBS' url) g + Git.Construct.fromRemoteLocation (Git.fromConfigValue url) g {- Git remotes are normally set up using standard git command, not - git-annex initremote and enableremote. diff --git a/Remote/GitLFS.hs b/Remote/GitLFS.hs index 624f90c3e7..fb4f2fce8c 100644 --- a/Remote/GitLFS.hs +++ b/Remote/GitLFS.hs @@ -189,7 +189,7 @@ configKnownUrl r set k v r' = do let k' = remoteConfig r' k setConfig k' v - return $ Git.Config.store' k' (encodeBS' v) r' + return $ Git.Config.store' k' (Git.ConfigValue (encodeBS' v)) r' data LFSHandle = LFSHandle { downloadEndpoint :: Maybe LFS.Endpoint diff --git a/Remote/Hook.hs b/Remote/Hook.hs index 1cc426f466..f0a67d808e 100644 --- a/Remote/Hook.hs +++ b/Remote/Hook.hs @@ -11,7 +11,7 @@ import Annex.Common import Types.Remote import Types.Creds import qualified Git -import Git.Types (fromConfigKey) +import Git.Types (fromConfigKey, fromConfigValue) import Config import Config.Cost import Annex.UUID @@ -108,10 +108,10 @@ hookEnv action k f = Just <$> mergeenv (fileenv f ++ keyenv) lookupHook :: HookName -> Action -> Annex (Maybe String) lookupHook hookname action = do - command <- decodeBS' <$> getConfig hook mempty + command <- fromConfigValue <$> getConfig hook mempty if null command then do - fallback <- decodeBS' <$> getConfig hookfallback mempty + fallback <- fromConfigValue <$> getConfig hookfallback mempty if null fallback then do warning $ "missing configuration for " ++ fromConfigKey hook ++ " or " ++ fromConfigKey hookfallback diff --git a/Test.hs b/Test.hs index bbe0f37431..4752ff07e2 100644 --- a/Test.hs +++ b/Test.hs @@ -204,17 +204,12 @@ properties = localOption (QuickCheckTests 1000) $ testGroup "QuickCheck" - of git-annex. They are always run before the unitTests. -} initTests :: TestTree initTests = testGroup "Init Tests" - [] -{- [ testCase "init" test_init , testCase "add" test_add ] --} unitTests :: String -> TestTree unitTests note = testGroup ("Unit Tests " ++ note) - [] -{- [ testCase "add dup" test_add_dup , testCase "add extras" test_add_extras , testCase "export_import" test_export_import @@ -629,7 +624,7 @@ test_lock_force = intmpclonerepo $ do git_annex "get" [annexedfile] @? "get of file failed" git_annex "unlock" [annexedfile] @? "unlock failed" annexeval $ do - Just k <- Annex.WorkTree.lookupFile annexedfile + Just k <- Annex.WorkTree.lookupFile (toRawFilePath annexedfile) Database.Keys.removeInodeCaches k Database.Keys.closeDb liftIO . nukeFile =<< Annex.fromRepo Annex.Locations.gitAnnexKeysDbIndexCache @@ -1151,7 +1146,7 @@ test_mixed_conflict_resolution = do @? (what ++ " too many variant files in: " ++ show v) indir d $ do git_annex "get" (conflictor:v) @? ("get failed in " ++ what) - git_annex_expectoutput "find" [conflictor] [Git.FilePath.toInternalGitPath subfile] + git_annex_expectoutput "find" [conflictor] [fromRawFilePath (Git.FilePath.toInternalGitPath (toRawFilePath subfile))] git_annex_expectoutput "find" v v {- Check merge conflict resolution when both repos start with an annexed @@ -1348,7 +1343,7 @@ test_conflict_resolution_symlink_bit = unlessM (hasUnlockedFiles <$> getTestMode where conflictor = "conflictor" check_is_link f what = do - git_annex_expectoutput "find" ["--include=*", f] [Git.FilePath.toInternalGitPath f] + git_annex_expectoutput "find" ["--include=*", f] [fromRawFilePath (Git.FilePath.toInternalGitPath (toRawFilePath f))] l <- annexeval $ Annex.inRepo $ Git.LsTree.lsTreeFiles Git.Ref.headRef [f] all (\i -> Git.Types.toTreeItemType (Git.LsTree.mode i) == Just Git.Types.TreeSymlink) l @? (what ++ " " ++ f ++ " lost symlink bit after merge: " ++ show l) @@ -1603,7 +1598,7 @@ test_crypto = do (c,k) <- annexeval $ do uuid <- Remote.nameToUUID "foo" rs <- Logs.Remote.readRemoteLog - Just k <- Annex.WorkTree.lookupFile annexedfile + Just k <- Annex.WorkTree.lookupFile (toRawFilePath annexedfile) return (fromJust $ M.lookup uuid rs, k) let key = if scheme `elem` ["hybrid","pubkey"] then Just $ Utility.Gpg.KeyIds [Utility.Gpg.testKeyId] @@ -1781,5 +1776,3 @@ test_export_import_subdir = intmpclonerepo $ do -- Make sure that import did not import the file to the top -- of the repo. checkdoesnotexist annexedfile - --} diff --git a/Test/Framework.hs b/Test/Framework.hs index b02bcc384c..8f3a773bd3 100644 --- a/Test/Framework.hs +++ b/Test/Framework.hs @@ -89,8 +89,9 @@ inmainrepo a = do with_ssh_origin :: (Assertion -> Assertion) -> (Assertion -> Assertion) with_ssh_origin cloner a = cloner $ do - origindir <- absPath . decodeBS' - =<< annexeval (Config.getConfig (Git.Types.ConfigKey (encodeBS' config)) (toRawFilePath "/dev/null")) + let k = Git.Types.ConfigKey (encodeBS' config) + let v = Git.Types.ConfigValue (toRawFilePath "/dev/null") + origindir <- absPath . Git.Types.fromConfigValue =<< annexeval (Config.getConfig k v) let originurl = "localhost:" ++ origindir boolSystem "git" [Param "config", Param config, Param originurl] @? "git config failed" a diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs index 73dd70cfcc..df2cd6bb1f 100644 --- a/Types/GitConfig.hs +++ b/Types/GitConfig.hs @@ -203,9 +203,9 @@ extractGitConfig r = GitConfig getbool k d = fromMaybe d $ getmaybebool k getmaybebool k = Git.Config.isTrue' =<< getmaybe' k getmayberead k = readish =<< getmaybe k - getmaybe = fmap decodeBS' . getmaybe' + getmaybe = fmap fromConfigValue . getmaybe' getmaybe' k = Git.Config.getMaybe k r - getlist k = map decodeBS' $ Git.Config.getList k r + getlist k = map fromConfigValue $ Git.Config.getList k r getwords k = fromMaybe [] $ words <$> getmaybe k configurable d Nothing = DefaultConfig d @@ -345,7 +345,7 @@ extractRemoteGitConfig r remotename = do getbool k d = fromMaybe d $ getmaybebool k getmaybebool k = Git.Config.isTrue' =<< getmaybe' k getmayberead k = readish =<< getmaybe k - getmaybe = fmap decodeBS' . getmaybe' + getmaybe = fmap fromConfigValue . getmaybe' getmaybe' k = mplus (Git.Config.getMaybe (key k) r) (Git.Config.getMaybe (remotekey k) r) getoptions k = fromMaybe [] $ words <$> getmaybe k diff --git a/Types/UUID.hs b/Types/UUID.hs index 726875b3a8..92f5ed9e17 100644 --- a/Types/UUID.hs +++ b/Types/UUID.hs @@ -17,6 +17,7 @@ import Data.String import Data.ByteString.Builder import qualified Data.Semigroup as Sem +import Git.Types (ConfigValue(..)) import Utility.FileSystemEncoding import Utility.QuickCheck import qualified Utility.SimpleProtocol as Proto @@ -52,6 +53,12 @@ instance FromUUID String where instance ToUUID String where toUUID s = toUUID (encodeBS' s) +instance FromUUID ConfigValue where + fromUUID s = (ConfigValue (fromUUID s)) + +instance ToUUID ConfigValue where + toUUID (ConfigValue v) = toUUID v + -- There is no matching FromUUID U.UUID because a git-annex UUID may -- be NoUUID or perhaps contain something not allowed in a canonical UUID. instance ToUUID U.UUID where diff --git a/Upgrade/V5/Direct.hs b/Upgrade/V5/Direct.hs index 2e6ca9b0b4..3f67959976 100644 --- a/Upgrade/V5/Direct.hs +++ b/Upgrade/V5/Direct.hs @@ -51,7 +51,7 @@ setIndirect = do Nothing -> noop Just wt -> do unsetConfig src - setConfig dest (decodeBS' wt) + setConfig dest (fromConfigValue wt) reloadConfig {- Converts a directBranch back to the original branch. diff --git a/git-annex.cabal b/git-annex.cabal index 1b695b10ae..5d8ba73914 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -407,16 +407,16 @@ Executable git-annex if flag(S3) Build-Depends: aws (>= 0.20) CPP-Options: -DWITH_S3 - Other-Modules-temp-disabled: Remote.S3 + Other-Modules: Remote.S3 if flag(WebDAV) Build-Depends: DAV (>= 1.0) CPP-Options: -DWITH_WEBDAV - Other-Modules-temp-disabled: + Other-Modules: Remote.WebDAV Remote.WebDAV.DavLocation if flag(S3) || flag(WebDAV) - Other-Modules-temp-disabled: + Other-Modules: Remote.Helper.Http if flag(Assistant) && ! os(solaris) && ! os(gnu) @@ -602,7 +602,7 @@ Executable git-annex if flag(DebugLocks) CPP-Options: -DDEBUGLOCKS - Other-Modules-Temp-Disabled: + Other-Modules: Annex Annex.Action Annex.AdjustedBranch @@ -860,6 +860,7 @@ Executable git-annex Git.RefLog Git.Remote Git.Remote.Remove + Git.Repair Git.Sha Git.Ssh Git.Status From 3266ad3ff7b4cdc50cc0593c698f25da7155c7f8 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 5 Dec 2019 15:10:23 -0400 Subject: [PATCH 16/42] everything is building again However, the test suite fails some quickchecks, so this branch is not yet in a mergeable state. --- Assistant/MakeRemote.hs | 2 ++ Assistant/MakeRepo.hs | 2 ++ Assistant/Sync.hs | 2 ++ Assistant/Threads/Committer.hs | 8 +++--- Assistant/Threads/ConfigMonitor.hs | 11 ++++---- Assistant/Threads/SanityChecker.hs | 5 ++-- Assistant/Threads/Watcher.hs | 34 ++++++++++++++----------- Assistant/TransferSlots.hs | 2 +- Assistant/Upgrade.hs | 2 +- Assistant/WebApp/Configurators/Edit.hs | 5 ++-- Assistant/WebApp/Configurators/Local.hs | 2 +- Assistant/WebApp/Configurators/Ssh.hs | 5 ++-- Assistant/WebApp/DashBoard.hs | 2 +- Command/WebApp.hs | 4 ++- 14 files changed, 51 insertions(+), 35 deletions(-) diff --git a/Assistant/MakeRemote.hs b/Assistant/MakeRemote.hs index 99d68ab82d..ba4df37f97 100644 --- a/Assistant/MakeRemote.hs +++ b/Assistant/MakeRemote.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Assistant.MakeRemote where import Assistant.Common diff --git a/Assistant/MakeRepo.hs b/Assistant/MakeRepo.hs index 67e83ef5cd..f1dac121d2 100644 --- a/Assistant/MakeRepo.hs +++ b/Assistant/MakeRepo.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Assistant.MakeRepo where import Assistant.WebApp.Common diff --git a/Assistant/Sync.hs b/Assistant/Sync.hs index c528cf565f..4a90b09943 100644 --- a/Assistant/Sync.hs +++ b/Assistant/Sync.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Assistant.Sync where import Assistant.Common diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs index 09fac0b311..5ed49166bb 100644 --- a/Assistant/Threads/Committer.hs +++ b/Assistant/Threads/Committer.hs @@ -286,7 +286,7 @@ handleAdds lockdowndir havelsof delayadd cs = returnWhen (null incomplete) $ do ks = keySource ld doadd = sanitycheck ks $ do (mkey, _mcache) <- liftAnnex $ do - showStart "add" $ keyFilename ks + showStart "add" $ toRawFilePath $ keyFilename ks ingest nullMeterUpdate (Just $ LockedDown lockdownconfig ks) Nothing maybe (failedingest change) (done change $ keyFilename ks) mkey add _ _ = return Nothing @@ -325,7 +325,7 @@ handleAdds lockdowndir havelsof delayadd cs = returnWhen (null incomplete) $ do removedKeysMap :: InodeComparisonType -> [Change] -> Annex (M.Map InodeCacheKey Key) removedKeysMap ct l = do mks <- forM (filter isRmChange l) $ \c -> - catKeyFile $ changeFile c + catKeyFile $ toRawFilePath $ changeFile c M.fromList . concat <$> mapM mkpairs (catMaybes mks) where mkpairs k = map (\c -> (inodeCacheToKey ct c, k)) <$> @@ -339,7 +339,7 @@ handleAdds lockdowndir havelsof delayadd cs = returnWhen (null incomplete) $ do done change file key = liftAnnex $ do logStatus key InfoPresent mode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus file - stagePointerFile file mode =<< hashPointerFile key + stagePointerFile (toRawFilePath file) mode =<< hashPointerFile key showEndOk return $ Just $ finishedChange change key @@ -457,5 +457,5 @@ checkChangeContent change@(Change { changeInfo = i }) = handleDrops "file renamed" present k af [] where f = changeFile change - af = AssociatedFile (Just f) + af = AssociatedFile (Just (toRawFilePath f)) checkChangeContent _ = noop diff --git a/Assistant/Threads/ConfigMonitor.hs b/Assistant/Threads/ConfigMonitor.hs index cbfd8c823b..cabda5d259 100644 --- a/Assistant/Threads/ConfigMonitor.hs +++ b/Assistant/Threads/ConfigMonitor.hs @@ -44,7 +44,8 @@ configMonitorThread = namedThread "ConfigMonitor" $ loop =<< getConfigs when (old /= new) $ do let changedconfigs = new `S.difference` old debug $ "reloading config" : - map fst (S.toList changedconfigs) + map (fromRawFilePath . fst) + (S.toList changedconfigs) reloadConfigs new {- Record a commit to get this config - change pushed out to remotes. -} @@ -53,10 +54,10 @@ configMonitorThread = namedThread "ConfigMonitor" $ loop =<< getConfigs loop new {- Config files, and their checksums. -} -type Configs = S.Set (FilePath, Sha) +type Configs = S.Set (RawFilePath, Sha) {- All git-annex's config files, and actions to run when they change. -} -configFilesActions :: [(FilePath, Assistant ())] +configFilesActions :: [(RawFilePath, Assistant ())] configFilesActions = [ (uuidLog, void $ liftAnnex uuidDescMapLoad) , (remoteLog, void $ liftAnnex remoteListRefresh) @@ -89,5 +90,5 @@ getConfigs :: Assistant Configs getConfigs = S.fromList . map extract <$> liftAnnex (inRepo $ LsTree.lsTreeFiles Annex.Branch.fullname files) where - files = map fst configFilesActions - extract treeitem = (getTopFilePath $ LsTree.file treeitem, LsTree.sha treeitem) + files = map (fromRawFilePath . fst) configFilesActions + extract treeitem = (toRawFilePath $ getTopFilePath $ LsTree.file treeitem, LsTree.sha treeitem) diff --git a/Assistant/Threads/SanityChecker.hs b/Assistant/Threads/SanityChecker.hs index bc65d9aa6f..28beacb2ea 100644 --- a/Assistant/Threads/SanityChecker.hs +++ b/Assistant/Threads/SanityChecker.hs @@ -155,10 +155,11 @@ dailyCheck urlrenderer = do (unstaged, cleanup) <- liftIO $ Git.LsFiles.notInRepo False ["."] g now <- liftIO getPOSIXTime forM_ unstaged $ \file -> do - ms <- liftIO $ catchMaybeIO $ getSymbolicLinkStatus file + let file' = fromRawFilePath file + ms <- liftIO $ catchMaybeIO $ getSymbolicLinkStatus file' case ms of Just s | toonew (statusChangeTime s) now -> noop - | isSymbolicLink s -> addsymlink file ms + | isSymbolicLink s -> addsymlink file' ms _ -> noop liftIO $ void cleanup diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs index 67c986301b..5322998644 100644 --- a/Assistant/Threads/Watcher.hs +++ b/Assistant/Threads/Watcher.hs @@ -136,10 +136,12 @@ startupScan scanner = do -- Notice any files that were deleted before -- watching was started. top <- liftAnnex $ fromRepo Git.repoPath - (fs, cleanup) <- liftAnnex $ inRepo $ LsFiles.deleted [top] + (fs, cleanup) <- liftAnnex $ inRepo $ LsFiles.deleted + [toRawFilePath top] forM_ fs $ \f -> do - liftAnnex $ onDel' f - maybe noop recordChange =<< madeChange f RmChange + let f' = fromRawFilePath f + liftAnnex $ onDel' f' + maybe noop recordChange =<< madeChange f' RmChange void $ liftIO cleanup liftAnnex $ showAction "started" @@ -206,7 +208,7 @@ shouldRestage ds = scanComplete ds || forceRestage ds onAddUnlocked :: Bool -> GetFileMatcher -> Handler onAddUnlocked symlinkssupported matcher f fs = do - mk <- liftIO $ isPointerFile f + mk <- liftIO $ isPointerFile $ toRawFilePath f case mk of Nothing -> onAddUnlocked' contentchanged addassociatedfile addlink samefilestatus symlinkssupported matcher f fs Just k -> addlink f k @@ -228,7 +230,7 @@ onAddUnlocked symlinkssupported matcher f fs = do logStatus oldkey InfoMissing addlink file key = do mode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus file - liftAnnex $ stagePointerFile file mode =<< hashPointerFile key + liftAnnex $ stagePointerFile (toRawFilePath file) mode =<< hashPointerFile key madeChange file $ LinkChange (Just key) onAddUnlocked' @@ -240,7 +242,7 @@ onAddUnlocked' -> GetFileMatcher -> Handler onAddUnlocked' contentchanged addassociatedfile addlink samefilestatus symlinkssupported matcher file fs = do - v <- liftAnnex $ catKeyFile file + v <- liftAnnex $ catKeyFile (toRawFilePath file) case (v, fs) of (Just key, Just filestatus) -> ifM (liftAnnex $ samefilestatus key file filestatus) @@ -270,7 +272,8 @@ onAddUnlocked' contentchanged addassociatedfile addlink samefilestatus symlinkss guardSymlinkStandin mk a | symlinkssupported = a | otherwise = do - linktarget <- liftAnnex $ getAnnexLinkTarget file + linktarget <- liftAnnex $ getAnnexLinkTarget $ + toRawFilePath file case linktarget of Nothing -> a Just lt -> do @@ -287,7 +290,7 @@ onAddUnlocked' contentchanged addassociatedfile addlink samefilestatus symlinkss onAddSymlink :: Handler onAddSymlink file filestatus = unlessIgnored file $ do linktarget <- liftIO (catchMaybeIO $ readSymbolicLink file) - kv <- liftAnnex (lookupFile file) + kv <- liftAnnex (lookupFile (toRawFilePath file)) onAddSymlink' linktarget kv file filestatus onAddSymlink' :: Maybe String -> Maybe Key -> Handler @@ -299,7 +302,7 @@ onAddSymlink' linktarget mk file filestatus = go mk then ensurestaged (Just link) =<< getDaemonStatus else do liftAnnex $ replaceFile file $ - makeAnnexLink link + makeAnnexLink link . toRawFilePath addLink file link (Just key) -- other symlink, not git-annex go Nothing = ensurestaged linktarget =<< getDaemonStatus @@ -332,8 +335,8 @@ addLink file link mk = do case v of Just (currlink, sha, _type) | s2w8 link == L.unpack currlink -> - stageSymlink file sha - _ -> stageSymlink file =<< hashSymlink link + stageSymlink (toRawFilePath file) sha + _ -> stageSymlink (toRawFilePath file) =<< hashSymlink link madeChange file $ LinkChange mk onDel :: Handler @@ -349,7 +352,7 @@ onDel' file = do Annex.Queue.addUpdateIndex =<< inRepo (Git.UpdateIndex.unstageFile file) where - withkey a = maybe noop a =<< catKeyFile file + withkey a = maybe noop a =<< catKeyFile (toRawFilePath file) {- A directory has been deleted, or moved, so tell git to remove anything - that was inside it from its cache. Since it could reappear at any time, @@ -360,14 +363,15 @@ onDel' file = do onDelDir :: Handler onDelDir dir _ = do debug ["directory deleted", dir] - (fs, clean) <- liftAnnex $ inRepo $ LsFiles.deleted [dir] + (fs, clean) <- liftAnnex $ inRepo $ LsFiles.deleted [toRawFilePath dir] + let fs' = map fromRawFilePath fs - liftAnnex $ mapM_ onDel' fs + liftAnnex $ mapM_ onDel' fs' -- Get the events queued up as fast as possible, so the -- committer sees them all in one block. now <- liftIO getCurrentTime - recordChanges $ map (\f -> Change now f RmChange) fs + recordChanges $ map (\f -> Change now f RmChange) fs' void $ liftIO clean noChange diff --git a/Assistant/TransferSlots.hs b/Assistant/TransferSlots.hs index 6dacefbf45..5b555548e7 100644 --- a/Assistant/TransferSlots.hs +++ b/Assistant/TransferSlots.hs @@ -161,7 +161,7 @@ genTransfer t info = case transferRemote info of AssociatedFile Nothing -> noop AssociatedFile (Just af) -> void $ addAlert $ makeAlertFiller True $ - transferFileAlert direction True af + transferFileAlert direction True (fromRawFilePath af) unless isdownload $ handleDrops ("object uploaded to " ++ show remote) diff --git a/Assistant/Upgrade.hs b/Assistant/Upgrade.hs index 53eeac3222..0ea52f3158 100644 --- a/Assistant/Upgrade.hs +++ b/Assistant/Upgrade.hs @@ -87,7 +87,7 @@ startDistributionDownload d = go =<< liftIO . newVersionLocation d =<< liftIO ol hook <- asIO1 $ distributionDownloadComplete d dest cleanup modifyDaemonStatus_ $ \s -> s { transferHook = M.insert k hook (transferHook s) } - maybe noop (queueTransfer "upgrade" Next (AssociatedFile (Just f)) t) + maybe noop (queueTransfer "upgrade" Next (AssociatedFile (Just (toRawFilePath f))) t) =<< liftAnnex (remoteFromUUID webUUID) startTransfer t k = mkKey $ const $ distributionKey d diff --git a/Assistant/WebApp/Configurators/Edit.hs b/Assistant/WebApp/Configurators/Edit.hs index 1237f22339..b711761a42 100644 --- a/Assistant/WebApp/Configurators/Edit.hs +++ b/Assistant/WebApp/Configurators/Edit.hs @@ -101,11 +101,12 @@ setRepoConfig uuid mremote oldc newc = do - there's not. Special remotes don't normally - have that, and don't use it. Temporarily add - it if it's missing. -} - let remotefetch = "remote." ++ T.unpack (repoName oldc) ++ ".fetch" + let remotefetch = Git.ConfigKey $ encodeBS' $ + "remote." ++ T.unpack (repoName oldc) ++ ".fetch" needfetch <- isNothing <$> fromRepo (Git.Config.getMaybe remotefetch) when needfetch $ inRepo $ Git.Command.run - [Param "config", Param remotefetch, Param ""] + [Param "config", Param (Git.fromConfigKey remotefetch), Param ""] inRepo $ Git.Command.run [ Param "remote" , Param "rename" diff --git a/Assistant/WebApp/Configurators/Local.hs b/Assistant/WebApp/Configurators/Local.hs index eb52be0093..faf3cde57e 100644 --- a/Assistant/WebApp/Configurators/Local.hs +++ b/Assistant/WebApp/Configurators/Local.hs @@ -336,7 +336,7 @@ getFinishAddDriveR drive = go isnew <- liftIO $ makeRepo dir True {- Removable drives are not reliable media, so enable fsync. -} liftIO $ inDir dir $ - setConfig (ConfigKey "core.fsyncobjectfiles") + setConfig "core.fsyncobjectfiles" (Git.Config.boolConfig True) (u, r) <- a isnew when isnew $ diff --git a/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs index b140e99dcc..9ed76bef48 100644 --- a/Assistant/WebApp/Configurators/Ssh.hs +++ b/Assistant/WebApp/Configurators/Ssh.hs @@ -20,7 +20,7 @@ import Types.StandardGroups import Utility.UserInfo import Utility.Gpg import Types.Remote (RemoteConfig) -import Git.Types (RemoteName, fromRef) +import Git.Types (RemoteName, fromRef, fromConfigKey) import qualified Remote.GCrypt as GCrypt import qualified Annex import qualified Git.Command @@ -317,7 +317,8 @@ testServer sshinput@(SshInput { inputHostname = Just hn }) = do else T.pack $ "Failed to ssh to the server. Transcript: " ++ s finduuid (k, v) | k == "annex.uuid" = Just $ toUUID v - | k == GCrypt.coreGCryptId = Just $ genUUIDInNameSpace gCryptNameSpace v + | k == fromConfigKey GCrypt.coreGCryptId = + Just $ genUUIDInNameSpace gCryptNameSpace v | otherwise = Nothing checkcommand c = "if which " ++ c ++ "; then " ++ report c ++ "; fi" diff --git a/Assistant/WebApp/DashBoard.hs b/Assistant/WebApp/DashBoard.hs index 09a1e5f047..6b9d8787cb 100644 --- a/Assistant/WebApp/DashBoard.hs +++ b/Assistant/WebApp/DashBoard.hs @@ -45,7 +45,7 @@ transfersDisplay = do transferPaused info || isNothing (startedTime info) desc transfer info = case associatedFile info of AssociatedFile Nothing -> serializeKey $ transferKey transfer - AssociatedFile (Just af) -> af + AssociatedFile (Just af) -> fromRawFilePath af {- Simplifies a list of transfers, avoiding display of redundant - equivilant transfers. -} diff --git a/Command/WebApp.hs b/Command/WebApp.hs index 3f8002d68b..95bd8af9d4 100644 --- a/Command/WebApp.hs +++ b/Command/WebApp.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} module Command.WebApp where @@ -22,6 +23,7 @@ import Utility.Daemon (checkDaemon) import Utility.UserInfo import Annex.Init import qualified Git +import Git.Types (fromConfigValue) import qualified Git.Config import qualified Git.CurrentRepo import qualified Annex @@ -229,7 +231,7 @@ openBrowser' mcmd htmlshim realurl outh errh = {- web.browser is a generic git config setting for a web browser program -} webBrowser :: Git.Repo -> Maybe FilePath -webBrowser = Git.Config.getMaybe "web.browser" +webBrowser = fmap fromConfigValue <$> Git.Config.getMaybe "web.browser" fileUrl :: FilePath -> String fileUrl file = "file://" ++ file From faf5415163b3ea7e78335ead4c2baf3d7a283be1 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 6 Dec 2019 12:14:55 -0400 Subject: [PATCH 17/42] add back lost filtering of multibyte chars in prop_encode_decode_roundtrip I had thought using ByteString would avoid the problem, but the quickcheck property is still taking Arbitrary String input, so the use of ByteString internally doesn't matter. --- Git/Filename.hs | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/Git/Filename.hs b/Git/Filename.hs index 0b0c4c27bf..1fe0d14158 100644 --- a/Git/Filename.hs +++ b/Git/Filename.hs @@ -35,6 +35,13 @@ decode b = case S.uncons b of encode :: RawFilePath -> S.ByteString encode s = encodeBS $ "\"" ++ encode_c (decodeBS s) ++ "\"" -{- For quickcheck. -} +{- For quickcheck. + - + - See comment on Utility.Format.prop_encode_c_decode_c + -_roundtrip for + - why this only tests chars < 256 + -} prop_encode_decode_roundtrip :: FilePath -> Bool -prop_encode_decode_roundtrip s = s == fromRawFilePath (decode (encode (toRawFilePath s))) +prop_encode_decode_roundtrip s = s' == fromRawFilePath (decode (encode (toRawFilePath s'))) + where + s' = filter (\c -> ord c < 256) s From 3ece4758c6538730991ee8a486f6d8b82e4dffa4 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 6 Dec 2019 12:44:18 -0400 Subject: [PATCH 18/42] fix Arbitrary AssociatedFile Empty filenames were already filtered out as not allowed. But before the change to ByteString, a NUL could appear in an Arbitrary String, and so Arbitrary AssociatedFile sometimes generated illegal filenames, as NUL never appears in a filename. The change to ByteString meant the String was run through toRawFilePath, which assumes a filename never contains a NUL. That truncated the String at the NUL, which could result in an AssociatedFile being generated with an empty filename. The filtering of NUL added here is not really necessary, because of the truncation, but it makes explicit that NUL is not allowed. The real fix is that the suchThat now applies to the final AssociatedFile, so will catch any empty ones however generated. This raises the more general question of whether toRawFilePath might truncate other strings that later get used as filenames. I think new bugs probably won't be introduced by that. Before, a FilePath that got read from somewhere (eg an attacker) and contained a NUL would perhaps be printed out by git-annex, including the NUL, or written to disk inside a file, or what have you. But as soon as that FilePath gets passed to any IO action that treats it as a filename, it gets truncated after the NUL. Eg, writeFile "foo\NULbar" "bar" writes to file "foo". Now toRawFilePath will make the truncation happen earler, but at most this will affect what gets printed out or is written to disk inside a file; actually using the RawFilePath as a filename will not change from using the FilePath as a filename. --- Key.hs | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/Key.hs b/Key.hs index 7fe5312cb7..723ee39a45 100644 --- a/Key.hs +++ b/Key.hs @@ -78,10 +78,13 @@ instance Arbitrary KeyData where <*> ((abs <$>) <$> arbitrary) -- chunksize cannot be negative <*> ((succ . abs <$>) <$> arbitrary) -- chunknum cannot be 0 or negative --- AssociatedFile cannot be empty (but can be Nothing) +-- AssociatedFile cannot be empty, and cannot contain a NUL +-- (but can be Nothing) instance Arbitrary AssociatedFile where - arbitrary = AssociatedFile . fmap toRawFilePath - <$> arbitrary `suchThat` (/= Just "") + arbitrary = (AssociatedFile . fmap mk <$> arbitrary) + `suchThat` (/= AssociatedFile (Just S.empty)) + where + mk = toRawFilePath . filter (/= '\NUL') instance Arbitrary Key where arbitrary = mkKey . const <$> arbitrary From 4aaef14c616cfe756c84f310ffa819f49cc90c34 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 6 Dec 2019 13:12:35 -0400 Subject: [PATCH 19/42] fix another quickcheck property broken by NUL in Arbitrary String --- Git/Filename.hs | 24 ++++++++++++++++-------- 1 file changed, 16 insertions(+), 8 deletions(-) diff --git a/Git/Filename.hs b/Git/Filename.hs index 1fe0d14158..eda4a4d907 100644 --- a/Git/Filename.hs +++ b/Git/Filename.hs @@ -35,13 +35,21 @@ decode b = case S.uncons b of encode :: RawFilePath -> S.ByteString encode s = encodeBS $ "\"" ++ encode_c (decodeBS s) ++ "\"" -{- For quickcheck. - - - - See comment on Utility.Format.prop_encode_c_decode_c - -_roundtrip for - - why this only tests chars < 256 - -} prop_encode_decode_roundtrip :: FilePath -> Bool -prop_encode_decode_roundtrip s = s' == fromRawFilePath (decode (encode (toRawFilePath s'))) +prop_encode_decode_roundtrip s = s' == + fromRawFilePath (decode (encode (toRawFilePath s'))) where - s' = filter (\c -> ord c < 256) s + s' = nonul (nohigh s) + -- Encoding and then decoding roundtrips only when + -- the string does not contain high unicode, because eg, + -- both "\12345" and "\227\128\185" are encoded to + -- "\343\200\271". + -- + -- This property papers over the problem, by only + -- testing chars < 256. + nohigh = filter (\c -> ord c < 256) + -- A String can contain a NUL, but toRawFilePath + -- truncates on the NUL, which is generally fine + -- because unix filenames cannot contain NUL. + -- So the encoding only roundtrips when there is no nul. + nonul = filter (/= '\NUL') From f39f018ee0b2feaab0007b776cb0ff6436aff0e8 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 6 Dec 2019 13:58:28 -0400 Subject: [PATCH 20/42] fix git ls-tree parser File mode is octal not decimal. This broke in the conversion to attoparsec. (I've submitted the content of Utility.Attoparsec to the attoparsec developers.) Test suite passes 100% now. --- COPYRIGHT | 35 ++++++++++++++++++++++++++++++++++- Git/LsTree.hs | 3 ++- Git/Types.hs | 2 +- Utility/Attoparsec.hs | 21 +++++++++++++++++++++ git-annex.cabal | 1 + 5 files changed, 59 insertions(+), 3 deletions(-) create mode 100644 Utility/Attoparsec.hs diff --git a/COPYRIGHT b/COPYRIGHT index a2324d7c58..858d7f0b74 100644 --- a/COPYRIGHT +++ b/COPYRIGHT @@ -29,6 +29,11 @@ Copyright: 2018 Joey Hess 2013 Michael Snoyman License: Expat +Files: Utility/Attoparsec.hs +Copyright: 2019 Joey Hess + 2007-2015 Bryan O'Sullivan +License: BSD-3-clause + Files: Utility/GitLFS.hs Copyright: © 2019 Joey Hess License: AGPL-3+ @@ -112,7 +117,35 @@ License: BSD-2-clause LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - + +License: BSD-3-clause + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + . + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + . + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + . + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + . + THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS + OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR + ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + License: Expat Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the diff --git a/Git/LsTree.hs b/Git/LsTree.hs index aa3651a543..0196d21a1f 100644 --- a/Git/LsTree.hs +++ b/Git/LsTree.hs @@ -24,6 +24,7 @@ import Git.Command import Git.Sha import Git.FilePath import qualified Git.Filename +import Utility.Attoparsec import Numeric import Data.Either @@ -90,7 +91,7 @@ parseLsTree b = case A.parse parserLsTree b of parserLsTree :: A.Parser TreeItem parserLsTree = TreeItem -- mode - <$> A8.decimal + <$> octal <* A8.char ' ' -- type <*> A.takeTill (== 32) diff --git a/Git/Types.hs b/Git/Types.hs index 45adc1f377..f15e334732 100644 --- a/Git/Types.hs +++ b/Git/Types.hs @@ -112,7 +112,7 @@ fmtObjectType TreeObject = "tree" {- Types of items in a tree. -} data TreeItemType = TreeFile | TreeExecutable | TreeSymlink | TreeSubmodule - deriving (Eq) + deriving (Eq, Show) {- Git uses magic numbers to denote the type of a tree item. -} readTreeItemType :: S.ByteString -> Maybe TreeItemType diff --git a/Utility/Attoparsec.hs b/Utility/Attoparsec.hs new file mode 100644 index 0000000000..bd20e8e6d9 --- /dev/null +++ b/Utility/Attoparsec.hs @@ -0,0 +1,21 @@ +{- attoparsec utility functions + - + - Copyright 2019 Joey Hess + - Copyright 2007-2015 Bryan O'Sullivan + - + - License: BSD-3-clause + -} + +module Utility.Attoparsec where + +import qualified Data.Attoparsec.ByteString as A +import qualified Data.ByteString as B + +-- | Parse and decode an unsigned octal number. +-- +-- This parser does not accept a leading @\"0o\"@ string. +octal :: Integral a => A.Parser a +octal = B.foldl' step 0 `fmap` A.takeWhile1 isOctDigit + where + isOctDigit w = w >= 48 && w <= 55 + step a w = a * 8 + fromIntegral (w - 48) diff --git a/git-annex.cabal b/git-annex.cabal index 5d8ba73914..fa75218993 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -1020,6 +1020,7 @@ Executable git-annex Utility.Aeson Utility.Android Utility.Applicative + Utility.Attoparsec Utility.AuthToken Utility.Base64 Utility.Batch From 360942ba127c4a5f4cbf820b9706de4f4eb96c77 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 6 Dec 2019 14:17:48 -0400 Subject: [PATCH 21/42] RawFilePath will need to support Windows too Of course, readSymbolicLink always fails on Windows, but now it's ready for other things that don't fail there. --- Utility/RawFilePath.hs | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/Utility/RawFilePath.hs b/Utility/RawFilePath.hs index 485346a0e6..24f26e25ff 100644 --- a/Utility/RawFilePath.hs +++ b/Utility/RawFilePath.hs @@ -1,4 +1,11 @@ {- Portability shim around System.Posix.Files.ByteString + - + - On unix, this makes syscalls using RawFilesPaths as efficiently as + - possible. + - + - On Windows, filenames are in unicode, so RawFilePaths have to be + - decoded. So this library will work, but less efficiently than using + - FilePath would. - - Copyright 2019 Joey Hess - @@ -17,12 +24,9 @@ import System.Posix.Files.ByteString import System.Posix.ByteString.FilePath #else import qualified Data.ByteString as B -import System.IO.Error - -type RawFilePath = B.ByteString +import qualified System.PosixCompat as P +import Utility.FileSystemEncoding readSymbolicLink :: RawFilePath -> IO RawFilePath -readSymbolicLink _ = ioError $ mkIOError illegalOperationErrorType x Nothing Nothing - where - x = "Utility.RawFilePath.readSymbolicLink: not supported" +readSymbolicLink f = toRawFilePath <$> P.readSymbolicLink (fromRawFilePath f) #endif From 0e9d699ef3741b279bdfbad36064bfe3f22f7c9e Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 6 Dec 2019 14:19:23 -0400 Subject: [PATCH 22/42] use R.readSymbolicLink This will be faster once gitAnnexLink is converted to a RawFilePath. --- Command/Fix.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/Command/Fix.hs b/Command/Fix.hs index 537a66f6d3..dec48b665e 100644 --- a/Command/Fix.hs +++ b/Command/Fix.hs @@ -17,6 +17,7 @@ import Annex.Content import Annex.Perms import qualified Annex.Queue import qualified Database.Keys +import qualified Utility.RawFilePath as R #if ! defined(mingw32_HOST_OS) import Utility.Touch @@ -39,11 +40,11 @@ data FixWhat = FixSymlinks | FixAll start :: FixWhat -> RawFilePath -> Key -> CommandStart start fixwhat file key = do - currlink <- liftIO $ catchMaybeIO $ readSymbolicLink $ fromRawFilePath file + currlink <- liftIO $ catchMaybeIO $ R.readSymbolicLink file wantlink <- calcRepo $ gitAnnexLink (fromRawFilePath file) key case currlink of Just l - | l /= wantlink -> fixby $ + | l /= toRawFilePath wantlink -> fixby $ fixSymlink (fromRawFilePath file) wantlink | otherwise -> stop Nothing -> case fixwhat of From 5f391179f1d8e18f736613a739dec7295d8baa40 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 6 Dec 2019 14:44:42 -0400 Subject: [PATCH 23/42] use RawFilePath getFileStatus for speed Only done on those calls to getFileStatus that had a RawFilePath, not a FilePath. The others would probably be just as fast if converted to use it with toRawFilePath, but I'm not 100% sure. Note that genInodeCache' uses fromRawFilePath, but that value only gets used on Windows, so on unix the thunk will never be evaluated. --- Annex/Link.hs | 2 +- Command/Fix.hs | 20 ++++++++++---------- Command/Fsck.hs | 3 ++- Command/Lock.hs | 4 ++-- Command/ReKey.hs | 7 ++++--- Command/Unlock.hs | 4 ++-- Utility/FileSize.hs | 5 ++++- Utility/InodeCache.hs | 6 ++++++ Utility/RawFilePath.hs | 6 +++++- 9 files changed, 36 insertions(+), 21 deletions(-) diff --git a/Annex/Link.hs b/Annex/Link.hs index 609e9eb1d3..b012b7d933 100644 --- a/Annex/Link.hs +++ b/Annex/Link.hs @@ -182,7 +182,7 @@ restagePointerFile (Restage True) f orig = withTSDelta $ \tsd -> do absf <- liftIO $ absPath $ fromRawFilePath f Annex.Queue.addInternalAction runner [(absf, isunmodified tsd)] where - isunmodified tsd = genInodeCache (fromRawFilePath f) tsd >>= return . \case + isunmodified tsd = genInodeCache' f tsd >>= return . \case Nothing -> False Just new -> compareStrong orig new diff --git a/Command/Fix.hs b/Command/Fix.hs index dec48b665e..52e076f30b 100644 --- a/Command/Fix.hs +++ b/Command/Fix.hs @@ -56,30 +56,30 @@ start fixwhat file key = do obj <- calcRepo $ gitAnnexLocation key stopUnless (isUnmodified key (fromRawFilePath file) <&&> isUnmodified key obj) $ do thin <- annexThin <$> Annex.getGitConfig - fs <- liftIO $ catchMaybeIO $ getFileStatus (fromRawFilePath file) + fs <- liftIO $ catchMaybeIO $ R.getFileStatus file os <- liftIO $ catchMaybeIO $ getFileStatus obj case (linkCount <$> fs, linkCount <$> os, thin) of (Just 1, Just 1, True) -> - fixby $ makeHardLink (fromRawFilePath file) key + fixby $ makeHardLink file key (Just n, Just n', False) | n > 1 && n == n' -> - fixby $ breakHardLink (fromRawFilePath file) key obj + fixby $ breakHardLink file key obj _ -> stop -breakHardLink :: FilePath -> Key -> FilePath -> CommandPerform +breakHardLink :: RawFilePath -> Key -> FilePath -> CommandPerform breakHardLink file key obj = do - replaceFile file $ \tmp -> do - mode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus file + replaceFile (fromRawFilePath file) $ \tmp -> do + mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file unlessM (checkedCopyFile key obj tmp mode) $ error "unable to break hard link" thawContent tmp modifyContent obj $ freezeContent obj - Database.Keys.storeInodeCaches key [file] + Database.Keys.storeInodeCaches key [fromRawFilePath file] next $ return True -makeHardLink :: FilePath -> Key -> CommandPerform +makeHardLink :: RawFilePath -> Key -> CommandPerform makeHardLink file key = do - replaceFile file $ \tmp -> do - mode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus file + replaceFile (fromRawFilePath file) $ \tmp -> do + mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file linkFromAnnex key tmp mode >>= \case LinkAnnexFailed -> error "unable to make hard link" _ -> noop diff --git a/Command/Fsck.hs b/Command/Fsck.hs index bb2dde569f..256bdfa894 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -35,6 +35,7 @@ import qualified Database.Fsck as FsckDb import Types.CleanupActions import Types.Key import Types.ActionItem +import qualified Utility.RawFilePath as R import Data.Time.Clock.POSIX import System.Posix.Types (EpochTime) @@ -327,7 +328,7 @@ verifyWorkTree key file = do Just k | k == key -> whenM (inAnnex key) $ do showNote "fixing worktree content" replaceFile (fromRawFilePath file) $ \tmp -> do - mode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus (fromRawFilePath file) + mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file ifM (annexThin <$> Annex.getGitConfig) ( void $ linkFromAnnex key tmp mode , do diff --git a/Command/Lock.hs b/Command/Lock.hs index cb104225f6..24dd6810ed 100644 --- a/Command/Lock.hs +++ b/Command/Lock.hs @@ -56,7 +56,7 @@ performNew :: RawFilePath -> Key -> CommandPerform performNew file key = do lockdown =<< calcRepo (gitAnnexLocation key) addLink (fromRawFilePath file) key - =<< withTSDelta (liftIO . genInodeCache (fromRawFilePath file)) + =<< withTSDelta (liftIO . genInodeCache' file) next $ cleanupNew file key where lockdown obj = do @@ -70,7 +70,7 @@ performNew file key = do -- It's ok if the file is hard linked to obj, but if some other -- associated file is, we need to break that link to lock down obj. breakhardlink obj = whenM (catchBoolIO $ (> 1) . linkCount <$> liftIO (getFileStatus obj)) $ do - mfc <- withTSDelta (liftIO . genInodeCache (fromRawFilePath file)) + mfc <- withTSDelta (liftIO . genInodeCache' file) unlessM (sameInodeCache obj (maybeToList mfc)) $ do modifyContent obj $ replaceFile obj $ \tmp -> do unlessM (checkedCopyFile key obj tmp Nothing) $ diff --git a/Command/ReKey.hs b/Command/ReKey.hs index b9eac59232..6e0678c2cc 100644 --- a/Command/ReKey.hs +++ b/Command/ReKey.hs @@ -19,6 +19,7 @@ import Git.FilePath import qualified Database.Keys import Annex.InodeSentinal import Utility.InodeCache +import qualified Utility.RawFilePath as R cmd :: Command cmd = command "rekey" SectionPlumbing @@ -89,14 +90,14 @@ linkKey file oldkey newkey = ifM (isJust <$> isAnnexLink file) - it's hard linked to the old key, that link must be broken. -} oldobj <- calcRepo (gitAnnexLocation oldkey) v <- tryNonAsync $ do - st <- liftIO $ getFileStatus (fromRawFilePath file) + st <- liftIO $ R.getFileStatus file when (linkCount st > 1) $ do freezeContent oldobj replaceFile (fromRawFilePath file) $ \tmp -> do unlessM (checkedCopyFile oldkey oldobj tmp Nothing) $ error "can't lock old key" thawContent tmp - ic <- withTSDelta (liftIO . genInodeCache (fromRawFilePath file)) + ic <- withTSDelta (liftIO . genInodeCache' file) case v of Left e -> do warning (show e) @@ -117,7 +118,7 @@ cleanup file oldkey newkey = do liftIO $ removeFile (fromRawFilePath file) addLink (fromRawFilePath file) newkey Nothing , do - mode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus (fromRawFilePath file) + mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file liftIO $ whenM (isJust <$> isPointerFile file) $ writePointerFile file newkey mode stagePointerFile file mode =<< hashPointerFile newkey diff --git a/Command/Unlock.hs b/Command/Unlock.hs index 31f8a26cf5..443ac46e3c 100644 --- a/Command/Unlock.hs +++ b/Command/Unlock.hs @@ -14,6 +14,7 @@ import Annex.Link import Annex.ReplaceFile import Git.FilePath import qualified Database.Keys +import qualified Utility.RawFilePath as R cmd :: Command cmd = mkcmd "unlock" "unlock files for modification" @@ -40,8 +41,7 @@ start file key = ifM (isJust <$> isAnnexLink file) perform :: RawFilePath -> Key -> CommandPerform perform dest key = do - destmode <- liftIO $ catchMaybeIO $ fileMode - <$> getFileStatus (fromRawFilePath dest) + destmode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus dest replaceFile (fromRawFilePath dest) $ \tmp -> ifM (inAnnex key) ( do diff --git a/Utility/FileSize.hs b/Utility/FileSize.hs index dd8fc70d14..8544ad4179 100644 --- a/Utility/FileSize.hs +++ b/Utility/FileSize.hs @@ -33,7 +33,10 @@ getFileSize f = fmap (fromIntegral . fileSize) (getFileStatus f) getFileSize f = bracket (openFile f ReadMode) hClose hFileSize #endif -{- Gets the size of the file, when its FileStatus is already known. -} +{- Gets the size of the file, when its FileStatus is already known. + - + - On windows, uses getFileSize. Otherwise, the FileStatus contains the + - size, so this does not do any work. -} getFileSize' :: FilePath -> FileStatus -> IO FileSize #ifndef mingw32_HOST_OS getFileSize' _ s = return $ fromIntegral $ fileSize s diff --git a/Utility/InodeCache.hs b/Utility/InodeCache.hs index 97245b3493..a918e7bd08 100644 --- a/Utility/InodeCache.hs +++ b/Utility/InodeCache.hs @@ -22,6 +22,7 @@ module Utility.InodeCache ( readInodeCache, showInodeCache, genInodeCache, + genInodeCache', toInodeCache, likeInodeCacheWeak, @@ -43,6 +44,7 @@ module Utility.InodeCache ( import Common import Utility.TimeStamp import Utility.QuickCheck +import qualified Utility.RawFilePath as R import System.PosixCompat.Types import Data.Time.Clock.POSIX @@ -184,6 +186,10 @@ genInodeCache :: FilePath -> TSDelta -> IO (Maybe InodeCache) genInodeCache f delta = catchDefaultIO Nothing $ toInodeCache delta f =<< getFileStatus f +genInodeCache' :: RawFilePath -> TSDelta -> IO (Maybe InodeCache) +genInodeCache' f delta = catchDefaultIO Nothing $ + toInodeCache delta (fromRawFilePath f) =<< R.getFileStatus f + toInodeCache :: TSDelta -> FilePath -> FileStatus -> IO (Maybe InodeCache) toInodeCache (TSDelta getdelta) f s | isRegularFile s = do diff --git a/Utility/RawFilePath.hs b/Utility/RawFilePath.hs index 24f26e25ff..ff7057783f 100644 --- a/Utility/RawFilePath.hs +++ b/Utility/RawFilePath.hs @@ -17,11 +17,12 @@ module Utility.RawFilePath ( RawFilePath, readSymbolicLink, + getFileStatus, ) where #ifndef mingw32_HOST_OS +import Utility.FileSystemEncoding (RawFilePath) import System.Posix.Files.ByteString -import System.Posix.ByteString.FilePath #else import qualified Data.ByteString as B import qualified System.PosixCompat as P @@ -29,4 +30,7 @@ import Utility.FileSystemEncoding readSymbolicLink :: RawFilePath -> IO RawFilePath readSymbolicLink f = toRawFilePath <$> P.readSymbolicLink (fromRawFilePath f) + +getFileStatus :: RawFilePath -> IO FileStatus +getFileStatus = P.getFileStatus . fromRawFilePath #endif From 8051deb35241266f2342ae9577bbbb6724b3ae72 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 6 Dec 2019 15:13:13 -0400 Subject: [PATCH 24/42] update re state of bs branch --- ...timize_by_converting_String_to_ByteString.mdwn | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/doc/todo/optimize_by_converting_String_to_ByteString.mdwn b/doc/todo/optimize_by_converting_String_to_ByteString.mdwn index 1c51fd0aa9..7ac7efe382 100644 --- a/doc/todo/optimize_by_converting_String_to_ByteString.mdwn +++ b/doc/todo/optimize_by_converting_String_to_ByteString.mdwn @@ -3,12 +3,13 @@ Converting to ByteString, and RawFilePath, should speed it up significantly, according to [[/profiling]]. I've made a test branch, `bs`, to see what kind of performance improvement -to expect. Most commands don't built yet in that branch, but `git annex -find` does. Speedups range from 28-66%. The files fly by much more -snappily. +to expect. -As well as adding back all the code that was disabled to get it to build, -the `bs` branch has quite a lot of things still needing work, including: +Benchmarking `git-annex find`, speedups range from 28-66%. The files fly by +much more snappily. Other commands likely also speed up, but do more work +than find so the improvement is not as large. + +The `bs` branch is in a mergeable state now, but still needs work: * Eliminate all the fromRawFilePath, toRawFilePath, encodeBS, decodeBS conversions. Or at least most of them. There are likely @@ -19,7 +20,9 @@ the `bs` branch has quite a lot of things still needing work, including: * 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. + `git-annex whereis`. Converting it to RawFilePath needs a version + of `` for RawFilePaths. It also needs a ByteString.readFile + for RawFilePath. * System.FilePath is not available for RawFilePath, and many of the conversions are to get a FilePath in order to use that library. From a0168cd9a22f8722b38d003b7b0d6e97686db7ff Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 6 Dec 2019 15:37:12 -0400 Subject: [PATCH 25/42] use RawFilePath getSymbolicLinkStatus for speed --- CmdLine/Seek.hs | 3 ++- Command/Add.hs | 5 +++-- Utility/RawFilePath.hs | 4 ++++ 3 files changed, 9 insertions(+), 3 deletions(-) diff --git a/CmdLine/Seek.hs b/CmdLine/Seek.hs index 68ee9efc02..97cc04a0cb 100644 --- a/CmdLine/Seek.hs +++ b/CmdLine/Seek.hs @@ -33,6 +33,7 @@ import Annex.CurrentBranch import Annex.Content import Annex.InodeSentinal import qualified Database.Keys +import qualified Utility.RawFilePath as R withFilesInGit :: (RawFilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek withFilesInGit a l = seekActions $ prepFiltered a $ @@ -276,4 +277,4 @@ workTreeItems' (AllowHidden allowhidden) ps = do | otherwise = return False notSymlink :: RawFilePath -> IO Bool -notSymlink f = liftIO $ not . isSymbolicLink <$> getSymbolicLinkStatus (fromRawFilePath f) +notSymlink f = liftIO $ not . isSymbolicLink <$> R.getSymbolicLinkStatus f diff --git a/Command/Add.hs b/Command/Add.hs index 0ebe42d735..919d217505 100644 --- a/Command/Add.hs +++ b/Command/Add.hs @@ -19,6 +19,7 @@ import Annex.Link import Annex.Tmp import Messages.Progress import Git.FilePath +import qualified Utility.RawFilePath as R cmd :: Command cmd = notBareRepo $ @@ -92,7 +93,7 @@ start file = do maybe go fixuppointer mk where go = ifAnnexed file addpresent add - add = liftIO (catchMaybeIO $ getSymbolicLinkStatus (fromRawFilePath file)) >>= \case + add = liftIO (catchMaybeIO $ R.getSymbolicLinkStatus file) >>= \case Nothing -> stop Just s | not (isRegularFile s) && not (isSymbolicLink s) -> stop @@ -102,7 +103,7 @@ start file = do then next $ addFile file else perform file addpresent key = - liftIO (catchMaybeIO $ getSymbolicLinkStatus $ fromRawFilePath file) >>= \case + liftIO (catchMaybeIO $ R.getSymbolicLinkStatus file) >>= \case Just s | isSymbolicLink s -> fixuplink key _ -> add fixuplink key = starting "add" (ActionItemWorkTreeFile file) $ do diff --git a/Utility/RawFilePath.hs b/Utility/RawFilePath.hs index ff7057783f..a62ba65e51 100644 --- a/Utility/RawFilePath.hs +++ b/Utility/RawFilePath.hs @@ -18,6 +18,7 @@ module Utility.RawFilePath ( RawFilePath, readSymbolicLink, getFileStatus, + getSymbolicLinkStatus, ) where #ifndef mingw32_HOST_OS @@ -33,4 +34,7 @@ readSymbolicLink f = toRawFilePath <$> P.readSymbolicLink (fromRawFilePath f) getFileStatus :: RawFilePath -> IO FileStatus getFileStatus = P.getFileStatus . fromRawFilePath + +getSymbolicLinkStatus :: RawFilePath -> IO FileStatus +getSymbolicLinkStatus = P.getSymbolicLinkStatus . fromRawFilePath #endif From a7004375ec381b6b2f8ce114a5e24c764ef4fdfd Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 6 Dec 2019 15:44:58 -0400 Subject: [PATCH 26/42] avoid deprecation warning --- Command/Config.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Command/Config.hs b/Command/Config.hs index 6764ca5e92..fb64dfdf90 100644 --- a/Command/Config.hs +++ b/Command/Config.hs @@ -12,7 +12,7 @@ import Logs.Config import Config import Git.Types (ConfigKey(..), fromConfigValue) -import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 cmd :: Command cmd = noMessages $ command "config" SectionSetup @@ -65,5 +65,5 @@ seek (GetConfig ck) = commandAction $ startingCustomOutput (ActionItemOther Nothing) $ do getGlobalConfig ck >>= \case Nothing -> return () - Just (ConfigValue v) -> liftIO $ S.putStrLn v + Just (ConfigValue v) -> liftIO $ S8.putStrLn v next $ return True From bdec7fed9cae4fe5c3cbdf0ee2ee6ae8530bbc19 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 9 Dec 2019 13:49:05 -0400 Subject: [PATCH 27/42] convert TopFilePath to use RawFilePath Adds a dependency on filepath-bytestring, an as yet unreleased fork of filepath that operates on RawFilePath. Git.Repo also changed to use RawFilePath for the path to the repo. This does eliminate some RawFilePath -> FilePath -> RawFilePath conversions. And filepath-bytestring's is probably faster. But I don't expect a major performance improvement from this. This is mostly groundwork for making Annex.Location use RawFilePath, which will allow for a conversion-free pipleline. --- Annex/AdjustedBranch.hs | 8 ++-- Annex/AutoMerge.hs | 8 ++-- Annex/Branch.hs | 4 +- Annex/ChangedRefs.hs | 2 +- Annex/Content.hs | 4 +- Annex/Drop.hs | 2 +- Annex/FileMatcher.hs | 4 +- Annex/Fixup.hs | 28 +++++++------ Annex/GitOverlay.hs | 5 ++- Annex/Import.hs | 17 ++++---- Annex/Ingest.hs | 16 ++++---- Annex/Init.hs | 6 ++- Annex/Link.hs | 2 +- Annex/Locations.hs | 19 ++++++--- Annex/View.hs | 17 ++++---- Annex/WorkTree.hs | 10 +++-- Assistant/Repair.hs | 4 +- Assistant/Threads/ConfigMonitor.hs | 2 +- Assistant/Threads/Merger.hs | 2 +- Assistant/Threads/MountWatcher.hs | 2 +- Assistant/Threads/PairListener.hs | 2 +- Assistant/Threads/SanityChecker.hs | 2 +- Assistant/Threads/Watcher.hs | 9 ++--- Assistant/Threads/WebApp.hs | 2 +- Assistant/Unused.hs | 2 +- Assistant/WebApp/Configurators/Delete.hs | 2 +- Assistant/WebApp/Configurators/Edit.hs | 2 +- Assistant/WebApp/Configurators/Pairing.hs | 2 +- Assistant/WebApp/Configurators/Preferences.hs | 4 +- Assistant/WebApp/DashBoard.hs | 3 +- Backend/WORM.hs | 3 +- CmdLine/Batch.hs | 3 +- CmdLine/Seek.hs | 9 ++--- Command/Add.hs | 2 +- Command/Export.hs | 27 +++++++------ Command/Find.hs | 2 +- Command/Fsck.hs | 2 +- Command/Import.hs | 4 +- Command/Info.hs | 6 +-- Command/Lock.hs | 4 +- Command/Log.hs | 2 +- Command/Map.hs | 5 ++- Command/Multicast.hs | 2 +- Command/PostReceive.hs | 2 + Command/ReKey.hs | 2 +- Command/ResolveMerge.hs | 2 +- Command/Smudge.hs | 7 ++-- Command/Status.hs | 2 +- Command/Sync.hs | 6 +-- Command/Unannex.hs | 15 +++---- Command/Undo.hs | 5 ++- Command/Uninit.hs | 2 +- Command/Unlock.hs | 2 +- Command/Unused.hs | 4 +- Command/View.hs | 6 +-- Database/ContentIdentifier.hs | 2 +- Database/Export.hs | 2 +- Database/Keys.hs | 4 +- Database/Keys/SQL.hs | 11 +++--- Git.hs | 39 ++++++++++--------- Git/Command.hs | 4 +- Git/Config.hs | 11 +++--- Git/Construct.hs | 12 +++--- Git/CurrentRepo.hs | 13 +++++-- Git/DiffTree.hs | 6 +-- Git/Env.hs | 6 ++- Git/FilePath.hs | 26 +++++++------ Git/Hook.hs | 2 +- Git/Index.hs | 2 +- Git/LsFiles.hs | 2 +- Git/LsTree.hs | 4 +- Git/Objects.hs | 2 +- Git/Ref.hs | 4 +- Git/Repair.hs | 16 ++++---- Git/Status.hs | 12 +++--- Git/Tree.hs | 10 ++--- Git/Types.hs | 4 +- Git/UnionMerge.hs | 2 +- Git/UpdateIndex.hs | 8 ++-- Limit.hs | 18 +++++---- Limit/Wanted.hs | 2 +- Logs/Export.hs | 2 + Logs/Smudge.hs | 8 ++-- Logs/Web.hs | 2 +- P2P/IO.hs | 2 +- Remote/Bup.hs | 2 +- Remote/External.hs | 3 +- Remote/Git.hs | 4 +- Remote/Helper/Git.hs | 4 +- Remote/Helper/Ssh.hs | 2 +- Types/FileMatcher.hs | 5 ++- Upgrade.hs | 2 +- Upgrade/V1.hs | 5 ++- Upgrade/V2.hs | 4 +- Upgrade/V5.hs | 4 +- Upgrade/V5/Direct.hs | 2 +- git-annex.cabal | 1 + 97 files changed, 323 insertions(+), 271 deletions(-) diff --git a/Annex/AdjustedBranch.hs b/Annex/AdjustedBranch.hs index a7b9d91a44..a6656ec08e 100644 --- a/Annex/AdjustedBranch.hs +++ b/Annex/AdjustedBranch.hs @@ -112,8 +112,8 @@ adjustToSymlink = adjustToSymlink' gitAnnexLink adjustToSymlink' :: (FilePath -> Key -> Git.Repo -> GitConfig -> IO FilePath) -> TreeItem -> Annex (Maybe TreeItem) adjustToSymlink' gitannexlink ti@(TreeItem f _m s) = catKey s >>= \case Just k -> do - absf <- inRepo $ \r -> absPath $ - fromTopFilePath f r + absf <- inRepo $ \r -> absPath $ + fromRawFilePath $ fromTopFilePath f r linktarget <- calcRepo $ gitannexlink absf k Just . TreeItem f (fromTreeItemType TreeSymlink) <$> hashSymlink linktarget @@ -376,7 +376,7 @@ mergeToAdjustedBranch tomerge (origbranch, adj) mergeconfig canresolvemerge comm -} changestomerge (Just updatedorig) = withOtherTmp $ \othertmpdir -> do tmpwt <- fromRepo gitAnnexMergeDir - git_dir <- fromRepo Git.localGitDir + git_dir <- fromRawFilePath <$> fromRepo Git.localGitDir withTmpDirIn othertmpdir "git" $ \tmpgit -> withWorkTreeRelated tmpgit $ withemptydir tmpwt $ withWorkTree tmpwt $ do liftIO $ writeFile (tmpgit "HEAD") (fromRef updatedorig) @@ -580,7 +580,7 @@ reverseAdjustedTree basis adj csha = do where m = M.fromList $ map (\i@(TreeItem f' _ _) -> (norm f', i)) $ map diffTreeToTreeItem changes - norm = normalise . getTopFilePath + norm = normalise . fromRawFilePath . getTopFilePath diffTreeToTreeItem :: Git.DiffTree.DiffTreeItem -> TreeItem diffTreeToTreeItem dti = TreeItem diff --git a/Annex/AutoMerge.hs b/Annex/AutoMerge.hs index f537081d71..d558c94c60 100644 --- a/Annex/AutoMerge.hs +++ b/Annex/AutoMerge.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Annex.AutoMerge ( autoMergeFrom , resolveMerge @@ -104,7 +106,7 @@ autoMergeFrom branch currbranch mergeconfig canresolvemerge commitmode = do -} resolveMerge :: Maybe Git.Ref -> Git.Ref -> Bool -> Annex Bool resolveMerge us them inoverlay = do - top <- toRawFilePath <$> if inoverlay + top <- if inoverlay then pure "." else fromRepo Git.repoPath (fs, cleanup) <- inRepo (LsFiles.unmerged [top]) @@ -196,7 +198,7 @@ resolveMerge' unstagedmap (Just us) them inoverlay u = do stagefile :: FilePath -> Annex FilePath stagefile f - | inoverlay = ( f) <$> fromRepo Git.repoPath + | inoverlay = ( f) . fromRawFilePath <$> fromRepo Git.repoPath | otherwise = pure f makesymlink key dest = do @@ -219,7 +221,7 @@ resolveMerge' unstagedmap (Just us) them inoverlay u = do stagePointerFile dest' destmode =<< hashPointerFile key unless inoverlay $ Database.Keys.addAssociatedFile key - =<< inRepo (toTopFilePath dest) + =<< inRepo (toTopFilePath (toRawFilePath dest)) withworktree f a = a f diff --git a/Annex/Branch.hs b/Annex/Branch.hs index c39807f61e..10fa59abc4 100644 --- a/Annex/Branch.hs +++ b/Annex/Branch.hs @@ -482,7 +482,7 @@ stageJournal jl commitindex = withIndex $ withOtherTmp $ \tmpdir -> do sha <- Git.HashObject.hashFile h path hPutStrLn jlogh file streamer $ Git.UpdateIndex.updateIndexLine - sha TreeFile (asTopFilePath $ fileJournal file) + sha TreeFile (asTopFilePath $ toRawFilePath $ fileJournal file) genstream dir h jh jlogh streamer -- Clean up the staged files, as listed in the temp log file. -- The temp file is used to avoid needing to buffer all the @@ -600,7 +600,7 @@ performTransitionsLocked jl ts neednewlocalbranch transitionedrefs = do else do sha <- hashBlob content' Annex.Queue.addUpdateIndex $ Git.UpdateIndex.pureStreamer $ - Git.UpdateIndex.updateIndexLine sha TreeFile (asTopFilePath (fromRawFilePath file)) + Git.UpdateIndex.updateIndexLine sha TreeFile (asTopFilePath file) apply rest file content' checkBranchDifferences :: Git.Ref -> Annex () diff --git a/Annex/ChangedRefs.hs b/Annex/ChangedRefs.hs index 82828bb847..6b6be4d202 100644 --- a/Annex/ChangedRefs.hs +++ b/Annex/ChangedRefs.hs @@ -76,7 +76,7 @@ watchChangedRefs = do chan <- liftIO $ newTBMChanIO 100 g <- gitRepo - let refdir = Git.localGitDir g "refs" + let refdir = fromRawFilePath (Git.localGitDir g) "refs" liftIO $ createDirectoryIfMissing True refdir let notifyhook = Just $ notifyHook chan diff --git a/Annex/Content.hs b/Annex/Content.hs index b3752c6ba9..c109e3f1f8 100644 --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -483,7 +483,7 @@ moveAnnex key src = ifM (checkSecureHashes key) fs <- map (`fromTopFilePath` g) <$> Database.Keys.getAssociatedFiles key unless (null fs) $ do - ics <- mapM (populatePointerFile (Restage True) key (toRawFilePath dest) . toRawFilePath) fs + ics <- mapM (populatePointerFile (Restage True) key (toRawFilePath dest)) fs Database.Keys.storeInodeCaches' key [dest] (catMaybes ics) ) alreadyhave = liftIO $ removeFile src @@ -643,7 +643,7 @@ removeAnnex (ContentRemovalLock key) = withObjectLoc key $ \file -> secureErase file liftIO $ nukeFile file g <- Annex.gitRepo - mapM_ (\f -> void $ tryIO $ resetpointer $ fromTopFilePath f g) + mapM_ (\f -> void $ tryIO $ resetpointer $ fromRawFilePath $ fromTopFilePath f g) =<< Database.Keys.getAssociatedFiles key Database.Keys.removeInodeCaches key where diff --git a/Annex/Drop.hs b/Annex/Drop.hs index f2489e5482..52c6f02bb7 100644 --- a/Annex/Drop.hs +++ b/Annex/Drop.hs @@ -49,7 +49,7 @@ 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 toRawFilePath . map (`fromTopFilePath` g) + l <- map (`fromTopFilePath` g) <$> Database.Keys.getAssociatedFiles key let fs = case afile of AssociatedFile (Just f) -> nub (f : l) diff --git a/Annex/FileMatcher.hs b/Annex/FileMatcher.hs index 05e6e7f761..cb43d55fd5 100644 --- a/Annex/FileMatcher.hs +++ b/Annex/FileMatcher.hs @@ -62,7 +62,7 @@ checkMatcher :: FileMatcher Annex -> Maybe Key -> AssociatedFile -> AssumeNotPre checkMatcher matcher mkey afile notpresent notconfigured d | isEmpty matcher = notconfigured | otherwise = case (mkey, afile) of - (_, AssociatedFile (Just file)) -> go =<< fileMatchInfo (fromRawFilePath file) + (_, AssociatedFile (Just file)) -> go =<< fileMatchInfo file (Just key, _) -> go (MatchingKey key afile) _ -> d where @@ -72,7 +72,7 @@ checkMatcher' :: FileMatcher Annex -> MatchInfo -> AssumeNotPresent -> Annex Boo checkMatcher' matcher mi notpresent = matchMrun matcher $ \a -> a notpresent mi -fileMatchInfo :: FilePath -> Annex MatchInfo +fileMatchInfo :: RawFilePath -> Annex MatchInfo fileMatchInfo file = do matchfile <- getTopFilePath <$> inRepo (toTopFilePath file) return $ MatchingFile FileInfo diff --git a/Annex/Fixup.hs b/Annex/Fixup.hs index 547458c08f..de940f7b9e 100644 --- a/Annex/Fixup.hs +++ b/Annex/Fixup.hs @@ -19,6 +19,7 @@ import Utility.SafeCommand import Utility.Directory import Utility.Exception import Utility.Monad +import Utility.FileSystemEncoding import Utility.PartialPrelude import System.IO @@ -29,6 +30,8 @@ import Data.Maybe import Control.Monad import Control.Monad.IfElse import qualified Data.Map as M +import qualified System.FilePath.ByteString as P +import qualified Data.ByteString as S import Control.Applicative import Prelude @@ -52,7 +55,7 @@ disableWildcardExpansion r = r fixupDirect :: Repo -> Repo fixupDirect r@(Repo { location = l@(Local { gitdir = d, worktree = Nothing }) }) = do r - { location = l { worktree = Just (parentDir d) } + { location = l { worktree = Just (toRawFilePath (parentDir (fromRawFilePath d))) } , gitGlobalOpts = gitGlobalOpts r ++ [ Param "-c" , Param $ fromConfigKey coreBare ++ "=" ++ boolConfig False @@ -110,12 +113,13 @@ fixupUnusualRepos r@(Repo { location = l@(Local { worktree = Just w, gitdir = d , return r ) where - dotgit = w ".git" + dotgit = w P. ".git" + dotgit' = fromRawFilePath dotgit - replacedotgit = whenM (doesFileExist dotgit) $ do - linktarget <- relPathDirToFile w d - nukeFile dotgit - createSymbolicLink linktarget dotgit + replacedotgit = whenM (doesFileExist dotgit') $ do + linktarget <- relPathDirToFile (fromRawFilePath w) (fromRawFilePath d) + nukeFile dotgit' + createSymbolicLink linktarget dotgit' unsetcoreworktree = maybe (error "unset core.worktree failed") (\_ -> return ()) @@ -125,13 +129,13 @@ fixupUnusualRepos r@(Repo { location = l@(Local { worktree = Just w, gitdir = d -- git-worktree sets up a "commondir" file that contains -- the path to the main git directory. -- Using --separate-git-dir does not. - catchDefaultIO Nothing (headMaybe . lines <$> readFile (d "commondir")) >>= \case + catchDefaultIO Nothing (headMaybe . lines <$> readFile (fromRawFilePath (d P. "commondir"))) >>= \case Just gd -> do -- Make the worktree's git directory -- contain an annex symlink to the main -- repository's annex directory. let linktarget = gd "annex" - createSymbolicLink linktarget (dotgit "annex") + createSymbolicLink linktarget (dotgit' "annex") Nothing -> return () -- Repo adjusted, so that symlinks to objects that get checked @@ -141,12 +145,12 @@ fixupUnusualRepos r@(Repo { location = l@(Local { worktree = Just w, gitdir = d | coreSymlinks c = r { location = l { gitdir = dotgit } } | otherwise = r - notnoannex = isNothing <$> noAnnexFileContent (Git.repoWorkTree r) + notnoannex = isNothing <$> noAnnexFileContent (fmap fromRawFilePath (Git.repoWorkTree r)) fixupUnusualRepos r _ = return r needsSubmoduleFixup :: Repo -> Bool needsSubmoduleFixup (Repo { location = (Local { worktree = Just _, gitdir = d }) }) = - (".git" "modules") `isInfixOf` d + (".git" P. "modules") `S.isInfixOf` d needsSubmoduleFixup _ = False needsGitLinkFixup :: Repo -> IO Bool @@ -154,6 +158,6 @@ needsGitLinkFixup (Repo { location = (Local { worktree = Just wt, gitdir = d }) -- Optimization: Avoid statting .git in the common case; only -- when the gitdir is not in the usual place inside the worktree -- might .git be a file. - | wt ".git" == d = return False - | otherwise = doesFileExist (wt ".git") + | wt P. ".git" == d = return False + | otherwise = doesFileExist (fromRawFilePath (wt P. ".git")) needsGitLinkFixup _ = return False diff --git a/Annex/GitOverlay.hs b/Annex/GitOverlay.hs index 0b3e9c2b88..a839ce450f 100644 --- a/Annex/GitOverlay.hs +++ b/Annex/GitOverlay.hs @@ -54,7 +54,7 @@ withWorkTree d = withAltRepo (\g -> return $ g { location = modlocation (location g), gitGlobalOpts = gitGlobalOpts g ++ disableSmudgeConfig }) (\g g' -> g' { location = location g, gitGlobalOpts = gitGlobalOpts g }) where - modlocation l@(Local {}) = l { worktree = Just d } + modlocation l@(Local {}) = l { worktree = Just (toRawFilePath d) } modlocation _ = error "withWorkTree of non-local git repo" disableSmudgeConfig = map Param [ "-c", "filter.annex.smudge=" @@ -73,7 +73,8 @@ withWorkTreeRelated :: FilePath -> Annex a -> Annex a withWorkTreeRelated d = withAltRepo modrepo unmodrepo where modrepo g = liftIO $ do - g' <- addGitEnv g "GIT_COMMON_DIR" =<< absPath (localGitDir g) + g' <- addGitEnv g "GIT_COMMON_DIR" + =<< absPath (fromRawFilePath (localGitDir g)) g'' <- addGitEnv g' "GIT_DIR" d return (g'' { gitEnvOverridesGitDir = True }) unmodrepo g g' = g' diff --git a/Annex/Import.hs b/Annex/Import.hs index 8291cd51bf..7c0f88164b 100644 --- a/Annex/Import.hs +++ b/Annex/Import.hs @@ -57,6 +57,7 @@ import Control.Concurrent.STM import qualified Data.Map.Strict as M import qualified Data.Set as S import qualified System.FilePath.Posix as Posix +import qualified System.FilePath.ByteString as P {- Configures how to build an import tree. -} data ImportTreeConfig @@ -123,7 +124,7 @@ buildImportCommit remote importtreeconfig importcommitconfig importable = Nothing -> pure committedtree Just dir -> let subtreeref = Ref $ - fromRef committedtree ++ ":" ++ getTopFilePath dir + fromRef committedtree ++ ":" ++ fromRawFilePath (getTopFilePath dir) in fromMaybe emptyTree <$> inRepo (Git.Ref.tree subtreeref) updateexportdb importedtree @@ -264,12 +265,12 @@ buildImportTrees basetree msubdir importable = History graftTree' importtree subdir basetree repo hdl mktreeitem (loc, k) = do - let lf = fromRawFilePath (fromImportLocation loc) + let lf = fromImportLocation loc let treepath = asTopFilePath lf let topf = asTopFilePath $ - maybe lf (\sd -> getTopFilePath sd lf) msubdir + maybe lf (\sd -> getTopFilePath sd P. lf) msubdir relf <- fromRepo $ fromTopFilePath topf - symlink <- calcRepo $ gitAnnexLink relf k + symlink <- calcRepo $ gitAnnexLink (fromRawFilePath relf) k linksha <- hashSymlink symlink return $ TreeItem treepath (fromTreeItemType TreeSymlink) linksha @@ -368,18 +369,18 @@ downloadImport remote importtreeconfig importablecontents = do mkkey loc tmpfile = do f <- fromRepo $ fromTopFilePath $ locworktreefilename loc - backend <- chooseBackend f + backend <- chooseBackend (fromRawFilePath f) let ks = KeySource - { keyFilename = f + { keyFilename = (fromRawFilePath f) , contentLocation = tmpfile , inodeCache = Nothing } fmap fst <$> genKey ks nullMeterUpdate backend locworktreefilename loc = asTopFilePath $ case importtreeconfig of - ImportTree -> fromRawFilePath (fromImportLocation loc) + ImportTree -> fromImportLocation loc ImportSubTree subdir _ -> - getTopFilePath subdir fromRawFilePath (fromImportLocation loc) + getTopFilePath subdir P. fromImportLocation loc getcidkey cidmap db cid = liftIO $ CIDDb.getContentIdentifierKeys db rs cid >>= \case diff --git a/Annex/Ingest.hs b/Annex/Ingest.hs index 5d5636b2e5..85a4d38122 100644 --- a/Annex/Ingest.hs +++ b/Annex/Ingest.hs @@ -202,7 +202,8 @@ finishIngestUnlocked key source = do finishIngestUnlocked' :: Key -> KeySource -> Restage -> Annex () finishIngestUnlocked' key source restage = do - Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath (keyFilename source)) + Database.Keys.addAssociatedFile key + =<< inRepo (toTopFilePath (toRawFilePath (keyFilename source))) populateAssociatedFiles key source restage {- Copy to any other locations using the same key. -} @@ -211,10 +212,10 @@ populateAssociatedFiles key source restage = do obj <- toRawFilePath <$> calcRepo (gitAnnexLocation key) g <- Annex.gitRepo ingestedf <- flip fromTopFilePath g - <$> inRepo (toTopFilePath (keyFilename source)) + <$> inRepo (toTopFilePath (toRawFilePath (keyFilename source))) afs <- map (`fromTopFilePath` g) <$> Database.Keys.getAssociatedFiles key forM_ (filter (/= ingestedf) afs) $ - populatePointerFile restage key obj . toRawFilePath + populatePointerFile restage key obj cleanCruft :: KeySource -> Annex () cleanCruft source = when (contentLocation source /= keyFilename source) $ @@ -226,15 +227,16 @@ cleanCruft source = when (contentLocation source /= keyFilename source) $ cleanOldKeys :: FilePath -> Key -> Annex () cleanOldKeys file newkey = do g <- Annex.gitRepo - ingestedf <- flip fromTopFilePath g <$> inRepo (toTopFilePath file) - topf <- inRepo (toTopFilePath file) + topf <- inRepo (toTopFilePath (toRawFilePath file)) + ingestedf <- fromRepo $ fromTopFilePath topf oldkeys <- filter (/= newkey) <$> Database.Keys.getAssociatedKey topf forM_ oldkeys $ \key -> unlessM (isUnmodified key =<< calcRepo (gitAnnexLocation key)) $ do caches <- Database.Keys.getInodeCaches key unlinkAnnex key - fs <- filter (/= ingestedf) + fs <- map fromRawFilePath + . filter (/= ingestedf) . map (`fromTopFilePath` g) <$> Database.Keys.getAssociatedFiles key filterM (`sameInodeCache` caches) fs >>= \case @@ -330,7 +332,7 @@ addAnnexedFile file key mtmp = ifM addUnlocked (\tmp -> liftIO $ catchMaybeIO $ fileMode <$> getFileStatus tmp) mtmp stagePointerFile (toRawFilePath file) mode =<< hashPointerFile key - Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath file) + Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath (toRawFilePath file)) case mtmp of Just tmp -> ifM (moveAnnex key tmp) ( linkunlocked mode >> return True diff --git a/Annex/Init.hs b/Annex/Init.hs index 3accd18ff3..ec6b8fc422 100644 --- a/Annex/Init.hs +++ b/Annex/Init.hs @@ -56,7 +56,7 @@ import Data.Either import qualified Data.Map as M checkCanInitialize :: Annex a -> Annex a -checkCanInitialize a = inRepo (noAnnexFileContent . Git.repoWorkTree) >>= \case +checkCanInitialize a = inRepo (noAnnexFileContent . fmap fromRawFilePath . Git.repoWorkTree) >>= \case Nothing -> a Just noannexmsg -> do warning "Initialization prevented by .noannex file (remove the file to override)" @@ -67,7 +67,9 @@ checkCanInitialize a = inRepo (noAnnexFileContent . Git.repoWorkTree) >>= \case genDescription :: Maybe String -> Annex UUIDDesc genDescription (Just d) = return $ UUIDDesc $ encodeBS d genDescription Nothing = do - reldir <- liftIO . relHome =<< liftIO . absPath =<< fromRepo Git.repoPath + reldir <- liftIO . relHome + =<< liftIO . absPath . fromRawFilePath + =<< fromRepo Git.repoPath hostname <- fromMaybe "" <$> liftIO getHostname let at = if null hostname then "" else "@" v <- liftIO myUserName diff --git a/Annex/Link.hs b/Annex/Link.hs index b012b7d933..fe9e1d52d7 100644 --- a/Annex/Link.hs +++ b/Annex/Link.hs @@ -200,7 +200,7 @@ restagePointerFile (Restage True) f orig = withTSDelta $ \tsd -> do unlockindex = liftIO . maybe noop Git.LockFile.closeLock showwarning = warning $ unableToRestage Nothing go Nothing = showwarning - go (Just _) = withTmpDirIn (Git.localGitDir r) "annexindex" $ \tmpdir -> do + go (Just _) = withTmpDirIn (fromRawFilePath $ Git.localGitDir r) "annexindex" $ \tmpdir -> do let tmpindex = tmpdir "index" let updatetmpindex = do r' <- Git.Env.addGitEnv r Git.Index.indexEnv diff --git a/Annex/Locations.hs b/Annex/Locations.hs index 1a9b5a6055..3c49099094 100644 --- a/Annex/Locations.hs +++ b/Annex/Locations.hs @@ -93,6 +93,7 @@ module Annex.Locations ( import Data.Char import Data.Default import qualified Data.ByteString.Char8 as S8 +import qualified System.FilePath.ByteString as P import Common import Key @@ -158,7 +159,12 @@ gitAnnexLocationDepth config = hashlevels + 1 - the actual location of the file's content. -} gitAnnexLocation :: Key -> Git.Repo -> GitConfig -> IO FilePath -gitAnnexLocation key r config = gitAnnexLocation' key r config (annexCrippledFileSystem config) (coreSymlinks config) doesFileExist (Git.localGitDir r) +gitAnnexLocation key r config = gitAnnexLocation' key r config + (annexCrippledFileSystem config) + (coreSymlinks config) + doesFileExist + (fromRawFilePath (Git.localGitDir r)) + gitAnnexLocation' :: Key -> Git.Repo -> GitConfig -> Bool -> Bool -> (FilePath -> IO Bool) -> FilePath -> IO FilePath gitAnnexLocation' key r config crippled symlinkssupported checker gitdir {- Bare repositories default to hashDirLower for new @@ -200,8 +206,9 @@ gitAnnexLink file key r config = do - supporting symlinks; generate link target that will - work portably. -} | not (coreSymlinks config) && needsSubmoduleFixup r = - absNormPathUnix currdir $ Git.repoPath r ".git" - | otherwise = Git.localGitDir r + absNormPathUnix currdir $ fromRawFilePath $ + Git.repoPath r P. ".git" + | otherwise = fromRawFilePath $ Git.localGitDir r absNormPathUnix d p = fromRawFilePath $ toInternalGitPath $ toRawFilePath $ absPathFrom (fromRawFilePath $ toInternalGitPath $ toRawFilePath d) @@ -214,7 +221,7 @@ gitAnnexLinkCanonical file key r config = gitAnnexLink file key r' config' where r' = case r of Git.Repo { Git.location = l@Git.Local { Git.worktree = Just wt } } -> - r { Git.location = l { Git.gitdir = wt ".git" } } + r { Git.location = l { Git.gitdir = wt P. ".git" } } _ -> r config' = config { annexCrippledFileSystem = False @@ -250,11 +257,11 @@ gitAnnexInodeSentinalCache r = gitAnnexInodeSentinal r ++ ".cache" {- The annex directory of a repository. -} gitAnnexDir :: Git.Repo -> FilePath -gitAnnexDir r = addTrailingPathSeparator $ Git.localGitDir r annexDir +gitAnnexDir r = addTrailingPathSeparator $ fromRawFilePath (Git.localGitDir r) annexDir {- The part of the annex directory where file contents are stored. -} gitAnnexObjectDir :: Git.Repo -> FilePath -gitAnnexObjectDir r = addTrailingPathSeparator $ Git.localGitDir r objectDir +gitAnnexObjectDir r = addTrailingPathSeparator $ fromRawFilePath (Git.localGitDir r) objectDir {- .git/annex/tmp/ is used for temp files for key's contents -} gitAnnexTmpObjectDir :: Git.Repo -> FilePath diff --git a/Annex/View.hs b/Annex/View.hs index d20bbb8caa..d1f41c42d3 100644 --- a/Annex/View.hs +++ b/Annex/View.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Annex.View where import Annex.Common @@ -80,7 +82,7 @@ parseViewParam s = case separate (== '=') s of ) where mkFilterValues v - | any (`elem` v) "*?" = FilterGlob v + | any (`elem` v) ['*', '?'] = FilterGlob v | otherwise = FilterValues $ S.singleton $ toMetaValue $ encodeBS v mkExcludeValues = ExcludeValues . S.singleton . toMetaValue . encodeBS @@ -343,11 +345,11 @@ narrowView = applyView' viewedFileReuse getViewedFileMetaData applyView' :: MkViewedFile -> (FilePath -> MetaData) -> View -> Annex Git.Branch applyView' mkviewedfile getfilemetadata view = do top <- fromRepo Git.repoPath - (l, clean) <- inRepo $ Git.LsFiles.stagedDetails [toRawFilePath top] + (l, clean) <- inRepo $ Git.LsFiles.stagedDetails [top] liftIO . nukeFile =<< fromRepo gitAnnexViewIndex uh <- withViewIndex $ inRepo Git.UpdateIndex.startUpdateIndex forM_ l $ \(f, sha, mode) -> do - topf <- inRepo (toTopFilePath $ fromRawFilePath f) + topf <- inRepo (toTopFilePath f) go uh topf sha (toTreeItemType =<< mode) =<< lookupFile f liftIO $ do void $ stopUpdateIndex uh @@ -358,13 +360,14 @@ applyView' mkviewedfile getfilemetadata view = do go uh topf _sha _mode (Just k) = do metadata <- getCurrentMetaData k - let f = getTopFilePath topf + let f = fromRawFilePath $ getTopFilePath topf let metadata' = getfilemetadata f `unionMetaData` metadata forM_ (genviewedfiles f metadata') $ \fv -> do - f' <- fromRepo $ fromTopFilePath $ asTopFilePath fv + f' <- fromRawFilePath <$> + fromRepo (fromTopFilePath $ asTopFilePath $ toRawFilePath fv) stagesymlink uh f' =<< calcRepo (gitAnnexLink f' k) go uh topf (Just sha) (Just treeitemtype) Nothing - | "." `isPrefixOf` getTopFilePath topf = + | "." `B.isPrefixOf` getTopFilePath topf = liftIO $ Git.UpdateIndex.streamUpdateIndex' uh $ pureStreamer $ updateIndexLine sha treeitemtype topf go _ _ _ _ _ = noop @@ -403,7 +406,7 @@ withViewChanges addmeta removemeta = do =<< catKey (DiffTree.dstsha item) | otherwise = noop handlechange item a = maybe noop - (void . commandAction . a (getTopFilePath $ DiffTree.file item)) + (void . commandAction . a (fromRawFilePath $ getTopFilePath $ DiffTree.file item)) {- Runs an action using the view index file. - Note that the file does not necessarily exist, or can contain diff --git a/Annex/WorkTree.hs b/Annex/WorkTree.hs index 269213428e..1b2c11061e 100644 --- a/Annex/WorkTree.hs +++ b/Annex/WorkTree.hs @@ -23,6 +23,7 @@ import Database.Types import qualified Database.Keys import qualified Database.Keys.SQL import Config +import qualified Utility.RawFilePath as R {- Looks up the key corresponding to an annexed file in the work tree, - by examining what the file links to. @@ -96,10 +97,11 @@ scanUnlockedFiles = whenM (inRepo Git.Ref.headExists <&&> not <$> isBareRepo) $ liftIO . Database.Keys.SQL.addAssociatedFileFast (toIKey k) tf whenM (inAnnex k) $ do f <- fromRepo $ fromTopFilePath tf - liftIO (isPointerFile (toRawFilePath f)) >>= \case + liftIO (isPointerFile f) >>= \case Just k' | k' == k -> do - destmode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus f - ic <- replaceFile f $ \tmp -> + destmode <- liftIO $ catchMaybeIO $ + fileMode <$> R.getFileStatus f + ic <- replaceFile (fromRawFilePath f) $ \tmp -> linkFromAnnex k tmp destmode >>= \case LinkAnnexOk -> withTSDelta (liftIO . genInodeCache tmp) @@ -107,5 +109,5 @@ scanUnlockedFiles = whenM (inRepo Git.Ref.headExists <&&> not <$> isBareRepo) $ LinkAnnexFailed -> liftIO $ do writePointerFile (toRawFilePath tmp) k destmode return Nothing - maybe noop (restagePointerFile (Restage True) (toRawFilePath f)) ic + maybe noop (restagePointerFile (Restage True) f) ic _ -> noop diff --git a/Assistant/Repair.hs b/Assistant/Repair.hs index 97c9f7f94a..f8e7bedcec 100644 --- a/Assistant/Repair.hs +++ b/Assistant/Repair.hs @@ -91,7 +91,7 @@ runRepair u mrmt destructiverepair = do remoterepair fsckresults = case Remote.repairRepo =<< mrmt of Nothing -> return False Just mkrepair -> do - thisrepopath <- liftIO . absPath + thisrepopath <- liftIO . absPath . fromRawFilePath =<< liftAnnex (fromRepo Git.repoPath) a <- liftAnnex $ mkrepair $ repair fsckresults (Just thisrepopath) @@ -130,7 +130,7 @@ repairStaleGitLocks r = do repairStaleLocks lockfiles return $ not $ null lockfiles where - findgitfiles = dirContentsRecursiveSkipping (== dropTrailingPathSeparator annexDir) True . Git.localGitDir + findgitfiles = dirContentsRecursiveSkipping (== dropTrailingPathSeparator annexDir) True . fromRawFilePath . Git.localGitDir islock f | "gc.pid" `isInfixOf` f = False | ".lock" `isSuffixOf` f = True diff --git a/Assistant/Threads/ConfigMonitor.hs b/Assistant/Threads/ConfigMonitor.hs index cabda5d259..b8ccb9e23d 100644 --- a/Assistant/Threads/ConfigMonitor.hs +++ b/Assistant/Threads/ConfigMonitor.hs @@ -91,4 +91,4 @@ getConfigs = S.fromList . map extract <$> liftAnnex (inRepo $ LsTree.lsTreeFiles Annex.Branch.fullname files) where files = map (fromRawFilePath . fst) configFilesActions - extract treeitem = (toRawFilePath $ getTopFilePath $ LsTree.file treeitem, LsTree.sha treeitem) + extract treeitem = (getTopFilePath $ LsTree.file treeitem, LsTree.sha treeitem) diff --git a/Assistant/Threads/Merger.hs b/Assistant/Threads/Merger.hs index f2284b6055..82802fbb29 100644 --- a/Assistant/Threads/Merger.hs +++ b/Assistant/Threads/Merger.hs @@ -26,7 +26,7 @@ import qualified Command.Sync mergeThread :: NamedThread mergeThread = namedThread "Merger" $ do g <- liftAnnex gitRepo - let dir = Git.localGitDir g "refs" + let dir = fromRawFilePath (Git.localGitDir g) "refs" liftIO $ createDirectoryIfMissing True dir let hook a = Just <$> asIO2 (runHandler a) changehook <- hook onChange diff --git a/Assistant/Threads/MountWatcher.hs b/Assistant/Threads/MountWatcher.hs index e35d624409..98aa34b305 100644 --- a/Assistant/Threads/MountWatcher.hs +++ b/Assistant/Threads/MountWatcher.hs @@ -159,7 +159,7 @@ handleMount urlrenderer dir = do -} remotesUnder :: FilePath -> Assistant [Remote] remotesUnder dir = do - repotop <- liftAnnex $ fromRepo Git.repoPath + repotop <- liftAnnex $ fromRawFilePath <$> fromRepo Git.repoPath rs <- liftAnnex remoteList pairs <- liftAnnex $ mapM (checkremote repotop) rs let (waschanged, rs') = unzip pairs diff --git a/Assistant/Threads/PairListener.hs b/Assistant/Threads/PairListener.hs index 28b55ef420..8a5ba7914c 100644 --- a/Assistant/Threads/PairListener.hs +++ b/Assistant/Threads/PairListener.hs @@ -119,7 +119,7 @@ pairReqReceived False urlrenderer msg = do pairAckReceived :: Bool -> Maybe PairingInProgress -> PairMsg -> [PairingInProgress] -> Assistant [PairingInProgress] pairAckReceived True (Just pip) msg cache = do stopSending pip - repodir <- repoPath <$> liftAnnex gitRepo + repodir <- fromRawFilePath . repoPath <$> liftAnnex gitRepo liftIO $ setupAuthorizedKeys msg repodir finishedLocalPairing msg (inProgressSshKeyPair pip) startSending pip PairDone $ multicastPairMsg diff --git a/Assistant/Threads/SanityChecker.hs b/Assistant/Threads/SanityChecker.hs index 28beacb2ea..57cf96cefa 100644 --- a/Assistant/Threads/SanityChecker.hs +++ b/Assistant/Threads/SanityChecker.hs @@ -269,5 +269,5 @@ checkOldUnused urlrenderer = go =<< annexExpireUnused <$> liftAnnex Annex.getGit checkRepoExists :: Assistant () checkRepoExists = do g <- liftAnnex gitRepo - liftIO $ unlessM (doesDirectoryExist $ Git.repoPath g) $ + liftIO $ unlessM (doesDirectoryExist $ fromRawFilePath $ Git.repoPath g) $ terminateSelf diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs index 5322998644..602fe893d9 100644 --- a/Assistant/Threads/Watcher.hs +++ b/Assistant/Threads/Watcher.hs @@ -136,8 +136,7 @@ startupScan scanner = do -- Notice any files that were deleted before -- watching was started. top <- liftAnnex $ fromRepo Git.repoPath - (fs, cleanup) <- liftAnnex $ inRepo $ LsFiles.deleted - [toRawFilePath top] + (fs, cleanup) <- liftAnnex $ inRepo $ LsFiles.deleted [top] forM_ fs $ \f -> do let f' = fromRawFilePath f liftAnnex $ onDel' f' @@ -215,7 +214,7 @@ onAddUnlocked symlinkssupported matcher f fs = do where addassociatedfile key file = Database.Keys.addAssociatedFile key - =<< inRepo (toTopFilePath file) + =<< inRepo (toTopFilePath (toRawFilePath file)) samefilestatus key file status = do cache <- Database.Keys.getInodeCaches key curr <- withTSDelta $ \delta -> liftIO $ toInodeCache delta file status @@ -225,7 +224,7 @@ onAddUnlocked symlinkssupported matcher f fs = do _ -> return False contentchanged oldkey file = do Database.Keys.removeAssociatedFile oldkey - =<< inRepo (toTopFilePath file) + =<< inRepo (toTopFilePath (toRawFilePath file)) unlessM (inAnnex oldkey) $ logStatus oldkey InfoMissing addlink file key = do @@ -347,7 +346,7 @@ onDel file _ = do onDel' :: FilePath -> Annex () onDel' file = do - topfile <- inRepo (toTopFilePath file) + topfile <- inRepo (toTopFilePath (toRawFilePath file)) withkey $ flip Database.Keys.removeAssociatedFile topfile Annex.Queue.addUpdateIndex =<< inRepo (Git.UpdateIndex.unstageFile file) diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs index b4e906857a..421f686c26 100644 --- a/Assistant/Threads/WebApp.hs +++ b/Assistant/Threads/WebApp.hs @@ -100,7 +100,7 @@ webAppThread assistantdata urlrenderer noannex cannotrun postfirstrun listenhost getreldir | noannex = return Nothing | otherwise = Just <$> - (relHome =<< absPath + (relHome =<< absPath . fromRawFilePath =<< getAnnex' (fromRepo repoPath)) go tlssettings addr webapp htmlshim urlfile = do let url = myUrl tlssettings webapp addr diff --git a/Assistant/Unused.hs b/Assistant/Unused.hs index da73f77abd..14450ef047 100644 --- a/Assistant/Unused.hs +++ b/Assistant/Unused.hs @@ -64,7 +64,7 @@ describeUnused' whenbig = liftAnnex $ go =<< readUnusedLog "" sumkeysize s k = s + fromMaybe 0 (fromKey keySize k) - forpath a = inRepo $ liftIO . a . Git.repoPath + forpath a = inRepo $ liftIO . a . fromRawFilePath . Git.repoPath {- With a duration, expires all unused files that are older. - With Nothing, expires *all* unused files. -} diff --git a/Assistant/WebApp/Configurators/Delete.hs b/Assistant/WebApp/Configurators/Delete.hs index 117d4b4272..82aa3bc35f 100644 --- a/Assistant/WebApp/Configurators/Delete.hs +++ b/Assistant/WebApp/Configurators/Delete.hs @@ -78,7 +78,7 @@ deleteCurrentRepository = dangerPage $ do sanityVerifierAForm $ SanityVerifier magicphrase case result of FormSuccess _ -> liftH $ do - dir <- liftAnnex $ fromRepo Git.repoPath + dir <- liftAnnex $ fromRawFilePath <$> fromRepo Git.repoPath liftIO $ removeAutoStartFile dir {- Disable syncing to this repository, and all diff --git a/Assistant/WebApp/Configurators/Edit.hs b/Assistant/WebApp/Configurators/Edit.hs index b711761a42..5f5e9ffed7 100644 --- a/Assistant/WebApp/Configurators/Edit.hs +++ b/Assistant/WebApp/Configurators/Edit.hs @@ -238,7 +238,7 @@ checkAssociatedDirectory cfg (Just r) = do RepoGroupStandard gr -> case associatedDirectory repoconfig gr of Just d -> inRepo $ \g -> createDirectoryIfMissing True $ - Git.repoPath g d + fromRawFilePath (Git.repoPath g) d Nothing -> noop _ -> noop diff --git a/Assistant/WebApp/Configurators/Pairing.hs b/Assistant/WebApp/Configurators/Pairing.hs index 5fcc42b28b..4088ebb1c5 100644 --- a/Assistant/WebApp/Configurators/Pairing.hs +++ b/Assistant/WebApp/Configurators/Pairing.hs @@ -173,7 +173,7 @@ getFinishLocalPairR = postFinishLocalPairR postFinishLocalPairR :: PairMsg -> Handler Html #ifdef WITH_PAIRING postFinishLocalPairR msg = promptSecret (Just msg) $ \_ secret -> do - repodir <- liftH $ repoPath <$> liftAnnex gitRepo + repodir <- liftH $ fromRawFilePath . repoPath <$> liftAnnex gitRepo liftIO $ setup repodir startLocalPairing PairAck (cleanup repodir) alert uuid "" secret where diff --git a/Assistant/WebApp/Configurators/Preferences.hs b/Assistant/WebApp/Configurators/Preferences.hs index 54b4add376..e16b9c8b16 100644 --- a/Assistant/WebApp/Configurators/Preferences.hs +++ b/Assistant/WebApp/Configurators/Preferences.hs @@ -94,7 +94,7 @@ storePrefs p = do unsetConfig (annexConfig "numcopies") -- deprecated setConfig (annexConfig "autoupgrade") (fromAutoUpgrade $ autoUpgrade p) unlessM ((==) <$> pure (autoStart p) <*> inAutoStartFile) $ do - here <- fromRepo Git.repoPath + here <- fromRawFilePath <$> fromRepo Git.repoPath liftIO $ if autoStart p then addAutoStartFile here else removeAutoStartFile here @@ -118,5 +118,5 @@ postPreferencesR = page "Preferences" (Just Configuration) $ do inAutoStartFile :: Annex Bool inAutoStartFile = do - here <- liftIO . absPath =<< fromRepo Git.repoPath + here <- liftIO . absPath . fromRawFilePath =<< fromRepo Git.repoPath any (`equalFilePath` here) <$> liftIO readAutoStartFile diff --git a/Assistant/WebApp/DashBoard.hs b/Assistant/WebApp/DashBoard.hs index 6b9d8787cb..0cd5e1389e 100644 --- a/Assistant/WebApp/DashBoard.hs +++ b/Assistant/WebApp/DashBoard.hs @@ -118,7 +118,8 @@ getFileBrowserR = whenM openFileBrowser redirectBack - blocking the response to the browser on it. -} openFileBrowser :: Handler Bool openFileBrowser = do - path <- liftIO . absPath =<< liftAnnex (fromRepo Git.repoPath) + path <- liftIO . absPath . fromRawFilePath + =<< liftAnnex (fromRepo Git.repoPath) #ifdef darwin_HOST_OS let cmd = "open" let p = proc cmd [path] diff --git a/Backend/WORM.hs b/Backend/WORM.hs index cd6be25fb1..35fa858b88 100644 --- a/Backend/WORM.hs +++ b/Backend/WORM.hs @@ -38,7 +38,8 @@ keyValue source _ = do let f = contentLocation source stat <- liftIO $ getFileStatus f sz <- liftIO $ getFileSize' f stat - relf <- getTopFilePath <$> inRepo (toTopFilePath $ keyFilename source) + relf <- fromRawFilePath . getTopFilePath + <$> inRepo (toTopFilePath $ toRawFilePath $ keyFilename source) return $ Just $ mkKey $ \k -> k { keyName = genKeyName relf , keyVariety = WORMKey diff --git a/CmdLine/Batch.hs b/CmdLine/Batch.hs index 4d1f33c289..b73e835f62 100644 --- a/CmdLine/Batch.hs +++ b/CmdLine/Batch.hs @@ -102,7 +102,8 @@ batchFilesMatching :: BatchFormat -> (FilePath -> CommandStart) -> Annex () batchFilesMatching fmt a = do matcher <- getMatcher batchStart fmt $ \f -> - ifM (matcher $ MatchingFile $ FileInfo f f) + let f' = toRawFilePath f + in ifM (matcher $ MatchingFile $ FileInfo f' f') ( a f , return Nothing ) diff --git a/CmdLine/Seek.hs b/CmdLine/Seek.hs index 97cc04a0cb..1811698f00 100644 --- a/CmdLine/Seek.hs +++ b/CmdLine/Seek.hs @@ -94,8 +94,8 @@ withPathContents a params = do , return [(p, takeFileName p)] ) checkmatch matcher (f, relf) = matcher $ MatchingFile $ FileInfo - { currFile = f - , matchFile = relf + { currFile = toRawFilePath f + , matchFile = toRawFilePath relf } withWords :: ([String] -> CommandSeek) -> CmdParams -> CommandSeek @@ -170,7 +170,7 @@ withKeyOptions ko auto keyaction = withKeyOptions' ko auto mkkeyaction return $ \v@(k, ai) -> let i = case ai of ActionItemBranchFilePath (BranchFilePath _ topf) _ -> - MatchingKey k (AssociatedFile $ Just $ toRawFilePath $ getTopFilePath topf) + MatchingKey k (AssociatedFile $ Just $ getTopFilePath topf) _ -> MatchingKey k (AssociatedFile Nothing) in whenM (matcher i) $ keyaction v @@ -232,8 +232,7 @@ prepFiltered a fs = do map (process matcher) <$> fs where process matcher f = - let f' = fromRawFilePath f - in whenM (matcher $ MatchingFile $ FileInfo f' f') $ a f + whenM (matcher $ MatchingFile $ FileInfo f f) $ a f seekActions :: Annex [CommandSeek] -> Annex () seekActions gen = sequence_ =<< gen diff --git a/Command/Add.hs b/Command/Add.hs index 919d217505..43f5520424 100644 --- a/Command/Add.hs +++ b/Command/Add.hs @@ -114,7 +114,7 @@ start file = do 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 (fromRawFilePath file)) + Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath file) next $ addFile file perform :: RawFilePath -> CommandPerform diff --git a/Command/Export.hs b/Command/Export.hs index 77ebc009f9..b9ceaca2f0 100644 --- a/Command/Export.hs +++ b/Command/Export.hs @@ -251,7 +251,7 @@ startExport :: Remote -> ExportHandle -> MVar FileUploaded -> MVar AllFilled -> startExport r db cvar allfilledvar ti = do ek <- exportKey (Git.LsTree.sha ti) stopUnless (notrecordedpresent ek) $ - starting ("export " ++ name r) (ActionItemOther (Just f)) $ + starting ("export " ++ name r) (ActionItemOther (Just (fromRawFilePath f))) $ ifM (either (const False) id <$> tryNonAsync (checkPresentExport (exportActions r) (asKey ek) loc)) ( next $ cleanupExport r db ek loc False , do @@ -259,9 +259,9 @@ startExport r db cvar allfilledvar ti = do performExport r db ek af (Git.LsTree.sha ti) loc allfilledvar ) where - loc = mkExportLocation (toRawFilePath f) + loc = mkExportLocation f f = getTopFilePath (Git.LsTree.file ti) - af = AssociatedFile (Just (toRawFilePath f)) + af = AssociatedFile (Just f) notrecordedpresent ek = (||) <$> liftIO (notElem loc <$> getExportedLocation db (asKey ek)) -- If content was removed from the remote, the export db @@ -314,17 +314,17 @@ startUnexport r db f shas = do eks <- forM (filter (/= nullSha) shas) exportKey if null eks then stop - else starting ("unexport " ++ name r) (ActionItemOther (Just f')) $ + else starting ("unexport " ++ name r) (ActionItemOther (Just (fromRawFilePath f'))) $ performUnexport r db eks loc where - loc = mkExportLocation (toRawFilePath f') + loc = mkExportLocation f' f' = getTopFilePath f 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 (fromRawFilePath f'))) $ performUnexport r db [ek] loc where - loc = mkExportLocation (toRawFilePath f') + loc = mkExportLocation f' f' = getTopFilePath f -- Unlike a usual drop from a repository, this does not check that @@ -368,15 +368,14 @@ startRecoverIncomplete r db sha oldf liftIO $ removeExportedLocation db (asKey ek) oldloc performUnexport r db [ek] loc where - oldloc = mkExportLocation (toRawFilePath oldf') - oldf' = getTopFilePath oldf + oldloc = mkExportLocation $ getTopFilePath oldf startMoveToTempName :: Remote -> ExportHandle -> TopFilePath -> ExportKey -> CommandStart startMoveToTempName r db f ek = starting ("rename " ++ name r) - (ActionItemOther $ Just $ f' ++ " -> " ++ fromRawFilePath (fromExportLocation tmploc)) + (ActionItemOther $ Just $ fromRawFilePath f' ++ " -> " ++ fromRawFilePath (fromExportLocation tmploc)) (performRename r db ek loc tmploc) where - loc = mkExportLocation (toRawFilePath f') + loc = mkExportLocation f' f' = getTopFilePath f tmploc = exportTempName ek @@ -384,10 +383,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 (fromRawFilePath (fromExportLocation tmploc) ++ " -> " ++ f'))) $ + starting ("rename " ++ name r) (ActionItemOther (Just (fromRawFilePath (fromExportLocation tmploc) ++ " -> " ++ fromRawFilePath f'))) $ performRename r db ek tmploc loc where - loc = mkExportLocation (toRawFilePath f') + loc = mkExportLocation f' f' = getTopFilePath f performRename :: Remote -> ExportHandle -> ExportKey -> ExportLocation -> ExportLocation -> CommandPerform @@ -469,7 +468,7 @@ filterPreferredContent r tree = logExportExcluded (uuid r) $ \logwriter -> do -- Match filename relative to the -- top of the tree. let af = AssociatedFile $ Just $ - toRawFilePath $ getTopFilePath topf + getTopFilePath topf let mi = MatchingKey k af ifM (checkMatcher' matcher mi mempty) ( return (Just ti) diff --git a/Command/Find.hs b/Command/Find.hs index 9ed9583c6b..4e71ac845a 100644 --- a/Command/Find.hs +++ b/Command/Find.hs @@ -74,7 +74,7 @@ start o file key = startKeys :: FindOptions -> (Key, ActionItem) -> CommandStart startKeys o (key, ActionItemBranchFilePath (BranchFilePath _ topf) _) = - start o (toRawFilePath (getTopFilePath topf)) key + start o (getTopFilePath topf) key startKeys _ _ = stop showFormatted :: Maybe Utility.Format.Format -> S.ByteString -> [(String, String)] -> Annex () diff --git a/Command/Fsck.hs b/Command/Fsck.hs index 256bdfa894..a55b882c09 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -313,7 +313,7 @@ verifyRequiredContent _ _ = return True verifyAssociatedFiles :: Key -> KeyStatus -> RawFilePath -> Annex Bool verifyAssociatedFiles key keystatus file = do when (isKeyUnlockedThin keystatus) $ do - f <- inRepo $ toTopFilePath $ fromRawFilePath file + f <- inRepo $ toTopFilePath file afs <- Database.Keys.getAssociatedFiles key unless (getTopFilePath f `elem` map getTopFilePath afs) $ Database.Keys.addAssociatedFile key f diff --git a/Command/Import.hs b/Command/Import.hs index 58c1b40f93..615fe5db1c 100644 --- a/Command/Import.hs +++ b/Command/Import.hs @@ -97,7 +97,7 @@ duplicateModeParser = seek :: ImportOptions -> CommandSeek seek o@(LocalImportOptions {}) = startConcurrency commandStages $ do - repopath <- liftIO . absPath =<< fromRepo Git.repoPath + repopath <- liftIO . absPath . fromRawFilePath =<< fromRepo Git.repoPath inrepops <- liftIO $ filter (dirContains repopath) <$> mapM absPath (importFiles o) unless (null inrepops) $ do giveup $ "cannot import files from inside the working tree (use git annex add instead): " ++ unwords inrepops @@ -110,7 +110,7 @@ seek o@(RemoteImportOptions {}) = startConcurrency commandStages $ do giveup "That remote does not support imports." subdir <- maybe (pure Nothing) - (Just <$$> inRepo . toTopFilePath) + (Just <$$> inRepo . toTopFilePath . toRawFilePath) (importToSubDir o) seekRemote r (importToBranch o) subdir diff --git a/Command/Info.hs b/Command/Info.hs index a0099ca06d..94292077f8 100644 --- a/Command/Info.hs +++ b/Command/Info.hs @@ -566,7 +566,7 @@ getDirStatInfo o dir = do where initial = (emptyKeyInfo, emptyKeyInfo, emptyNumCopiesStats, M.empty) update matcher fast key file vs@(presentdata, referenceddata, numcopiesstats, repodata) = - ifM (matcher $ MatchingFile $ FileInfo file' file') + ifM (matcher $ MatchingFile $ FileInfo file file) ( do !presentdata' <- ifM (inAnnex key) ( return $ addKey key presentdata @@ -577,13 +577,11 @@ getDirStatInfo o dir = do then return (numcopiesstats, repodata) else do locs <- Remote.keyLocations key - nc <- updateNumCopiesStats file' numcopiesstats locs + nc <- updateNumCopiesStats (fromRawFilePath file) numcopiesstats locs return (nc, updateRepoData key locs repodata) return $! (presentdata', referenceddata', numcopiesstats', repodata') , return vs ) - where - file' = fromRawFilePath file getTreeStatInfo :: InfoOptions -> Git.Ref -> Annex (Maybe StatInfo) getTreeStatInfo o r = do diff --git a/Command/Lock.hs b/Command/Lock.hs index 24dd6810ed..e0ca6e4594 100644 --- a/Command/Lock.hs +++ b/Command/Lock.hs @@ -80,7 +80,7 @@ performNew file key = do -- Try to repopulate obj from an unmodified associated file. repopulate obj = modifyContent obj $ do g <- Annex.gitRepo - fs <- map (`fromTopFilePath` g) + fs <- map fromRawFilePath . map (`fromTopFilePath` g) <$> Database.Keys.getAssociatedFiles key mfile <- firstM (isUnmodified key) fs liftIO $ nukeFile obj @@ -94,7 +94,7 @@ performNew file key = do cleanupNew :: RawFilePath -> Key -> CommandCleanup cleanupNew file key = do - Database.Keys.removeAssociatedFile key =<< inRepo (toTopFilePath (fromRawFilePath file)) + Database.Keys.removeAssociatedFile key =<< inRepo (toTopFilePath file) return True startOld :: RawFilePath -> CommandStart diff --git a/Command/Log.hs b/Command/Log.hs index 19ededcc02..861229183f 100644 --- a/Command/Log.hs +++ b/Command/Log.hs @@ -199,7 +199,7 @@ compareChanges format changes = concatMap diff changes getKeyLog :: Key -> [CommandParam] -> Annex ([RefChange], IO Bool) getKeyLog key os = do top <- fromRepo Git.repoPath - p <- liftIO $ relPathCwdToFile top + p <- liftIO $ relPathCwdToFile $ fromRawFilePath top config <- Annex.getGitConfig let logfile = p fromRawFilePath (locationLogFile config key) getGitLog [logfile] (Param "--remove-empty" : os) diff --git a/Command/Map.hs b/Command/Map.hs index 84f8ca5f16..de2a0c6dd6 100644 --- a/Command/Map.hs +++ b/Command/Map.hs @@ -176,7 +176,8 @@ absRepo reference r | Git.repoIsUrl reference = return $ Git.Construct.localToUrl reference r | Git.repoIsUrl r = return r | otherwise = liftIO $ do - r' <- Git.Construct.fromAbsPath =<< absPath (Git.repoPath r) + r' <- Git.Construct.fromAbsPath + =<< absPath (fromRawFilePath (Git.repoPath r)) r'' <- safely $ flip Annex.eval Annex.gitRepo =<< Annex.new r' return (fromMaybe r' r'') @@ -234,7 +235,7 @@ tryScan r where remotecmd = "sh -c " ++ shellEscape (cddir ++ " && " ++ "git config --null --list") - dir = Git.repoPath r + dir = fromRawFilePath $ Git.repoPath r cddir | "/~" `isPrefixOf` dir = let (userhome, reldir) = span (/= '/') (drop 1 dir) diff --git a/Command/Multicast.hs b/Command/Multicast.hs index 97966984a1..6c6d2c418b 100644 --- a/Command/Multicast.hs +++ b/Command/Multicast.hs @@ -137,7 +137,7 @@ send ups fs = do mk <- lookupFile f case mk of Nothing -> noop - Just k -> withObjectLoc k (addlist (fromRawFilePath f)) + Just k -> withObjectLoc k (addlist f) liftIO $ hClose h serverkey <- uftpKey diff --git a/Command/PostReceive.hs b/Command/PostReceive.hs index a362cc6543..096cc87e47 100644 --- a/Command/PostReceive.hs +++ b/Command/PostReceive.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Command.PostReceive where import Command diff --git a/Command/ReKey.hs b/Command/ReKey.hs index 6e0678c2cc..a67d876df7 100644 --- a/Command/ReKey.hs +++ b/Command/ReKey.hs @@ -123,7 +123,7 @@ cleanup file oldkey newkey = do writePointerFile file newkey mode stagePointerFile file mode =<< hashPointerFile newkey Database.Keys.removeAssociatedFile oldkey - =<< inRepo (toTopFilePath (fromRawFilePath file)) + =<< inRepo (toTopFilePath file) ) whenM (inAnnex newkey) $ logStatus newkey InfoPresent diff --git a/Command/ResolveMerge.hs b/Command/ResolveMerge.hs index 3a38ffaa7d..e3d9829be8 100644 --- a/Command/ResolveMerge.hs +++ b/Command/ResolveMerge.hs @@ -24,7 +24,7 @@ seek = withNothing (commandAction start) start :: CommandStart start = starting "resolvemerge" (ActionItemOther Nothing) $ do us <- fromMaybe nobranch <$> inRepo Git.Branch.current - d <- fromRepo Git.localGitDir + d <- fromRawFilePath <$> fromRepo Git.localGitDir let merge_head = d "MERGE_HEAD" them <- fromMaybe (error nomergehead) . extractSha <$> liftIO (readFile merge_head) diff --git a/Command/Smudge.hs b/Command/Smudge.hs index 30e2f2d168..9b5e57ede1 100644 --- a/Command/Smudge.hs +++ b/Command/Smudge.hs @@ -70,7 +70,7 @@ smudge file = do case parseLinkTargetOrPointerLazy b of Nothing -> noop Just k -> do - topfile <- inRepo (toTopFilePath file) + topfile <- inRepo (toTopFilePath (toRawFilePath file)) Database.Keys.addAssociatedFile k topfile void $ smudgeLog k topfile liftIO $ L.putStr b @@ -141,7 +141,8 @@ clean file = do -- git diff can run the clean filter on files outside the -- repository; can't annex those fileoutsiderepo = do - repopath <- liftIO . absPath =<< fromRepo Git.repoPath + repopath <- liftIO . absPath . fromRawFilePath + =<< fromRepo Git.repoPath filepath <- liftIO $ absPath file return $ not $ dirContains repopath filepath @@ -204,7 +205,7 @@ update = do updateSmudged :: Restage -> Annex () updateSmudged restage = streamSmudged $ \k topf -> do - f <- toRawFilePath <$> fromRepo (fromTopFilePath topf) + f <- fromRepo (fromTopFilePath topf) whenM (inAnnex k) $ do obj <- toRawFilePath <$> calcRepo (gitAnnexLocation k) unlessM (isJust <$> populatePointerFile restage k obj f) $ diff --git a/Command/Status.hs b/Command/Status.hs index e9c2b3580e..82c48e2b75 100644 --- a/Command/Status.hs +++ b/Command/Status.hs @@ -61,6 +61,6 @@ displayStatus (Renamed _ _) = noop displayStatus s = do let c = statusChar s absf <- fromRepo $ fromTopFilePath (statusFile s) - f <- liftIO $ relPathCwdToFile absf + f <- liftIO $ relPathCwdToFile $ fromRawFilePath absf unlessM (showFullJSON $ JSONChunk [("status", [c]), ("file", f)]) $ liftIO $ putStrLn $ [c] ++ " " ++ f diff --git a/Command/Sync.hs b/Command/Sync.hs index 880b1dbbc0..ff35f2219a 100644 --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -226,7 +226,7 @@ seek' o = do - of the repo. This also means that sync always acts on all files in the - repository, not just on a subdirectory. -} prepMerge :: Annex () -prepMerge = Annex.changeDirectory =<< fromRepo Git.repoPath +prepMerge = Annex.changeDirectory . fromRawFilePath =<< fromRepo Git.repoPath mergeConfig :: [Git.Merge.MergeConfig] mergeConfig = @@ -409,7 +409,7 @@ importRemote o mergeconfig remote currbranch let branch = Git.Ref b let subdir = if null s then Nothing - else Just (asTopFilePath s) + else Just (asTopFilePath (toRawFilePath s)) Command.Import.seekRemote remote branch subdir void $ mergeRemote remote currbranch mergeconfig (resolveMergeOverride o) @@ -468,7 +468,7 @@ pushRemote o remote (Just branch, _) = stopUnless (pure (pushOption o) <&&> need ( liftIO $ do p <- readProgramFile boolSystem' p [Param "post-receive"] - (\cp -> cp { cwd = Just wt }) + (\cp -> cp { cwd = Just (fromRawFilePath wt) }) , return True ) where diff --git a/Command/Unannex.hs b/Command/Unannex.hs index 7610b56176..356ff1d946 100644 --- a/Command/Unannex.hs +++ b/Command/Unannex.hs @@ -28,22 +28,22 @@ seek ps = (withFilesInGit $ commandAction . whenAnnexed start) =<< workTreeItems start :: RawFilePath -> Key -> CommandStart start file key = stopUnless (inAnnex key) $ starting "unannex" (mkActionItem (key, file)) $ - perform (fromRawFilePath file) key + perform file key -perform :: FilePath -> Key -> CommandPerform +perform :: RawFilePath -> Key -> CommandPerform perform file key = do - liftIO $ removeFile file + liftIO $ removeFile (fromRawFilePath file) inRepo $ Git.Command.run [ Param "rm" , Param "--cached" , Param "--force" , Param "--quiet" , Param "--" - , File file + , File (fromRawFilePath file) ] next $ cleanup file key -cleanup :: FilePath -> Key -> CommandCleanup +cleanup :: RawFilePath -> Key -> CommandCleanup cleanup file key = do Database.Keys.removeAssociatedFile key =<< inRepo (toTopFilePath file) src <- calcRepo $ gitAnnexLocation key @@ -61,11 +61,12 @@ cleanup file key = do , copyfrom src ) where + file' = fromRawFilePath file copyfrom src = - thawContent file `after` liftIO (copyFileExternal CopyAllMetaData src file) + thawContent file' `after` liftIO (copyFileExternal CopyAllMetaData src file') hardlinkfrom src = -- creating a hard link could fall; fall back to copying - ifM (liftIO $ catchBoolIO $ createLink src file >> return True) + ifM (liftIO $ catchBoolIO $ createLink src file' >> return True) ( return True , copyfrom src ) diff --git a/Command/Undo.hs b/Command/Undo.hs index fd4b3b263d..0899715a09 100644 --- a/Command/Undo.hs +++ b/Command/Undo.hs @@ -51,7 +51,7 @@ perform p = do -- Get the reversed diff that needs to be applied to undo. (diff, cleanup) <- inRepo $ diffLog [Param "-R", Param "--", Param p] - top <- inRepo $ toTopFilePath p + top <- inRepo $ toTopFilePath $ toRawFilePath p let diff' = filter (`isDiffOf` top) diff liftIO $ streamUpdateIndex g (map stageDiffTreeItem diff') @@ -59,7 +59,8 @@ perform p = do -- and then any adds. This order is necessary to handle eg, removing -- a directory and replacing it with a file. let (removals, adds) = partition (\di -> dstsha di == nullSha) diff' - let mkrel di = liftIO $ relPathCwdToFile $ fromTopFilePath (file di) g + let mkrel di = liftIO $ relPathCwdToFile $ fromRawFilePath $ + fromTopFilePath (file di) g forM_ removals $ \di -> do f <- mkrel di diff --git a/Command/Uninit.hs b/Command/Uninit.hs index 1e4ebdf2dc..6c62694543 100644 --- a/Command/Uninit.hs +++ b/Command/Uninit.hs @@ -29,7 +29,7 @@ check = do b <- current_branch when (b == Annex.Branch.name) $ giveup $ "cannot uninit when the " ++ Git.fromRef b ++ " branch is checked out" - top <- fromRepo Git.repoPath + top <- fromRawFilePath <$> fromRepo Git.repoPath currdir <- liftIO getCurrentDirectory whenM ((/=) <$> liftIO (absPath top) <*> liftIO (absPath currdir)) $ giveup "can only run uninit from the top of the git repository" diff --git a/Command/Unlock.hs b/Command/Unlock.hs index 443ac46e3c..ce53b1d0bb 100644 --- a/Command/Unlock.hs +++ b/Command/Unlock.hs @@ -57,5 +57,5 @@ perform dest key = do cleanup :: RawFilePath -> Key -> Maybe FileMode -> CommandCleanup cleanup dest key destmode = do stagePointerFile dest destmode =<< hashPointerFile key - Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath (fromRawFilePath dest)) + Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath dest) return True diff --git a/Command/Unused.hs b/Command/Unused.hs index 345111ec81..7f49440e6b 100644 --- a/Command/Unused.hs +++ b/Command/Unused.hs @@ -207,7 +207,7 @@ withKeysReferenced' mdir initial a = do ( return ([], return True) , do top <- fromRepo Git.repoPath - inRepo $ LsFiles.allFiles [toRawFilePath top] + inRepo $ LsFiles.allFiles [top] ) Just dir -> inRepo $ LsFiles.inRepo [toRawFilePath dir] go v [] = return v @@ -283,7 +283,7 @@ associatedFilesFilter = filterM go checkunmodified _ [] = return True checkunmodified cs (f:fs) = do relf <- fromRepo $ fromTopFilePath f - ifM (sameInodeCache relf cs) + ifM (sameInodeCache (fromRawFilePath relf) cs) ( return False , checkunmodified cs fs ) diff --git a/Command/View.hs b/Command/View.hs index 58e7a8c8b0..f4aba27675 100644 --- a/Command/View.hs +++ b/Command/View.hs @@ -99,7 +99,7 @@ checkoutViewBranch view mkbranch = do - and this pollutes the view, so remove them. - (However, emptry directories used by submodules are not - removed.) -} - top <- liftIO . absPath =<< fromRepo Git.repoPath + top <- liftIO . absPath . fromRawFilePath =<< fromRepo Git.repoPath (l, cleanup) <- inRepo $ LsFiles.notInRepoIncludingEmptyDirectories False [toRawFilePath top] @@ -110,8 +110,8 @@ checkoutViewBranch view mkbranch = do return ok where removeemptydir top d = do - p <- inRepo $ toTopFilePath $ fromRawFilePath d - liftIO $ tryIO $ removeDirectory (top getTopFilePath p) + p <- inRepo $ toTopFilePath d + liftIO $ tryIO $ removeDirectory (top fromRawFilePath (getTopFilePath p)) cwdmissing top = unlines [ "This view does not include the subdirectory you are currently in." , "Perhaps you should: cd " ++ top diff --git a/Database/ContentIdentifier.hs b/Database/ContentIdentifier.hs index bbe3022367..024825eaec 100644 --- a/Database/ContentIdentifier.hs +++ b/Database/ContentIdentifier.hs @@ -145,7 +145,7 @@ updateFromLog db (oldtree, currtree) = do recordAnnexBranchTree db currtree flushDbQueue db where - go ti = case extLogFileKey remoteContentIdentifierExt (toRawFilePath (getTopFilePath (DiffTree.file ti))) of + go ti = case extLogFileKey remoteContentIdentifierExt (getTopFilePath (DiffTree.file ti)) of Nothing -> return () Just k -> do l <- Log.getContentIdentifiers k diff --git a/Database/Export.hs b/Database/Export.hs index 6168a60616..7604feea35 100644 --- a/Database/Export.hs +++ b/Database/Export.hs @@ -220,7 +220,7 @@ mkExportDiffUpdater removeold addnew h srcek dstek i = do Nothing -> return () Just k -> liftIO $ addnew h (asKey k) loc where - loc = mkExportLocation $ toRawFilePath $ getTopFilePath $ Git.DiffTree.file i + loc = mkExportLocation $ getTopFilePath $ Git.DiffTree.file i runExportDiffUpdater :: ExportDiffUpdater -> ExportHandle -> Sha -> Sha -> Annex () runExportDiffUpdater updater h old new = do diff --git a/Database/Keys.hs b/Database/Keys.hs index bff7109135..b04dff02be 100644 --- a/Database/Keys.hs +++ b/Database/Keys.hs @@ -279,7 +279,7 @@ reconcileStaged qh = do ((':':_srcmode):dstmode:_srcsha:dstsha:_change:[]) -- Only want files, not symlinks | dstmode /= decodeBS' (fmtTreeItemType TreeSymlink) -> do - maybe noop (reconcile (asTopFilePath file)) + maybe noop (reconcile (asTopFilePath (toRawFilePath file))) =<< catKey (Ref dstsha) procdiff rest True | otherwise -> procdiff rest changed @@ -294,7 +294,7 @@ reconcileStaged qh = do caches <- liftIO $ SQL.getInodeCaches ikey (SQL.ReadHandle qh) keyloc <- calcRepo (gitAnnexLocation key) keypopulated <- sameInodeCache keyloc caches - p <- fromRepo $ toRawFilePath . fromTopFilePath file + p <- fromRepo $ fromTopFilePath file filepopulated <- sameInodeCache (fromRawFilePath p) caches case (keypopulated, filepopulated) of (True, False) -> diff --git a/Database/Keys/SQL.hs b/Database/Keys/SQL.hs index 4b7a7ec625..99606bbad5 100644 --- a/Database/Keys/SQL.hs +++ b/Database/Keys/SQL.hs @@ -17,6 +17,7 @@ import Database.Types import Database.Handle import qualified Database.Queue as H import Utility.InodeCache +import Utility.FileSystemEncoding import Git.FilePath import Database.Persist.Sql @@ -69,7 +70,7 @@ addAssociatedFile ik f = queueDb $ do deleteWhere [AssociatedFile ==. af, AssociatedKey !=. ik] void $ insertUnique $ Associated ik af where - af = toSFilePath (getTopFilePath f) + af = toSFilePath (fromRawFilePath (getTopFilePath f)) -- Does not remove any old association for a file, but less expensive -- than addAssociatedFile. Calling dropAllAssociatedFiles first and then @@ -77,7 +78,7 @@ addAssociatedFile ik f = queueDb $ do addAssociatedFileFast :: IKey -> TopFilePath -> WriteHandle -> IO () addAssociatedFileFast ik f = queueDb $ void $ insertUnique $ Associated ik af where - af = toSFilePath (getTopFilePath f) + af = toSFilePath (fromRawFilePath (getTopFilePath f)) dropAllAssociatedFiles :: WriteHandle -> IO () dropAllAssociatedFiles = queueDb $ @@ -88,7 +89,7 @@ dropAllAssociatedFiles = queueDb $ getAssociatedFiles :: IKey -> ReadHandle -> IO [TopFilePath] getAssociatedFiles ik = readDb $ do l <- selectList [AssociatedKey ==. ik] [] - return $ map (asTopFilePath . fromSFilePath . associatedFile . entityVal) l + return $ map (asTopFilePath . toRawFilePath . fromSFilePath . associatedFile . entityVal) l {- Gets any keys that are on record as having a particular associated file. - (Should be one or none but the database doesn't enforce that.) -} @@ -97,13 +98,13 @@ getAssociatedKey f = readDb $ do l <- selectList [AssociatedFile ==. af] [] return $ map (associatedKey . entityVal) l where - af = toSFilePath (getTopFilePath f) + af = toSFilePath (fromRawFilePath (getTopFilePath f)) removeAssociatedFile :: IKey -> TopFilePath -> WriteHandle -> IO () removeAssociatedFile ik f = queueDb $ deleteWhere [AssociatedKey ==. ik, AssociatedFile ==. af] where - af = toSFilePath (getTopFilePath f) + af = toSFilePath (fromRawFilePath (getTopFilePath f)) addInodeCaches :: IKey -> [InodeCache] -> WriteHandle -> IO () addInodeCaches ik is = queueDb $ diff --git a/Git.hs b/Git.hs index d6147db650..87a8d19720 100644 --- a/Git.hs +++ b/Git.hs @@ -51,35 +51,35 @@ import Utility.FileMode repoDescribe :: Repo -> String repoDescribe Repo { remoteName = Just name } = name repoDescribe Repo { location = Url url } = show url -repoDescribe Repo { location = Local { worktree = Just dir } } = dir -repoDescribe Repo { location = Local { gitdir = dir } } = dir -repoDescribe Repo { location = LocalUnknown dir } = dir +repoDescribe Repo { location = Local { worktree = Just dir } } = fromRawFilePath dir +repoDescribe Repo { location = Local { gitdir = dir } } = fromRawFilePath dir +repoDescribe Repo { location = LocalUnknown dir } = fromRawFilePath dir repoDescribe Repo { location = Unknown } = "UNKNOWN" {- Location of the repo, either as a path or url. -} repoLocation :: Repo -> String repoLocation Repo { location = Url url } = show url -repoLocation Repo { location = Local { worktree = Just dir } } = dir -repoLocation Repo { location = Local { gitdir = dir } } = dir -repoLocation Repo { location = LocalUnknown dir } = dir +repoLocation Repo { location = Local { worktree = Just dir } } = fromRawFilePath dir +repoLocation Repo { location = Local { gitdir = dir } } = fromRawFilePath dir +repoLocation Repo { location = LocalUnknown dir } = fromRawFilePath dir repoLocation Repo { location = Unknown } = error "unknown repoLocation" {- Path to a repository. For non-bare, this is the worktree, for bare, - it's the gitdir, and for URL repositories, is the path on the remote - host. -} -repoPath :: Repo -> FilePath -repoPath Repo { location = Url u } = unEscapeString $ uriPath u +repoPath :: Repo -> RawFilePath +repoPath Repo { location = Url u } = toRawFilePath $ unEscapeString $ uriPath u repoPath Repo { location = Local { worktree = Just d } } = d repoPath Repo { location = Local { gitdir = d } } = d repoPath Repo { location = LocalUnknown dir } = dir repoPath Repo { location = Unknown } = error "unknown repoPath" -repoWorkTree :: Repo -> Maybe FilePath +repoWorkTree :: Repo -> Maybe RawFilePath repoWorkTree Repo { location = Local { worktree = Just d } } = Just d repoWorkTree _ = Nothing {- Path to a local repository's .git directory. -} -localGitDir :: Repo -> FilePath +localGitDir :: Repo -> RawFilePath localGitDir Repo { location = Local { gitdir = d } } = d localGitDir _ = error "unknown localGitDir" @@ -132,16 +132,17 @@ assertLocal repo action attributes :: Repo -> FilePath attributes repo | repoIsLocalBare repo = attributesLocal repo - | otherwise = repoPath repo ".gitattributes" + | otherwise = fromRawFilePath (repoPath repo) ".gitattributes" attributesLocal :: Repo -> FilePath -attributesLocal repo = localGitDir repo "info" "attributes" +attributesLocal repo = fromRawFilePath (localGitDir repo) + "info" "attributes" {- Path to a given hook script in a repository, only if the hook exists - and is executable. -} hookPath :: String -> Repo -> IO (Maybe FilePath) hookPath script repo = do - let hook = localGitDir repo "hooks" script + let hook = fromRawFilePath (localGitDir repo) "hooks" script ifM (catchBoolIO $ isexecutable hook) ( return $ Just hook , return Nothing ) where @@ -157,22 +158,22 @@ relPath = adjustPath torel where torel p = do p' <- relPathCwdToFile p - if null p' - then return "." - else return p' + return $ if null p' then "." else p' {- Adusts the path to a local Repo using the provided function. -} adjustPath :: (FilePath -> IO FilePath) -> Repo -> IO Repo adjustPath f r@(Repo { location = l@(Local { gitdir = d, worktree = w }) }) = do - d' <- f d - w' <- maybe (pure Nothing) (Just <$$> f) w + d' <- f' d + w' <- maybe (pure Nothing) (Just <$$> f') w return $ r { location = l { gitdir = d' , worktree = w' } } + where + f' v = toRawFilePath <$> f (fromRawFilePath v) adjustPath f r@(Repo { location = LocalUnknown d }) = do - d' <- f d + d' <- toRawFilePath <$> f (fromRawFilePath d) return $ r { location = LocalUnknown d' } adjustPath _ r = pure r diff --git a/Git/Command.hs b/Git/Command.hs index c2477529cf..eb20af2dc9 100644 --- a/Git/Command.hs +++ b/Git/Command.hs @@ -24,10 +24,10 @@ gitCommandLine params r@(Repo { location = l@(Local { } ) }) = where setdir | gitEnvOverridesGitDir r = [] - | otherwise = [Param $ "--git-dir=" ++ gitdir l] + | otherwise = [Param $ "--git-dir=" ++ fromRawFilePath (gitdir l)] settree = case worktree l of Nothing -> [] - Just t -> [Param $ "--work-tree=" ++ t] + Just t -> [Param $ "--work-tree=" ++ fromRawFilePath t] gitCommandLine _ repo = assertLocal repo $ error "internal" {- Runs git in the specified repo. -} diff --git a/Git/Config.hs b/Git/Config.hs index 5276e46835..1927fd14cf 100644 --- a/Git/Config.hs +++ b/Git/Config.hs @@ -13,6 +13,7 @@ import qualified Data.Map as M import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import Data.Char +import qualified System.FilePath.ByteString as P import Common import Git @@ -61,7 +62,7 @@ read' repo = go repo where params = ["config", "--null", "--list"] p = (proc "git" params) - { cwd = Just d + { cwd = Just (fromRawFilePath d) , env = gitEnv repo } @@ -114,13 +115,13 @@ store' k v repo = repo -} updateLocation :: Repo -> IO Repo updateLocation r@(Repo { location = LocalUnknown d }) - | isBare r = ifM (doesDirectoryExist dotgit) + | isBare r = ifM (doesDirectoryExist (fromRawFilePath dotgit)) ( updateLocation' r $ Local dotgit Nothing , updateLocation' r $ Local d Nothing ) | otherwise = updateLocation' r $ Local dotgit (Just d) where - dotgit = (d ".git") + dotgit = d P. ".git" updateLocation r@(Repo { location = l@(Local {}) }) = updateLocation' r l updateLocation r = return r @@ -130,9 +131,9 @@ updateLocation' r l = do Nothing -> return l Just (ConfigValue d) -> do {- core.worktree is relative to the gitdir -} - top <- absPath $ gitdir l + top <- absPath $ fromRawFilePath (gitdir l) let p = absPathFrom top (fromRawFilePath d) - return $ l { worktree = Just p } + return $ l { worktree = Just (toRawFilePath p) } return $ r { location = l' } {- Parses git config --list or git config --null --list output into a diff --git a/Git/Construct.hs b/Git/Construct.hs index 7a58a5d444..5b656eba72 100644 --- a/Git/Construct.hs +++ b/Git/Construct.hs @@ -62,7 +62,7 @@ fromAbsPath dir | otherwise = error $ "internal error, " ++ dir ++ " is not absolute" where - ret = pure . newFrom . LocalUnknown + ret = pure . newFrom . LocalUnknown . toRawFilePath canondir = dropTrailingPathSeparator dir {- When dir == "foo/.git", git looks for "foo/.git/.git", - and failing that, uses "foo" as the repository. -} @@ -117,7 +117,7 @@ localToUrl reference r [ Url.scheme reference , "//" , auth - , repoPath r + , fromRawFilePath (repoPath r) ] in r { location = Url $ fromJust $ parseURI absurl } @@ -154,7 +154,7 @@ fromRemoteLocation s repo = gen $ parseRemoteLocation s repo fromRemotePath :: FilePath -> Repo -> IO Repo fromRemotePath dir repo = do dir' <- expandTilde dir - fromPath $ repoPath repo dir' + fromPath $ fromRawFilePath (repoPath repo) dir' {- Git remotes can have a directory that is specified relative - to the user's home directory, or that contains tilde expansions. @@ -204,7 +204,7 @@ checkForRepo dir = where check test cont = maybe cont (return . Just) =<< test checkdir c = ifM c - ( return $ Just $ LocalUnknown dir + ( return $ Just $ LocalUnknown $ toRawFilePath dir , return Nothing ) isRepo = checkdir $ @@ -224,9 +224,9 @@ checkForRepo dir = catchDefaultIO "" (readFile $ dir ".git") return $ if gitdirprefix `isPrefixOf` c then Just $ Local - { gitdir = absPathFrom dir $ + { gitdir = toRawFilePath $ absPathFrom dir $ drop (length gitdirprefix) c - , worktree = Just dir + , worktree = Just (toRawFilePath dir) } else Nothing where diff --git a/Git/CurrentRepo.hs b/Git/CurrentRepo.hs index f8383326a5..054a81e0b0 100644 --- a/Git/CurrentRepo.hs +++ b/Git/CurrentRepo.hs @@ -37,7 +37,7 @@ get = do gd <- getpathenv "GIT_DIR" r <- configure gd =<< fromCwd prefix <- getpathenv "GIT_PREFIX" - wt <- maybe (worktree $ location r) Just + wt <- maybe (fromRawFilePath <$> worktree (location r)) Just <$> getpathenvprefix "GIT_WORK_TREE" prefix case wt of Nothing -> return r @@ -68,13 +68,18 @@ get = do absd <- absPath d curr <- getCurrentDirectory r <- Git.Config.read $ newFrom $ - Local { gitdir = absd, worktree = Just curr } + Local + { gitdir = toRawFilePath absd + , worktree = Just (toRawFilePath curr) + } return $ if Git.Config.isBare r then r { location = (location r) { worktree = Nothing } } else r configure Nothing Nothing = giveup "Not in a git repository." - addworktree w r = changelocation r $ - Local { gitdir = gitdir (location r), worktree = w } + addworktree w r = changelocation r $ Local + { gitdir = gitdir (location r) + , worktree = fmap toRawFilePath w + } changelocation r l = r { location = l } diff --git a/Git/DiffTree.hs b/Git/DiffTree.hs index f6c5c60955..5f556b1ee8 100644 --- a/Git/DiffTree.hs +++ b/Git/DiffTree.hs @@ -31,9 +31,9 @@ import qualified Git.Ref {- Checks if the DiffTreeItem modifies a file with a given name - or under a directory by that name. -} isDiffOf :: DiffTreeItem -> TopFilePath -> Bool -isDiffOf diff f = case getTopFilePath f of +isDiffOf diff f = case fromRawFilePath (getTopFilePath f) of "" -> True -- top of repo contains all - d -> d `dirContains` getTopFilePath (file diff) + d -> d `dirContains` fromRawFilePath (getTopFilePath (file diff)) {- Diffs two tree Refs. -} diffTree :: Ref -> Ref -> Repo -> IO ([DiffTreeItem], IO Bool) @@ -113,7 +113,7 @@ parseDiffRaw l = go l , srcsha = fromMaybe (error "bad srcsha") $ extractSha ssha , dstsha = fromMaybe (error "bad dstsha") $ extractSha dsha , status = s - , file = asTopFilePath $ fromRawFilePath $ fromInternalGitPath $ Git.Filename.decode $ toRawFilePath f + , file = asTopFilePath $ fromInternalGitPath $ Git.Filename.decode $ toRawFilePath f } where readmode = fst . Prelude.head . readOct diff --git a/Git/Env.hs b/Git/Env.hs index b824e1f234..fb0377f85d 100644 --- a/Git/Env.hs +++ b/Git/Env.hs @@ -30,8 +30,10 @@ addGitEnv g var val = adjustGitEnv g (addEntry var val) - and a copy of the rest of the system environment. -} propGitEnv :: Repo -> IO [(String, String)] propGitEnv g = do - g' <- addGitEnv g "GIT_DIR" (localGitDir g) - g'' <- maybe (pure g') (addGitEnv g' "GIT_WORK_TREE") (repoWorkTree g) + g' <- addGitEnv g "GIT_DIR" (fromRawFilePath (localGitDir g)) + g'' <- maybe (pure g') + (addGitEnv g' "GIT_WORK_TREE" . fromRawFilePath) + (repoWorkTree g) return $ fromMaybe [] (gitEnv g'') {- Use with any action that makes a commit to set metadata. -} diff --git a/Git/FilePath.hs b/Git/FilePath.hs index bb80df4815..66a015994e 100644 --- a/Git/FilePath.hs +++ b/Git/FilePath.hs @@ -5,7 +5,7 @@ - top of the repository even when run in a subdirectory. Adding some - types helps keep that straight. - - - Copyright 2012-2013 Joey Hess + - Copyright 2012-2019 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -31,13 +31,14 @@ module Git.FilePath ( import Common import Git -import qualified System.FilePath.Posix +import qualified System.FilePath.ByteString as P +import qualified System.FilePath.Posix.ByteString import GHC.Generics import Control.DeepSeq import qualified Data.ByteString as S {- A RawFilePath, relative to the top of the git repository. -} -newtype TopFilePath = TopFilePath { getTopFilePath :: FilePath } +newtype TopFilePath = TopFilePath { getTopFilePath :: RawFilePath } deriving (Show, Eq, Ord, Generic) instance NFData TopFilePath @@ -49,19 +50,20 @@ data BranchFilePath = BranchFilePath Ref TopFilePath {- Git uses the branch:file form to refer to a BranchFilePath -} descBranchFilePath :: BranchFilePath -> S.ByteString descBranchFilePath (BranchFilePath b f) = - encodeBS' (fromRef b) <> ":" <> toRawFilePath (getTopFilePath f) + encodeBS' (fromRef b) <> ":" <> getTopFilePath f {- Path to a TopFilePath, within the provided git repo. -} -fromTopFilePath :: TopFilePath -> Git.Repo -> FilePath -fromTopFilePath p repo = combine (repoPath repo) (getTopFilePath p) +fromTopFilePath :: TopFilePath -> Git.Repo -> RawFilePath +fromTopFilePath p repo = P.combine (repoPath repo) (getTopFilePath p) {- The input FilePath can be absolute, or relative to the CWD. -} -toTopFilePath :: FilePath -> Git.Repo -> IO TopFilePath -toTopFilePath file repo = TopFilePath <$> relPathDirToFile (repoPath repo) file +toTopFilePath :: RawFilePath -> Git.Repo -> IO TopFilePath +toTopFilePath file repo = TopFilePath . toRawFilePath + <$> relPathDirToFile (fromRawFilePath (repoPath repo)) (fromRawFilePath file) -{- The input FilePath must already be relative to the top of the git +{- The input RawFilePath must already be relative to the top of the git - repository -} -asTopFilePath :: FilePath -> TopFilePath +asTopFilePath :: RawFilePath -> TopFilePath asTopFilePath file = TopFilePath file {- Git may use a different representation of a path when storing @@ -91,5 +93,5 @@ fromInternalGitPath = encodeBS . replace "/" "\\" . decodeBS - so try posix paths. -} absoluteGitPath :: RawFilePath -> Bool -absoluteGitPath p = isAbsolute (decodeBS p) || - System.FilePath.Posix.isAbsolute (decodeBS (toInternalGitPath p)) +absoluteGitPath p = P.isAbsolute p || + System.FilePath.Posix.ByteString.isAbsolute (toInternalGitPath p) diff --git a/Git/Hook.hs b/Git/Hook.hs index 9fcc0c66d5..100111dba6 100644 --- a/Git/Hook.hs +++ b/Git/Hook.hs @@ -28,7 +28,7 @@ instance Eq Hook where a == b = hookName a == hookName b hookFile :: Hook -> Repo -> FilePath -hookFile h r = localGitDir r "hooks" hookName h +hookFile h r = fromRawFilePath (localGitDir r) "hooks" hookName h {- Writes a hook. Returns False if the hook already exists with a different - content. Upgrades old scripts. diff --git a/Git/Index.hs b/Git/Index.hs index a5bd7b9a9c..afd29c2967 100644 --- a/Git/Index.hs +++ b/Git/Index.hs @@ -49,7 +49,7 @@ override index _r = do {- The normal index file. Does not check GIT_INDEX_FILE. -} indexFile :: Repo -> FilePath -indexFile r = localGitDir r "index" +indexFile r = fromRawFilePath (localGitDir r) "index" {- The index file git will currently use, checking GIT_INDEX_FILE. -} currentIndexFile :: Repo -> IO FilePath diff --git a/Git/LsFiles.hs b/Git/LsFiles.hs index 160c0c1ec1..5534307d6b 100644 --- a/Git/LsFiles.hs +++ b/Git/LsFiles.hs @@ -185,7 +185,7 @@ typeChanged' ps l repo = do (fs, cleanup) <- pipeNullSplit (prefix ++ ps ++ suffix) repo -- git diff returns filenames relative to the top of the git repo; -- convert to filenames relative to the cwd, like git ls-files. - top <- absPath (repoPath repo) + top <- absPath (fromRawFilePath (repoPath repo)) currdir <- getCurrentDirectory return (map (\f -> toRawFilePath (relPathDirToFileAbs currdir $ top decodeBL' f)) fs, cleanup) where diff --git a/Git/LsTree.hs b/Git/LsTree.hs index 0196d21a1f..a3d8383934 100644 --- a/Git/LsTree.hs +++ b/Git/LsTree.hs @@ -100,7 +100,7 @@ parserLsTree = TreeItem <*> (Ref . decodeBS' <$> A.take shaSize) <* A8.char '\t' -- file - <*> (asTopFilePath . decodeBS' . Git.Filename.decode <$> A.takeByteString) + <*> (asTopFilePath . Git.Filename.decode <$> A.takeByteString) {- Inverse of parseLsTree -} formatLsTree :: TreeItem -> String @@ -108,5 +108,5 @@ formatLsTree ti = unwords [ showOct (mode ti) "" , decodeBS (typeobj ti) , fromRef (sha ti) - , getTopFilePath (file ti) + , fromRawFilePath (getTopFilePath (file ti)) ] diff --git a/Git/Objects.hs b/Git/Objects.hs index 3c1108dd13..c9ede4da9a 100644 --- a/Git/Objects.hs +++ b/Git/Objects.hs @@ -12,7 +12,7 @@ import Git import Git.Sha objectsDir :: Repo -> FilePath -objectsDir r = localGitDir r "objects" +objectsDir r = fromRawFilePath (localGitDir r) "objects" packDir :: Repo -> FilePath packDir r = objectsDir r "pack" diff --git a/Git/Ref.hs b/Git/Ref.hs index 8c8511ae04..621e328f27 100644 --- a/Git/Ref.hs +++ b/Git/Ref.hs @@ -22,7 +22,7 @@ headRef :: Ref headRef = Ref "HEAD" headFile :: Repo -> FilePath -headFile r = localGitDir r "HEAD" +headFile r = fromRawFilePath (localGitDir r) "HEAD" setHeadRef :: Ref -> Repo -> IO () setHeadRef ref r = writeFile (headFile r) ("ref: " ++ fromRef ref) @@ -85,7 +85,7 @@ exists ref = runBool {- The file used to record a ref. (Git also stores some refs in a - packed-refs file.) -} file :: Ref -> Repo -> FilePath -file ref repo = localGitDir repo fromRef ref +file ref repo = fromRawFilePath (localGitDir repo) fromRef ref {- Checks if HEAD exists. It generally will, except for in a repository - that was just created. -} diff --git a/Git/Repair.hs b/Git/Repair.hs index 6031f4dd73..66e68117f3 100644 --- a/Git/Repair.hs +++ b/Git/Repair.hs @@ -227,7 +227,7 @@ badBranches missing r = filterM isbad =<< getAllRefs r - Relies on packed refs being exploded before it's called. -} getAllRefs :: Repo -> IO [Ref] -getAllRefs r = getAllRefs' (localGitDir r "refs") +getAllRefs r = getAllRefs' (fromRawFilePath (localGitDir r) "refs") getAllRefs' :: FilePath -> IO [Ref] getAllRefs' refdir = do @@ -245,13 +245,13 @@ explodePackedRefsFile r = do nukeFile f where makeref (sha, ref) = do - let dest = localGitDir r fromRef ref + let dest = fromRawFilePath (localGitDir r) fromRef ref createDirectoryIfMissing True (parentDir dest) unlessM (doesFileExist dest) $ writeFile dest (fromRef sha) packedRefsFile :: Repo -> FilePath -packedRefsFile r = localGitDir r "packed-refs" +packedRefsFile r = fromRawFilePath (localGitDir r) "packed-refs" parsePacked :: String -> Maybe (Sha, Ref) parsePacked l = case words l of @@ -263,7 +263,7 @@ parsePacked l = case words l of {- git-branch -d cannot be used to remove a branch that is directly - pointing to a corrupt commit. -} nukeBranchRef :: Branch -> Repo -> IO () -nukeBranchRef b r = nukeFile $ localGitDir r fromRef b +nukeBranchRef b r = nukeFile $ fromRawFilePath (localGitDir r) fromRef b {- Finds the most recent commit to a branch that does not need any - of the missing objects. If the input branch is good as-is, returns it. @@ -366,16 +366,16 @@ checkIndex r = do - itself is not corrupt. -} checkIndexFast :: Repo -> IO Bool checkIndexFast r = do - (indexcontents, cleanup) <- LsFiles.stagedDetails [toRawFilePath (repoPath r)] r + (indexcontents, cleanup) <- LsFiles.stagedDetails [repoPath r] r length indexcontents `seq` cleanup missingIndex :: Repo -> IO Bool -missingIndex r = not <$> doesFileExist (localGitDir r "index") +missingIndex r = not <$> doesFileExist (fromRawFilePath (localGitDir r) "index") {- Finds missing and ok files staged in the index. -} partitionIndex :: Repo -> IO ([LsFiles.StagedDetails], [LsFiles.StagedDetails], IO Bool) partitionIndex r = do - (indexcontents, cleanup) <- LsFiles.stagedDetails [toRawFilePath (repoPath r)] r + (indexcontents, cleanup) <- LsFiles.stagedDetails [repoPath r] r l <- forM indexcontents $ \i -> case i of (_file, Just sha, Just _mode) -> (,) <$> isMissing sha r <*> pure i _ -> pure (False, i) @@ -446,7 +446,7 @@ preRepair g = do let f = indexFile g void $ tryIO $ allowWrite f where - headfile = localGitDir g "HEAD" + headfile = fromRawFilePath (localGitDir g) "HEAD" validhead s = "ref: refs/" `isPrefixOf` s || isJust (extractSha s) {- Put it all together. -} diff --git a/Git/Status.hs b/Git/Status.hs index c15a11bd63..8e50a69fc4 100644 --- a/Git/Status.hs +++ b/Git/Status.hs @@ -57,13 +57,13 @@ parseStatusZ = go [] in go (v : c) xs' _ -> go c xs - cparse 'M' f _ = (Just (Modified (asTopFilePath f)), Nothing) - cparse 'A' f _ = (Just (Added (asTopFilePath f)), Nothing) - cparse 'D' f _ = (Just (Deleted (asTopFilePath f)), Nothing) - cparse 'T' f _ = (Just (TypeChanged (asTopFilePath f)), Nothing) - cparse '?' f _ = (Just (Untracked (asTopFilePath f)), Nothing) + cparse 'M' f _ = (Just (Modified (asTopFilePath (toRawFilePath f))), Nothing) + cparse 'A' f _ = (Just (Added (asTopFilePath (toRawFilePath f))), Nothing) + cparse 'D' f _ = (Just (Deleted (asTopFilePath (toRawFilePath f))), Nothing) + cparse 'T' f _ = (Just (TypeChanged (asTopFilePath (toRawFilePath f))), Nothing) + cparse '?' f _ = (Just (Untracked (asTopFilePath (toRawFilePath f))), Nothing) cparse 'R' f (oldf:xs) = - (Just (Renamed (asTopFilePath oldf) (asTopFilePath f)), Just xs) + (Just (Renamed (asTopFilePath (toRawFilePath oldf)) (asTopFilePath (toRawFilePath f))), Just xs) cparse _ _ _ = (Nothing, Nothing) getStatus :: [CommandParam] -> [FilePath] -> Repo -> IO ([StagedUnstaged Status], IO Bool) diff --git a/Git/Tree.hs b/Git/Tree.hs index 8a69c53a2a..da05a3fa5d 100644 --- a/Git/Tree.hs +++ b/Git/Tree.hs @@ -119,7 +119,7 @@ mkTreeOutput fm ot s f = concat , " " , fromRef s , "\t" - , takeFileName (getTopFilePath f) + , takeFileName (fromRawFilePath (getTopFilePath f)) , "\NUL" ] @@ -156,7 +156,7 @@ treeItemsToTree = go M.empty Just (NewSubTree d l) -> go (addsubtree idir m (NewSubTree d (c:l))) is _ -> - go (addsubtree idir m (NewSubTree (asTopFilePath idir) [c])) is + go (addsubtree idir m (NewSubTree (asTopFilePath (toRawFilePath idir)) [c])) is where p = gitPath i idir = takeDirectory p @@ -169,7 +169,7 @@ treeItemsToTree = go M.empty Just (NewSubTree d' l) -> let l' = filter (\ti -> gitPath ti /= d) l in addsubtree parent m' (NewSubTree d' (t:l')) - _ -> addsubtree parent m' (NewSubTree (asTopFilePath parent) [t]) + _ -> addsubtree parent m' (NewSubTree (asTopFilePath (toRawFilePath parent)) [t]) | otherwise = M.insert d t m where parent = takeDirectory d @@ -328,7 +328,7 @@ graftTree' subtree graftloc basetree repo hdl = go basetree graftdirs -- For a graftloc of "foo/bar/baz", this generates -- ["foo", "foo/bar", "foo/bar/baz"] - graftdirs = map (asTopFilePath . decodeBS . toInternalGitPath . encodeBS) $ + graftdirs = map (asTopFilePath . toInternalGitPath . encodeBS) $ mkpaths [] $ splitDirectories $ gitPath graftloc mkpaths _ [] = [] mkpaths base (d:rest) = (joinPath base d) : mkpaths (base ++ [d]) rest @@ -366,7 +366,7 @@ instance GitPath FilePath where gitPath = id instance GitPath TopFilePath where - gitPath = getTopFilePath + gitPath = fromRawFilePath . getTopFilePath instance GitPath TreeItem where gitPath (TreeItem f _ _) = gitPath f diff --git a/Git/Types.hs b/Git/Types.hs index f15e334732..9c2754a7d3 100644 --- a/Git/Types.hs +++ b/Git/Types.hs @@ -30,8 +30,8 @@ import Utility.FileSystemEncoding - else known about it. -} data RepoLocation - = Local { gitdir :: FilePath, worktree :: Maybe FilePath } - | LocalUnknown FilePath + = Local { gitdir :: RawFilePath, worktree :: Maybe RawFilePath } + | LocalUnknown RawFilePath | Url URI | Unknown deriving (Show, Eq, Ord) diff --git a/Git/UnionMerge.hs b/Git/UnionMerge.hs index fc3c30e2ac..85d9687e4c 100644 --- a/Git/UnionMerge.hs +++ b/Git/UnionMerge.hs @@ -91,7 +91,7 @@ mergeFile info file hashhandle h = case filter (/= nullSha) [Ref asha, Ref bsha] where [_colonmode, _bmode, asha, bsha, _status] = words info use sha = return $ Just $ - updateIndexLine sha TreeFile $ asTopFilePath file + updateIndexLine sha TreeFile $ asTopFilePath $ toRawFilePath file -- Get file and split into lines to union merge. -- The encoding of the file is assumed to be either ASCII or utf-8; -- in either case it's safe to split on \n diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs index 76094a3432..9f07cf54ed 100644 --- a/Git/UpdateIndex.hs +++ b/Git/UpdateIndex.hs @@ -96,13 +96,13 @@ updateIndexLine sha treeitemtype file = L.fromStrict $ stageFile :: Sha -> TreeItemType -> FilePath -> Repo -> IO Streamer stageFile sha treeitemtype file repo = do - p <- toTopFilePath file repo + p <- toTopFilePath (toRawFilePath file) repo return $ pureStreamer $ updateIndexLine sha treeitemtype p {- A streamer that removes a file from the index. -} unstageFile :: FilePath -> Repo -> IO Streamer unstageFile file repo = do - p <- toTopFilePath file repo + p <- toTopFilePath (toRawFilePath file) repo return $ unstageFile' p unstageFile' :: TopFilePath -> Streamer @@ -118,7 +118,7 @@ stageSymlink file sha repo = do !line <- updateIndexLine <$> pure sha <*> pure TreeSymlink - <*> toTopFilePath file repo + <*> toTopFilePath (toRawFilePath file) repo return $ pureStreamer line {- A streamer that applies a DiffTreeItem to the index. -} @@ -128,7 +128,7 @@ stageDiffTreeItem d = case toTreeItemType (Diff.dstmode d) of Just t -> pureStreamer $ updateIndexLine (Diff.dstsha d) t (Diff.file d) indexPath :: TopFilePath -> InternalGitPath -indexPath = toInternalGitPath . toRawFilePath . getTopFilePath +indexPath = toInternalGitPath . getTopFilePath {- Refreshes the index, by checking file stat information. -} refreshIndex :: Repo -> ((FilePath -> IO ()) -> IO ()) -> IO Bool diff --git a/Limit.hs b/Limit.hs index 7511e39abc..9e8ece2d11 100644 --- a/Limit.hs +++ b/Limit.hs @@ -94,7 +94,7 @@ matchGlobFile :: String -> MatchInfo -> Annex Bool matchGlobFile glob = go where cglob = compileGlob glob CaseSensative -- memoized - go (MatchingFile fi) = pure $ matchGlob cglob (matchFile fi) + go (MatchingFile fi) = pure $ matchGlob cglob (fromRawFilePath (matchFile fi)) go (MatchingInfo p) = matchGlob cglob <$> getInfo (providedFilePath p) go (MatchingKey _ (AssociatedFile Nothing)) = pure False go (MatchingKey _ (AssociatedFile (Just af))) = pure $ matchGlob cglob (fromRawFilePath af) @@ -127,7 +127,7 @@ matchMagic _limitname querymagic selectprovidedinfo (Just magic) glob = Right $ go (MatchingKey _ _) = pure False go (MatchingFile fi) = catchBoolIO $ maybe False (matchGlob cglob) - <$> querymagic magic (currFile fi) + <$> querymagic magic (fromRawFilePath (currFile fi)) go (MatchingInfo p) = matchGlob cglob <$> getInfo (selectprovidedinfo p) matchMagic limitname _ _ Nothing _ = @@ -143,10 +143,10 @@ matchLockStatus :: Bool -> MatchInfo -> Annex Bool matchLockStatus _ (MatchingKey _ _) = pure False matchLockStatus _ (MatchingInfo _) = pure False matchLockStatus wantlocked (MatchingFile fi) = liftIO $ do - islocked <- isPointerFile (toRawFilePath (currFile fi)) >>= \case + islocked <- isPointerFile (currFile fi) >>= \case Just _key -> return False Nothing -> isSymbolicLink - <$> getSymbolicLinkStatus (currFile fi) + <$> getSymbolicLinkStatus (fromRawFilePath (currFile fi)) return (islocked == wantlocked) {- Adds a limit to skip files not believed to be present @@ -190,7 +190,7 @@ limitPresent u _ = checkKey $ \key -> do limitInDir :: FilePath -> MatchFiles Annex limitInDir dir = const go where - go (MatchingFile fi) = checkf $ matchFile fi + go (MatchingFile fi) = checkf $ fromRawFilePath $ matchFile fi go (MatchingKey _ (AssociatedFile Nothing)) = return False go (MatchingKey _ (AssociatedFile (Just af))) = checkf (fromRawFilePath af) go (MatchingInfo p) = checkf =<< getInfo (providedFilePath p) @@ -239,7 +239,8 @@ limitLackingCopies approx want = case readish want of NumCopies numcopies <- if approx then approxNumCopies else case mi of - MatchingFile fi -> getGlobalFileNumCopies $ matchFile fi + MatchingFile fi -> getGlobalFileNumCopies $ + fromRawFilePath $ matchFile fi MatchingKey _ _ -> approxNumCopies MatchingInfo {} -> approxNumCopies us <- filter (`S.notMember` notpresent) @@ -321,7 +322,8 @@ limitSize lb vs s = case readSize dataUnits s of Just key -> checkkey sz key Nothing -> return False LimitDiskFiles -> do - filesize <- liftIO $ catchMaybeIO $ getFileSize (currFile fi) + filesize <- liftIO $ catchMaybeIO $ + getFileSize (fromRawFilePath (currFile fi)) return $ filesize `vs` Just sz go sz _ (MatchingKey key _) = checkkey sz key go sz _ (MatchingInfo p) = @@ -368,7 +370,7 @@ addAccessedWithin duration = do secs = fromIntegral (durationSeconds duration) lookupFileKey :: FileInfo -> Annex (Maybe Key) -lookupFileKey = lookupFile . toRawFilePath . currFile +lookupFileKey = lookupFile . currFile checkKey :: (Key -> Annex Bool) -> MatchInfo -> Annex Bool checkKey a (MatchingFile fi) = lookupFileKey fi >>= maybe (return False) a diff --git a/Limit/Wanted.hs b/Limit/Wanted.hs index 668614ce28..adbcafbfba 100644 --- a/Limit/Wanted.hs +++ b/Limit/Wanted.hs @@ -21,6 +21,6 @@ addWantDrop = addLimit $ Right $ const $ checkWant $ wantDrop False Nothing Nothing checkWant :: (AssociatedFile -> Annex Bool) -> MatchInfo -> Annex Bool -checkWant a (MatchingFile fi) = a (AssociatedFile (Just $ toRawFilePath $ matchFile fi)) +checkWant a (MatchingFile fi) = a (AssociatedFile (Just $ matchFile fi)) checkWant a (MatchingKey _ af) = a af checkWant _ (MatchingInfo {}) = return False diff --git a/Logs/Export.hs b/Logs/Export.hs index fd2ebfe504..aadd1b9c4a 100644 --- a/Logs/Export.hs +++ b/Logs/Export.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Logs.Export ( Exported, mkExported, diff --git a/Logs/Smudge.hs b/Logs/Smudge.hs index 5586a357d9..005806edec 100644 --- a/Logs/Smudge.hs +++ b/Logs/Smudge.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Logs.Smudge where import Annex.Common @@ -15,8 +17,8 @@ import Logs.File smudgeLog :: Key -> TopFilePath -> Annex () smudgeLog k f = do logf <- fromRepo gitAnnexSmudgeLog - appendLogFile logf gitAnnexSmudgeLock $ - serializeKey k ++ " " ++ getTopFilePath f + appendLogFile logf gitAnnexSmudgeLock $ fromRawFilePath $ + serializeKey' k <> " " <> getTopFilePath f -- | Streams all smudged files, and then empties the log at the end. -- @@ -37,4 +39,4 @@ streamSmudged a = do let (ks, f) = separate (== ' ') l in do k <- deserializeKey ks - return (k, asTopFilePath f) + return (k, asTopFilePath (toRawFilePath f)) diff --git a/Logs/Web.hs b/Logs/Web.hs index a59ea99205..b057a6580e 100644 --- a/Logs/Web.hs +++ b/Logs/Web.hs @@ -93,7 +93,7 @@ knownUrls = do Annex.Branch.update Annex.Branch.commit =<< Annex.Branch.commitMessage Annex.Branch.withIndex $ do - top <- toRawFilePath <$> fromRepo Git.repoPath + top <- fromRepo Git.repoPath (l, cleanup) <- inRepo $ Git.LsFiles.stagedDetails [top] r <- mapM getkeyurls l void $ liftIO cleanup diff --git a/P2P/IO.hs b/P2P/IO.hs index b079f8de84..3503386a8b 100644 --- a/P2P/IO.hs +++ b/P2P/IO.hs @@ -293,7 +293,7 @@ runRelayService conn runner service = serviceproc = gitCreateProcess [ Param cmd - , File (repoPath (connRepo conn)) + , File (fromRawFilePath (repoPath (connRepo conn))) ] (connRepo conn) setup = do diff --git a/Remote/Bup.hs b/Remote/Bup.hs index 8fa00cbc41..b1ba5f1870 100644 --- a/Remote/Bup.hs +++ b/Remote/Bup.hs @@ -230,7 +230,7 @@ onBupRemote r runner command params = do (sshcmd, sshparams) <- Ssh.toRepo NoConsumeStdin r c remotecmd liftIO $ runner sshcmd sshparams where - path = Git.repoPath r + path = fromRawFilePath $ Git.repoPath r base = fromMaybe path (stripPrefix "/~/" path) dir = shellEscape base diff --git a/Remote/External.hs b/Remote/External.hs index c172bc71cd..2b5c99457a 100644 --- a/Remote/External.hs +++ b/Remote/External.hs @@ -409,7 +409,8 @@ handleRequest' st external req mp responsehandler send $ CREDS (fst creds) (snd creds) handleRemoteRequest GETUUID = send $ VALUE $ fromUUID $ externalUUID external - handleRemoteRequest GETGITDIR = send . VALUE =<< fromRepo Git.localGitDir + handleRemoteRequest GETGITDIR = + send . VALUE . fromRawFilePath =<< fromRepo Git.localGitDir handleRemoteRequest (SETWANTED expr) = preferredContentSet (externalUUID external) expr handleRemoteRequest GETWANTED = do diff --git a/Remote/Git.hs b/Remote/Git.hs index 7dc85aa629..459cd80d65 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -680,8 +680,8 @@ fsckOnRemote r params r' <- Git.Config.read r environ <- getEnvironment let environ' = addEntries - [ ("GIT_WORK_TREE", Git.repoPath r') - , ("GIT_DIR", Git.localGitDir r') + [ ("GIT_WORK_TREE", fromRawFilePath $ Git.repoPath r') + , ("GIT_DIR", fromRawFilePath $ Git.localGitDir r') ] environ batchCommandEnv program (Param "fsck" : params) (Just environ') diff --git a/Remote/Helper/Git.hs b/Remote/Helper/Git.hs index 71a4bbc74d..5fd7ea1e2a 100644 --- a/Remote/Helper/Git.hs +++ b/Remote/Helper/Git.hs @@ -20,7 +20,7 @@ repoCheap = not . Git.repoIsUrl localpathCalc :: Git.Repo -> Maybe FilePath localpathCalc r | availabilityCalc r == GloballyAvailable = Nothing - | otherwise = Just $ Git.repoPath r + | otherwise = Just $ fromRawFilePath $ Git.repoPath r availabilityCalc :: Git.Repo -> Availability availabilityCalc r @@ -36,7 +36,7 @@ guardUsable r fallback a gitRepoInfo :: Remote -> Annex [(String, String)] gitRepoInfo r = do - d <- fromRepo Git.localGitDir + d <- fromRawFilePath <$> fromRepo Git.localGitDir mtimes <- liftIO $ mapM (modificationTime <$$> getFileStatus) =<< dirContentsRecursive (d "refs" "remotes" Remote.name r) let lastsynctime = case mtimes of diff --git a/Remote/Helper/Ssh.hs b/Remote/Helper/Ssh.hs index ae4a680d9a..185ad4e34d 100644 --- a/Remote/Helper/Ssh.hs +++ b/Remote/Helper/Ssh.hs @@ -65,7 +65,7 @@ git_annex_shell cs r command params fields let params' = if debug then Param "--debug" : params else params - return (Param command : File dir : params') + return (Param command : File (fromRawFilePath dir) : params') uuidcheck NoUUID = [] uuidcheck u@(UUID _) = ["--uuid", fromUUID u] fieldopts diff --git a/Types/FileMatcher.hs b/Types/FileMatcher.hs index d0e24ba37d..114f96774f 100644 --- a/Types/FileMatcher.hs +++ b/Types/FileMatcher.hs @@ -12,6 +12,7 @@ import Types.Key (Key, AssociatedFile) import Types.Mime import Utility.Matcher (Matcher, Token) import Utility.FileSize +import Utility.FileSystemEncoding import Control.Monad.IO.Class import qualified Data.Map as M @@ -24,9 +25,9 @@ data MatchInfo | MatchingInfo ProvidedInfo data FileInfo = FileInfo - { currFile :: FilePath + { currFile :: RawFilePath -- ^ current path to the file, for operations that examine it - , matchFile :: FilePath + , matchFile :: RawFilePath -- ^ filepath to match on; may be relative to top of repo or cwd } diff --git a/Upgrade.hs b/Upgrade.hs index 457fab180b..d98203979d 100644 --- a/Upgrade.hs +++ b/Upgrade.hs @@ -48,7 +48,7 @@ needsUpgrade v where err msg = do g <- Annex.gitRepo - p <- liftIO $ absPath $ Git.repoPath g + p <- liftIO $ absPath $ fromRawFilePath $ Git.repoPath g return $ Just $ unwords [ "Repository", p , "is at unsupported version" diff --git a/Upgrade/V1.hs b/Upgrade/V1.hs index fd46108dd5..bad1183dfd 100644 --- a/Upgrade/V1.hs +++ b/Upgrade/V1.hs @@ -84,7 +84,7 @@ updateSymlinks :: Annex () updateSymlinks = do showAction "updating symlinks" top <- fromRepo Git.repoPath - (files, cleanup) <- inRepo $ LsFiles.inRepo [toRawFilePath top] + (files, cleanup) <- inRepo $ LsFiles.inRepo [top] forM_ files (fixlink . fromRawFilePath) void $ liftIO cleanup where @@ -244,4 +244,5 @@ stateDir :: FilePath stateDir = addTrailingPathSeparator ".git-annex" gitStateDir :: Git.Repo -> FilePath -gitStateDir repo = addTrailingPathSeparator $ Git.repoPath repo stateDir +gitStateDir repo = addTrailingPathSeparator $ + fromRawFilePath (Git.repoPath repo) stateDir diff --git a/Upgrade/V2.hs b/Upgrade/V2.hs index 9b29783e9d..e255403d58 100644 --- a/Upgrade/V2.hs +++ b/Upgrade/V2.hs @@ -139,5 +139,7 @@ gitAttributesUnWrite repo = do stateDir :: FilePath stateDir = addTrailingPathSeparator ".git-annex" + gitStateDir :: Git.Repo -> FilePath -gitStateDir repo = addTrailingPathSeparator $ Git.repoPath repo stateDir +gitStateDir repo = addTrailingPathSeparator $ + fromRawFilePath (Git.repoPath repo) stateDir diff --git a/Upgrade/V5.hs b/Upgrade/V5.hs index ba897399f2..7cbdd04e65 100644 --- a/Upgrade/V5.hs +++ b/Upgrade/V5.hs @@ -108,7 +108,7 @@ convertDirect = do upgradeDirectWorkTree :: Annex () upgradeDirectWorkTree = do top <- fromRepo Git.repoPath - (l, clean) <- inRepo $ Git.LsFiles.stagedDetails [toRawFilePath top] + (l, clean) <- inRepo $ Git.LsFiles.stagedDetails [top] forM_ l go void $ liftIO clean where @@ -125,7 +125,7 @@ upgradeDirectWorkTree = do , fromdirect (fromRawFilePath f) k ) Database.Keys.addAssociatedFile k - =<< inRepo (toTopFilePath (fromRawFilePath f)) + =<< inRepo (toTopFilePath f) go _ = noop fromdirect f k = ifM (Direct.goodContent k f) diff --git a/Upgrade/V5/Direct.hs b/Upgrade/V5/Direct.hs index 3f67959976..baf7dae9a0 100644 --- a/Upgrade/V5/Direct.hs +++ b/Upgrade/V5/Direct.hs @@ -81,7 +81,7 @@ switchHEADBack = maybe noop switch =<< inRepo Git.Branch.currentUnsafe associatedFiles :: Key -> Annex [FilePath] associatedFiles key = do files <- associatedFilesRelative key - top <- fromRepo Git.repoPath + top <- fromRawFilePath <$> fromRepo Git.repoPath return $ map (top ) files {- List of files in the tree that are associated with a key, relative to diff --git a/git-annex.cabal b/git-annex.cabal index fa75218993..d18151368f 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -320,6 +320,7 @@ Executable git-annex directory (>= 1.2), disk-free-space, filepath, + filepath-bytestring, IfElse, hslogger, monad-logger, From c19211774f509f2b0334073b599295538871a00f Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 11 Dec 2019 14:12:22 -0400 Subject: [PATCH 28/42] use filepath-bytestring for annex object manipulations git-annex find is now RawFilePath end to end, no string conversions. So is git-annex get when it does not need to get anything. So this is a major milestone on optimisation. Benchmarks indicate around 30% speedup in both commands. Probably many other performance improvements. All or nearly all places where a file is statted use RawFilePath now. --- Annex/AutoMerge.hs | 5 +- Annex/Branch.hs | 2 +- Annex/Content.hs | 66 +++++++++++-------- Annex/Content/PointerFile.hs | 7 +- Annex/DirHashes.hs | 32 +++++---- Annex/Ingest.hs | 13 ++-- Annex/InodeSentinal.hs | 4 +- Annex/Journal.hs | 30 +++++---- Annex/Link.hs | 8 +-- Annex/Locations.hs | 64 +++++++++++------- Annex/WorkTree.hs | 7 +- Assistant/Threads/Committer.hs | 2 +- Assistant/Upgrade.hs | 2 +- CHANGELOG | 12 ++-- CmdLine/Seek.hs | 2 +- Command/ContentLocation.hs | 7 +- Command/DiffDriver.hs | 3 +- Command/Find.hs | 4 +- Command/Fix.hs | 15 +++-- Command/Fsck.hs | 18 ++--- Command/Import.hs | 2 +- Command/Lock.hs | 24 +++---- Command/Migrate.hs | 2 +- Command/Multicast.hs | 3 +- Command/ReKey.hs | 6 +- Command/Smudge.hs | 8 +-- Command/TestRemote.hs | 6 +- Command/Unannex.hs | 2 +- Command/Uninit.hs | 3 +- Command/Unused.hs | 2 +- Database/Keys.hs | 12 ++-- Limit.hs | 6 +- Logs.hs | 25 +++---- P2P/Annex.hs | 2 +- Remote/Adb.hs | 2 +- Remote/Directory.hs | 5 +- Remote/External.hs | 4 +- Remote/GCrypt.hs | 3 +- Remote/Git.hs | 9 +-- Remote/Hook.hs | 3 +- Remote/Rsync.hs | 4 +- Remote/Rsync/RsyncUrl.hs | 11 ++-- Remote/WebDAV/DavLocation.hs | 4 +- Test.hs | 3 +- Upgrade/V1.hs | 4 +- Upgrade/V5.hs | 2 +- Upgrade/V5/Direct.hs | 4 +- Utility/InodeCache.hs | 19 ++---- Utility/MD5.hs | 5 +- Utility/RawFilePath.hs | 9 +++ ...ze_by_converting_String_to_ByteString.mdwn | 20 +----- ..._5cad0557a1409703f8c71078f0785309._comment | 40 +++++++++++ stack.yaml | 1 + 53 files changed, 324 insertions(+), 234 deletions(-) create mode 100644 doc/todo/optimize_by_converting_String_to_ByteString/comment_3_5cad0557a1409703f8c71078f0785309._comment diff --git a/Annex/AutoMerge.hs b/Annex/AutoMerge.hs index d558c94c60..c2990eabf2 100644 --- a/Annex/AutoMerge.hs +++ b/Annex/AutoMerge.hs @@ -334,10 +334,9 @@ inodeMap :: Annex ([RawFilePath], IO Bool) -> Annex InodeMap inodeMap getfiles = do (fs, cleanup) <- getfiles fsis <- forM fs $ \f -> do - let f' = fromRawFilePath f - mi <- withTSDelta (liftIO . genInodeCache f') + mi <- withTSDelta (liftIO . genInodeCache f) return $ case mi of Nothing -> Nothing - Just i -> Just (inodeCacheToKey Strongly i, f') + Just i -> Just (inodeCacheToKey Strongly i, fromRawFilePath f) void $ liftIO cleanup return $ M.fromList $ catMaybes fsis diff --git a/Annex/Branch.hs b/Annex/Branch.hs index 10fa59abc4..6934e62bab 100644 --- a/Annex/Branch.hs +++ b/Annex/Branch.hs @@ -482,7 +482,7 @@ stageJournal jl commitindex = withIndex $ withOtherTmp $ \tmpdir -> do sha <- Git.HashObject.hashFile h path hPutStrLn jlogh file streamer $ Git.UpdateIndex.updateIndexLine - sha TreeFile (asTopFilePath $ toRawFilePath $ fileJournal file) + sha TreeFile (asTopFilePath $ fileJournal $ toRawFilePath file) genstream dir h jh jlogh streamer -- Clean up the staged files, as listed in the temp log file. -- The temp file is used to avoid needing to buffer all the diff --git a/Annex/Content.hs b/Annex/Content.hs index c109e3f1f8..74dd17886e 100644 --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -89,17 +89,18 @@ import Annex.Content.LowLevel import Annex.Content.PointerFile import Annex.Concurrent import Types.WorkerPool +import qualified Utility.RawFilePath as R {- Checks if a given key's content is currently present. -} inAnnex :: Key -> Annex Bool -inAnnex key = inAnnexCheck key $ liftIO . doesFileExist +inAnnex key = inAnnexCheck key $ liftIO . R.doesPathExist {- Runs an arbitrary check on a key's content. -} -inAnnexCheck :: Key -> (FilePath -> Annex Bool) -> Annex Bool +inAnnexCheck :: Key -> (RawFilePath -> Annex Bool) -> Annex Bool inAnnexCheck key check = inAnnex' id False check key {- inAnnex that performs an arbitrary check of the key's content. -} -inAnnex' :: (a -> Bool) -> a -> (FilePath -> Annex a) -> Key -> Annex a +inAnnex' :: (a -> Bool) -> a -> (RawFilePath -> Annex a) -> Key -> Annex a inAnnex' isgood bad check key = withObjectLoc key $ \loc -> do r <- check loc if isgood r @@ -120,12 +121,15 @@ inAnnex' isgood bad check key = withObjectLoc key $ \loc -> do {- Like inAnnex, checks if the object file for a key exists, - but there are no guarantees it has the right content. -} objectFileExists :: Key -> Annex Bool -objectFileExists key = calcRepo (gitAnnexLocation key) >>= liftIO . doesFileExist +objectFileExists key = + calcRepo (gitAnnexLocation key) + >>= liftIO . R.doesPathExist {- A safer check; the key's content must not only be present, but - is not in the process of being removed. -} inAnnexSafe :: Key -> Annex (Maybe Bool) -inAnnexSafe key = inAnnex' (fromMaybe True) (Just False) go key +inAnnexSafe key = + inAnnex' (fromMaybe True) (Just False) (go . fromRawFilePath) key where is_locked = Nothing is_unlocked = Just True @@ -246,7 +250,7 @@ winLocker _ _ Nothing = return Nothing lockContentUsing :: ContentLocker -> Key -> Annex a -> Annex a lockContentUsing locker key a = do - contentfile <- calcRepo $ gitAnnexLocation key + contentfile <- fromRawFilePath <$> calcRepo (gitAnnexLocation key) lockfile <- contentLockFile key bracket (lock contentfile lockfile) @@ -474,18 +478,20 @@ moveAnnex key src = ifM (checkSecureHashes key) , return False ) where - storeobject dest = ifM (liftIO $ doesFileExist dest) + storeobject dest = ifM (liftIO $ R.doesPathExist dest) ( alreadyhave - , modifyContent dest $ do + , modifyContent dest' $ do freezeContent src - liftIO $ moveFile src dest + liftIO $ moveFile src dest' g <- Annex.gitRepo fs <- map (`fromTopFilePath` g) <$> Database.Keys.getAssociatedFiles key unless (null fs) $ do - ics <- mapM (populatePointerFile (Restage True) key (toRawFilePath dest)) fs + ics <- mapM (populatePointerFile (Restage True) key dest) fs Database.Keys.storeInodeCaches' key [dest] (catMaybes ics) ) + where + dest' = fromRawFilePath dest alreadyhave = liftIO $ removeFile src checkSecureHashes :: Key -> Annex Bool @@ -505,7 +511,7 @@ data LinkAnnexResult = LinkAnnexOk | LinkAnnexFailed | LinkAnnexNoop linkToAnnex :: Key -> FilePath -> Maybe InodeCache -> Annex LinkAnnexResult linkToAnnex key src srcic = ifM (checkSecureHashes key) ( do - dest <- calcRepo (gitAnnexLocation key) + dest <- fromRawFilePath <$> calcRepo (gitAnnexLocation key) modifyContent dest $ linkAnnex To key src srcic dest Nothing , return LinkAnnexFailed ) @@ -515,7 +521,7 @@ linkFromAnnex :: Key -> FilePath -> Maybe FileMode -> Annex LinkAnnexResult linkFromAnnex key dest destmode = do src <- calcRepo (gitAnnexLocation key) srcic <- withTSDelta (liftIO . genInodeCache src) - linkAnnex From key src srcic dest destmode + linkAnnex From key (fromRawFilePath src) srcic dest destmode data FromTo = From | To @@ -534,7 +540,7 @@ data FromTo = From | To linkAnnex :: FromTo -> Key -> FilePath -> Maybe InodeCache -> FilePath -> Maybe FileMode -> Annex LinkAnnexResult linkAnnex _ _ _ Nothing _ _ = return LinkAnnexFailed linkAnnex fromto key src (Just srcic) dest destmode = - withTSDelta (liftIO . genInodeCache dest) >>= \case + withTSDelta (liftIO . genInodeCache dest') >>= \case Just destic -> do cs <- Database.Keys.getInodeCaches key if null cs @@ -551,12 +557,13 @@ linkAnnex fromto key src (Just srcic) dest destmode = Linked -> noop checksrcunchanged where + dest' = toRawFilePath dest failed = do Database.Keys.addInodeCaches key [srcic] return LinkAnnexFailed - checksrcunchanged = withTSDelta (liftIO . genInodeCache src) >>= \case + checksrcunchanged = withTSDelta (liftIO . genInodeCache (toRawFilePath src)) >>= \case Just srcic' | compareStrong srcic srcic' -> do - destic <- withTSDelta (liftIO . genInodeCache dest) + destic <- withTSDelta (liftIO . genInodeCache dest') Database.Keys.addInodeCaches key $ catMaybes [destic, Just srcic] return LinkAnnexOk @@ -567,7 +574,7 @@ linkAnnex fromto key src (Just srcic) dest destmode = {- Removes the annex object file for a key. Lowlevel. -} unlinkAnnex :: Key -> Annex () unlinkAnnex key = do - obj <- calcRepo $ gitAnnexLocation key + obj <- fromRawFilePath <$> calcRepo (gitAnnexLocation key) modifyContent obj $ do secureErase obj liftIO $ nukeFile obj @@ -616,15 +623,15 @@ prepSendAnnex key = withObjectLoc key $ \f -> do else pure cache return $ if null cache' then Nothing - else Just (f, sameInodeCache f cache') + else Just (fromRawFilePath f, sameInodeCache f cache') {- Performs an action, passing it the location to use for a key's content. -} -withObjectLoc :: Key -> (FilePath -> Annex a) -> Annex a +withObjectLoc :: Key -> (RawFilePath -> Annex a) -> Annex a withObjectLoc key a = a =<< calcRepo (gitAnnexLocation key) cleanObjectLoc :: Key -> Annex () -> Annex () cleanObjectLoc key cleaner = do - file <- calcRepo $ gitAnnexLocation key + file <- fromRawFilePath <$> calcRepo (gitAnnexLocation key) void $ tryIO $ thawContentDir file cleaner liftIO $ removeparents file (3 :: Int) @@ -640,22 +647,23 @@ cleanObjectLoc key cleaner = do removeAnnex :: ContentRemovalLock -> Annex () removeAnnex (ContentRemovalLock key) = withObjectLoc key $ \file -> cleanObjectLoc key $ do - secureErase file - liftIO $ nukeFile file + let file' = fromRawFilePath file + secureErase file' + liftIO $ nukeFile file' g <- Annex.gitRepo - mapM_ (\f -> void $ tryIO $ resetpointer $ fromRawFilePath $ fromTopFilePath f g) + mapM_ (\f -> void $ tryIO $ resetpointer $ fromTopFilePath f g) =<< Database.Keys.getAssociatedFiles key Database.Keys.removeInodeCaches key where -- Check associated pointer file for modifications, and reset if -- it's unmodified. resetpointer file = ifM (isUnmodified key file) - ( depopulatePointerFile key (toRawFilePath file) + ( depopulatePointerFile key file -- Modified file, so leave it alone. -- If it was a hard link to the annex object, -- that object might have been frozen as part of the -- removal process, so thaw it. - , void $ tryIO $ thawContent file + , void $ tryIO $ thawContent $ fromRawFilePath file ) {- Check if a file contains the unmodified content of the key. @@ -663,12 +671,12 @@ removeAnnex (ContentRemovalLock key) = withObjectLoc key $ \file -> - The expensive way to tell is to do a verification of its content. - The cheaper way is to see if the InodeCache for the key matches the - file. -} -isUnmodified :: Key -> FilePath -> Annex Bool +isUnmodified :: Key -> RawFilePath -> Annex Bool isUnmodified key f = go =<< geti where go Nothing = return False go (Just fc) = isUnmodifiedCheap' key fc <||> expensivecheck fc - expensivecheck fc = ifM (verifyKeyContent RetrievalAllKeysSecure AlwaysVerify UnVerified key f) + expensivecheck fc = ifM (verifyKeyContent RetrievalAllKeysSecure AlwaysVerify UnVerified key (fromRawFilePath f)) ( do -- The file could have been modified while it was -- being verified. Detect that. @@ -691,7 +699,7 @@ isUnmodified key f = go =<< geti - this may report a false positive when repeated edits are made to a file - within a small time window (eg 1 second). -} -isUnmodifiedCheap :: Key -> FilePath -> Annex Bool +isUnmodifiedCheap :: Key -> RawFilePath -> Annex Bool isUnmodifiedCheap key f = maybe (return False) (isUnmodifiedCheap' key) =<< withTSDelta (liftIO . genInodeCache f) @@ -703,7 +711,7 @@ isUnmodifiedCheap' key fc = - returns the file it was moved to. -} moveBad :: Key -> Annex FilePath moveBad key = do - src <- calcRepo $ gitAnnexLocation key + src <- fromRawFilePath <$> calcRepo (gitAnnexLocation key) bad <- fromRepo gitAnnexBadDir let dest = bad takeFileName src createAnnexDirectory (parentDir dest) @@ -791,7 +799,7 @@ preseedTmp key file = go =<< inAnnex key copy = ifM (liftIO $ doesFileExist file) ( return True , do - s <- calcRepo $ gitAnnexLocation key + s <- fromRawFilePath <$> (calcRepo $ gitAnnexLocation key) liftIO $ ifM (doesFileExist s) ( copyFileExternal CopyTimeStamps s file , return False diff --git a/Annex/Content/PointerFile.hs b/Annex/Content/PointerFile.hs index 59825a9d70..997f731ca6 100644 --- a/Annex/Content/PointerFile.hs +++ b/Annex/Content/PointerFile.hs @@ -38,10 +38,11 @@ populatePointerFile restage k obj f = go =<< liftIO (isPointerFile f) destmode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus f' liftIO $ nukeFile f' (ic, populated) <- replaceFile f' $ \tmp -> do + let tmp' = toRawFilePath tmp ok <- linkOrCopy k (fromRawFilePath obj) tmp destmode >>= \case Just _ -> thawContent tmp >> return True - Nothing -> liftIO (writePointerFile (toRawFilePath tmp) k destmode) >> return False - ic <- withTSDelta (liftIO . genInodeCache tmp) + Nothing -> liftIO (writePointerFile tmp' k destmode) >> return False + ic <- withTSDelta (liftIO . genInodeCache tmp') return (ic, ok) maybe noop (restagePointerFile restage f) ic if populated @@ -68,5 +69,5 @@ depopulatePointerFile key file = do (\t -> touch tmp t False) (fmap modificationTimeHiRes st) #endif - withTSDelta (liftIO . genInodeCache tmp) + withTSDelta (liftIO . genInodeCache (toRawFilePath tmp)) maybe noop (restagePointerFile (Restage True) file) ic diff --git a/Annex/DirHashes.hs b/Annex/DirHashes.hs index 1fb0073826..237345feb1 100644 --- a/Annex/DirHashes.hs +++ b/Annex/DirHashes.hs @@ -1,6 +1,6 @@ {- git-annex file locations - - - Copyright 2010-2017 Joey Hess + - Copyright 2010-2019 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -19,7 +19,10 @@ module Annex.DirHashes ( import Data.Default import Data.Bits -import qualified Data.ByteArray +import qualified Data.ByteArray as BA +import qualified Data.ByteArray.Encoding as BA +import qualified Data.ByteString as S +import qualified System.FilePath.ByteString as P import Common import Key @@ -28,7 +31,7 @@ import Types.Difference import Utility.Hash import Utility.MD5 -type Hasher = Key -> FilePath +type Hasher = Key -> RawFilePath -- Number of hash levels to use. 2 is the default. newtype HashLevels = HashLevels Int @@ -47,7 +50,7 @@ configHashLevels d config | hasDifference d (annexDifferences config) = HashLevels 1 | otherwise = def -branchHashDir :: GitConfig -> Key -> String +branchHashDir :: GitConfig -> Key -> S.ByteString branchHashDir = hashDirLower . branchHashLevels {- Two different directory hashes may be used. The mixed case hash @@ -60,19 +63,26 @@ branchHashDir = hashDirLower . branchHashLevels dirHashes :: [HashLevels -> Hasher] dirHashes = [hashDirLower, hashDirMixed] -hashDirs :: HashLevels -> Int -> String -> FilePath -hashDirs (HashLevels 1) sz s = addTrailingPathSeparator $ take sz s -hashDirs _ sz s = addTrailingPathSeparator $ take sz s drop sz s +hashDirs :: HashLevels -> Int -> S.ByteString -> RawFilePath +hashDirs (HashLevels 1) sz s = P.addTrailingPathSeparator $ S.take sz s +hashDirs _ sz s = P.addTrailingPathSeparator $ h P. t + where + (h, t) = S.splitAt sz s hashDirLower :: HashLevels -> Hasher -hashDirLower n k = hashDirs n 3 $ take 6 $ show $ md5s $ serializeKey' $ nonChunkKey k +hashDirLower n k = hashDirs n 3 $ S.pack $ take 6 $ conv $ + md5s $ serializeKey' $ nonChunkKey k + where + conv v = BA.unpack $ + (BA.convertToBase BA.Base16 v :: BA.Bytes) {- This was originally using Data.Hash.MD5 from MissingH. This new version - is faster, but ugly as it has to replicate the 4 Word32's that produced. -} hashDirMixed :: HashLevels -> Hasher -hashDirMixed n k = hashDirs n 2 $ take 4 $ concatMap display_32bits_as_dir $ - encodeWord32 $ map fromIntegral $ Data.ByteArray.unpack $ - Utility.Hash.md5s $ serializeKey' $ nonChunkKey k +hashDirMixed n k = hashDirs n 2 $ S.pack $ take 4 $ + concatMap display_32bits_as_dir $ + encodeWord32 $ map fromIntegral $ BA.unpack $ + Utility.Hash.md5s $ serializeKey' $ nonChunkKey k where encodeWord32 (b1:b2:b3:b4:rest) = (shiftL b4 24 .|. shiftL b3 16 .|. shiftL b2 8 .|. b1) diff --git a/Annex/Ingest.hs b/Annex/Ingest.hs index 85a4d38122..e1b22c7b8a 100644 --- a/Annex/Ingest.hs +++ b/Annex/Ingest.hs @@ -92,7 +92,7 @@ lockDown' cfg file = tryIO $ ifM crippledFileSystem nohardlink = withTSDelta $ liftIO . nohardlink' nohardlink' delta = do - cache <- genInodeCache file delta + cache <- genInodeCache (toRawFilePath file) delta return $ LockedDown cfg $ KeySource { keyFilename = file , contentLocation = file @@ -112,7 +112,7 @@ lockDown' cfg file = tryIO $ ifM crippledFileSystem withhardlink' delta tmpfile = do createLink file tmpfile - cache <- genInodeCache tmpfile delta + cache <- genInodeCache (toRawFilePath tmpfile) delta return $ LockedDown cfg $ KeySource { keyFilename = file , contentLocation = tmpfile @@ -209,7 +209,7 @@ 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 <- toRawFilePath <$> calcRepo (gitAnnexLocation key) + obj <- calcRepo (gitAnnexLocation key) g <- Annex.gitRepo ingestedf <- flip fromTopFilePath g <$> inRepo (toTopFilePath (toRawFilePath (keyFilename source))) @@ -235,8 +235,7 @@ cleanOldKeys file newkey = do unlessM (isUnmodified key =<< calcRepo (gitAnnexLocation key)) $ do caches <- Database.Keys.getInodeCaches key unlinkAnnex key - fs <- map fromRawFilePath - . filter (/= ingestedf) + fs <- filter (/= ingestedf) . map (`fromTopFilePath` g) <$> Database.Keys.getAssociatedFiles key filterM (`sameInodeCache` caches) fs >>= \case @@ -245,7 +244,7 @@ cleanOldKeys file newkey = do -- so no need for any recovery. (f:_) -> do ic <- withTSDelta (liftIO . genInodeCache f) - void $ linkToAnnex key f ic + void $ linkToAnnex key (fromRawFilePath f) ic _ -> logStatus key InfoMissing {- On error, put the file back so it doesn't seem to have vanished. @@ -256,7 +255,7 @@ restoreFile file key e = do liftIO $ nukeFile file -- The key could be used by other files too, so leave the -- content in the annex, and make a copy back to the file. - obj <- calcRepo $ gitAnnexLocation key + obj <- fromRawFilePath <$> calcRepo (gitAnnexLocation key) unlessM (liftIO $ copyFileExternal CopyTimeStamps obj file) $ warning $ "Unable to restore content of " ++ file ++ "; it should be located in " ++ obj thawContent file diff --git a/Annex/InodeSentinal.hs b/Annex/InodeSentinal.hs index 0f5c7ca606..0dae0d6cac 100644 --- a/Annex/InodeSentinal.hs +++ b/Annex/InodeSentinal.hs @@ -29,7 +29,7 @@ compareInodeCachesWith = ifM inodesChanged ( return Weakly, return Strongly ) {- Checks if one of the provided old InodeCache matches the current - version of a file. -} -sameInodeCache :: FilePath -> [InodeCache] -> Annex Bool +sameInodeCache :: RawFilePath -> [InodeCache] -> Annex Bool sameInodeCache _ [] = return False sameInodeCache file old = go =<< withTSDelta (liftIO . genInodeCache file) where @@ -78,7 +78,7 @@ createInodeSentinalFile :: Bool -> Annex () createInodeSentinalFile evenwithobjects = unlessM (alreadyexists <||> hasobjects) $ do s <- annexSentinalFile - createAnnexDirectory (parentDir (sentinalFile s)) + createAnnexDirectory (parentDir (fromRawFilePath (sentinalFile s))) liftIO $ writeSentinalFile s where alreadyexists = liftIO. sentinalFileExists =<< annexSentinalFile diff --git a/Annex/Journal.hs b/Annex/Journal.hs index e7e624f354..937e183e22 100644 --- a/Annex/Journal.hs +++ b/Annex/Journal.hs @@ -20,7 +20,9 @@ import Utility.Directory.Stream import qualified Data.ByteString.Lazy as L import qualified Data.ByteString as S +import qualified System.FilePath.ByteString as P import Data.ByteString.Builder +import Data.Char class Journalable t where writeJournalHandle :: Handle -> t -> IO () @@ -48,7 +50,7 @@ setJournalFile :: Journalable content => JournalLocked -> RawFilePath -> content setJournalFile _jl file content = withOtherTmp $ \tmp -> do createAnnexDirectory =<< fromRepo gitAnnexJournalDir -- journal file is written atomically - jfile <- fromRepo $ journalFile $ fromRawFilePath file + jfile <- fromRawFilePath <$> fromRepo (journalFile file) let tmpfile = tmp takeFileName jfile liftIO $ do withFile tmpfile WriteMode $ \h -> writeJournalHandle h content @@ -71,7 +73,7 @@ getJournalFile _jl = getJournalFileStale -} getJournalFileStale :: RawFilePath -> Annex (Maybe L.ByteString) getJournalFileStale file = inRepo $ \g -> catchMaybeIO $ - L.fromStrict <$> S.readFile (journalFile (fromRawFilePath file) g) + L.fromStrict <$> S.readFile (fromRawFilePath $ journalFile file g) {- List of existing journal files, but without locking, may miss new ones - just being added, or may have false positives if the journal is staged @@ -81,7 +83,8 @@ getJournalledFilesStale = do g <- gitRepo fs <- liftIO $ catchDefaultIO [] $ getDirectoryContents $ gitAnnexJournalDir g - return $ filter (`notElem` [".", ".."]) $ map fileJournal fs + return $ filter (`notElem` [".", ".."]) $ + map (fromRawFilePath . fileJournal . toRawFilePath) fs withJournalHandle :: (DirectoryHandle -> IO a) -> Annex a withJournalHandle a = do @@ -97,24 +100,29 @@ journalDirty = do `catchIO` (const $ doesDirectoryExist d) {- Produces a filename to use in the journal for a file on the branch. + - + - The input filename is assumed to not contain any '_' character, + - since path separators are replaced with that. - - The journal typically won't have a lot of files in it, so the hashing - used in the branch is not necessary, and all the files are put directly - in the journal directory. -} -journalFile :: FilePath -> Git.Repo -> FilePath -journalFile file repo = gitAnnexJournalDir repo concatMap mangle file +journalFile :: RawFilePath -> Git.Repo -> RawFilePath +journalFile file repo = gitAnnexJournalDir' repo P. S.map mangle file where mangle c - | c == pathSeparator = "_" - | c == '_' = "__" - | otherwise = [c] + | c == P.pathSeparator = fromIntegral (ord '_') + | otherwise = c {- Converts a journal file (relative to the journal dir) back to the - filename on the branch. -} -fileJournal :: FilePath -> FilePath -fileJournal = replace [pathSeparator, pathSeparator] "_" . - replace "_" [pathSeparator] +fileJournal :: RawFilePath -> RawFilePath +fileJournal = S.map unmangle + where + unmangle c + | c == fromIntegral (ord '_') = P.pathSeparator + | otherwise = c {- Sentinal value, only produced by lockJournal; required - as a parameter by things that need to ensure the journal is diff --git a/Annex/Link.hs b/Annex/Link.hs index fe9e1d52d7..ede132a5b9 100644 --- a/Annex/Link.hs +++ b/Annex/Link.hs @@ -39,6 +39,7 @@ import qualified Utility.RawFilePath as R import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L +import qualified System.FilePath.ByteString as P type LinkTarget = String @@ -182,7 +183,7 @@ restagePointerFile (Restage True) f orig = withTSDelta $ \tsd -> do absf <- liftIO $ absPath $ fromRawFilePath f Annex.Queue.addInternalAction runner [(absf, isunmodified tsd)] where - isunmodified tsd = genInodeCache' f tsd >>= return . \case + isunmodified tsd = genInodeCache f tsd >>= return . \case Nothing -> False Just new -> compareStrong orig new @@ -301,8 +302,7 @@ isLinkToAnnex s = p `S.isInfixOf` s || p' `S.isInfixOf` s #endif where - sp = (pathSeparator:objectDir) - p = toRawFilePath sp + p = P.pathSeparator `S.cons` objectDir' #ifdef mingw32_HOST_OS - p' = toRawFilePath (toInternalGitPath sp) + p' = toInternalGitPath p #endif diff --git a/Annex/Locations.hs b/Annex/Locations.hs index 3c49099094..36858a72bb 100644 --- a/Annex/Locations.hs +++ b/Annex/Locations.hs @@ -16,6 +16,7 @@ module Annex.Locations ( keyPath, annexDir, objectDir, + objectDir', gitAnnexLocation, gitAnnexLocationDepth, gitAnnexLink, @@ -62,6 +63,7 @@ module Annex.Locations ( gitAnnexFeedState, gitAnnexMergeDir, gitAnnexJournalDir, + gitAnnexJournalDir', gitAnnexJournalLock, gitAnnexGitQueueLock, gitAnnexPreCommitLock, @@ -105,6 +107,7 @@ import qualified Git.Types as Git import Git.FilePath import Annex.DirHashes import Annex.Fixup +import qualified Utility.RawFilePath as R {- Conventions: - @@ -124,21 +127,27 @@ import Annex.Fixup annexDir :: FilePath annexDir = addTrailingPathSeparator "annex" +annexDir' :: RawFilePath +annexDir' = P.addTrailingPathSeparator "annex" + {- The directory git annex uses for locally available object content, - relative to the .git directory -} objectDir :: FilePath objectDir = addTrailingPathSeparator $ annexDir "objects" +objectDir' :: RawFilePath +objectDir' = P.addTrailingPathSeparator $ annexDir' P. "objects" + {- Annexed file's possible locations relative to the .git directory. - There are two different possibilities, using different hashes. - - Also, some repositories have a Difference in hash directory depth. -} -annexLocations :: GitConfig -> Key -> [FilePath] +annexLocations :: GitConfig -> Key -> [RawFilePath] annexLocations config key = map (annexLocation config key) dirHashes -annexLocation :: GitConfig -> Key -> (HashLevels -> Hasher) -> FilePath -annexLocation config key hasher = objectDir keyPath key (hasher $ objectHashLevels config) +annexLocation :: GitConfig -> Key -> (HashLevels -> Hasher) -> RawFilePath +annexLocation config key hasher = objectDir' P. keyPath key (hasher $ objectHashLevels config) {- Number of subdirectories from the gitAnnexObjectDir - to the gitAnnexLocation. -} @@ -158,14 +167,14 @@ gitAnnexLocationDepth config = hashlevels + 1 - This does not take direct mode into account, so in direct mode it is not - the actual location of the file's content. -} -gitAnnexLocation :: Key -> Git.Repo -> GitConfig -> IO FilePath +gitAnnexLocation :: Key -> Git.Repo -> GitConfig -> IO RawFilePath gitAnnexLocation key r config = gitAnnexLocation' key r config (annexCrippledFileSystem config) (coreSymlinks config) - doesFileExist - (fromRawFilePath (Git.localGitDir r)) + R.doesPathExist + (Git.localGitDir r) -gitAnnexLocation' :: Key -> Git.Repo -> GitConfig -> Bool -> Bool -> (FilePath -> IO Bool) -> FilePath -> IO FilePath +gitAnnexLocation' :: Key -> Git.Repo -> GitConfig -> Bool -> Bool -> (RawFilePath -> IO Bool) -> RawFilePath -> IO RawFilePath gitAnnexLocation' key r config crippled symlinkssupported checker gitdir {- Bare repositories default to hashDirLower for new - content, as it's more portable. But check all locations. -} @@ -187,7 +196,7 @@ gitAnnexLocation' key r config crippled symlinkssupported checker gitdir only = return . inrepo . annexLocation config key checkall = check $ map inrepo $ annexLocations config key - inrepo d = gitdir d + inrepo d = gitdir P. d check locs@(l:_) = fromMaybe l <$> firstM checker locs check [] = error "internal" @@ -199,16 +208,17 @@ gitAnnexLink file key r config = do let gitdir = getgitdir currdir loc <- gitAnnexLocation' key r config False False (\_ -> return True) gitdir fromRawFilePath . toInternalGitPath . toRawFilePath - <$> relPathDirToFile (parentDir absfile) loc + <$> relPathDirToFile (parentDir absfile) (fromRawFilePath loc) where getgitdir currdir {- This special case is for git submodules on filesystems not - supporting symlinks; generate link target that will - work portably. -} | not (coreSymlinks config) && needsSubmoduleFixup r = - absNormPathUnix currdir $ fromRawFilePath $ - Git.repoPath r P. ".git" - | otherwise = fromRawFilePath $ Git.localGitDir r + toRawFilePath $ + absNormPathUnix currdir $ fromRawFilePath $ + Git.repoPath r P. ".git" + | otherwise = Git.localGitDir r absNormPathUnix d p = fromRawFilePath $ toInternalGitPath $ toRawFilePath $ absPathFrom (fromRawFilePath $ toInternalGitPath $ toRawFilePath d) @@ -232,33 +242,36 @@ gitAnnexLinkCanonical file key r config = gitAnnexLink file key r' config' gitAnnexContentLock :: Key -> Git.Repo -> GitConfig -> IO FilePath gitAnnexContentLock key r config = do loc <- gitAnnexLocation key r config - return $ loc ++ ".lck" + return $ fromRawFilePath loc ++ ".lck" {- File that maps from a key to the file(s) in the git repository. - Used in direct mode. -} gitAnnexMapping :: Key -> Git.Repo -> GitConfig -> IO FilePath gitAnnexMapping key r config = do loc <- gitAnnexLocation key r config - return $ loc ++ ".map" + return $ fromRawFilePath loc ++ ".map" {- File that caches information about a key's content, used to determine - if a file has changed. - Used in direct mode. -} gitAnnexInodeCache :: Key -> Git.Repo -> GitConfig -> IO FilePath -gitAnnexInodeCache key r config = do +gitAnnexInodeCache key r config = do loc <- gitAnnexLocation key r config - return $ loc ++ ".cache" + return $ fromRawFilePath loc ++ ".cache" -gitAnnexInodeSentinal :: Git.Repo -> FilePath -gitAnnexInodeSentinal r = gitAnnexDir r "sentinal" +gitAnnexInodeSentinal :: Git.Repo -> RawFilePath +gitAnnexInodeSentinal r = gitAnnexDir' r P. "sentinal" -gitAnnexInodeSentinalCache :: Git.Repo -> FilePath -gitAnnexInodeSentinalCache r = gitAnnexInodeSentinal r ++ ".cache" +gitAnnexInodeSentinalCache :: Git.Repo -> RawFilePath +gitAnnexInodeSentinalCache r = gitAnnexInodeSentinal r <> ".cache" {- The annex directory of a repository. -} gitAnnexDir :: Git.Repo -> FilePath gitAnnexDir r = addTrailingPathSeparator $ fromRawFilePath (Git.localGitDir r) annexDir +gitAnnexDir' :: Git.Repo -> RawFilePath +gitAnnexDir' r = P.addTrailingPathSeparator $ Git.localGitDir r P. annexDir' + {- The part of the annex directory where file contents are stored. -} gitAnnexObjectDir :: Git.Repo -> FilePath gitAnnexObjectDir r = addTrailingPathSeparator $ fromRawFilePath (Git.localGitDir r) objectDir @@ -428,6 +441,9 @@ gitAnnexTransferDir r = addTrailingPathSeparator $ gitAnnexDir r "transfer" gitAnnexJournalDir :: Git.Repo -> FilePath gitAnnexJournalDir r = addTrailingPathSeparator $ gitAnnexDir r "journal" +gitAnnexJournalDir' :: Git.Repo -> RawFilePath +gitAnnexJournalDir' r = P.addTrailingPathSeparator $ gitAnnexDir' r P. "journal" + {- Lock file for the journal. -} gitAnnexJournalLock :: Git.Repo -> FilePath gitAnnexJournalLock r = gitAnnexDir r "journal.lck" @@ -609,10 +625,10 @@ fileKey' = deserializeKey' . S8.intercalate "/" . map go . S8.split '%' - The file is put in a directory with the same name, this allows - write-protecting the directory to avoid accidental deletion of the file. -} -keyPath :: Key -> Hasher -> FilePath -keyPath key hasher = hasher key f f +keyPath :: Key -> Hasher -> RawFilePath +keyPath key hasher = hasher key P. f P. f where - f = keyFile key + f = keyFile' key {- All possibile locations to store a key in a special remote - using different directory hashes. @@ -620,5 +636,5 @@ keyPath key hasher = hasher key f f - This is compatible with the annexLocations, for interoperability between - special remotes and git-annex repos. -} -keyPaths :: Key -> [FilePath] +keyPaths :: Key -> [RawFilePath] keyPaths key = map (\h -> keyPath key (h def)) dirHashes diff --git a/Annex/WorkTree.hs b/Annex/WorkTree.hs index 1b2c11061e..bca75be864 100644 --- a/Annex/WorkTree.hs +++ b/Annex/WorkTree.hs @@ -101,13 +101,14 @@ scanUnlockedFiles = whenM (inRepo Git.Ref.headExists <&&> not <$> isBareRepo) $ Just k' | k' == k -> do destmode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus f - ic <- replaceFile (fromRawFilePath f) $ \tmp -> + ic <- replaceFile (fromRawFilePath f) $ \tmp -> do + let tmp' = toRawFilePath tmp linkFromAnnex k tmp destmode >>= \case LinkAnnexOk -> - withTSDelta (liftIO . genInodeCache tmp) + withTSDelta (liftIO . genInodeCache tmp') LinkAnnexNoop -> return Nothing LinkAnnexFailed -> liftIO $ do - writePointerFile (toRawFilePath tmp) k destmode + writePointerFile tmp' k destmode return Nothing maybe noop (restagePointerFile (Restage True) f) ic _ -> noop diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs index 5ed49166bb..53d72b6454 100644 --- a/Assistant/Threads/Committer.hs +++ b/Assistant/Threads/Committer.hs @@ -308,7 +308,7 @@ handleAdds lockdowndir havelsof delayadd cs = returnWhen (null incomplete) $ do if M.null m then forM toadd (add cfg) else forM toadd $ \c -> do - mcache <- liftIO $ genInodeCache (changeFile c) delta + mcache <- liftIO $ genInodeCache (toRawFilePath (changeFile c)) delta case mcache of Nothing -> add cfg c Just cache -> diff --git a/Assistant/Upgrade.hs b/Assistant/Upgrade.hs index 0ea52f3158..a8a6778abe 100644 --- a/Assistant/Upgrade.hs +++ b/Assistant/Upgrade.hs @@ -113,7 +113,7 @@ distributionDownloadComplete d dest cleanup t | transferDirection t == Download = do debug ["finished downloading git-annex distribution"] maybe (failedupgrade "bad download") go - =<< liftAnnex (withObjectLoc k fsckit) + =<< liftAnnex (withObjectLoc k (fsckit . fromRawFilePath)) | otherwise = cleanup where k = mkKey $ const $ distributionKey d diff --git a/CHANGELOG b/CHANGELOG index 66ae7e8bdc..a3c748ce93 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,13 +1,9 @@ git-annex (7.20191115) UNRELEASED; urgency=medium - * Sped up many git-annex commands that operate on many files, by - using ByteStrings. Some commands like find got up to 60% faster. - * Sped up many git-annex commands that operate on many files, by - avoiding reserialization of keys. - find got 7% faster; whereis 3% faster; and git-annex get when - all files are already present got 5% faster - * Sped up many git-annex commands that query the git-annex branch. - In particular whereis got 1.5% faster. + * Optimised processing of many files, especially by commands like find + and whereis that only report on the state of the repository. Commands + like get also sped up in cases where they have to check a lot of + files but only transfer a few files. Speedups range from 30-100%. * Stop displaying rsync progress, and use git-annex's own progress display for local-to-local repo transfers. * git-lfs: The url provided to initremote/enableremote will now be diff --git a/CmdLine/Seek.hs b/CmdLine/Seek.hs index 1811698f00..0ffa1cbfb6 100644 --- a/CmdLine/Seek.hs +++ b/CmdLine/Seek.hs @@ -131,7 +131,7 @@ withUnmodifiedUnlockedPointers a l = seekActions $ isUnmodifiedUnlocked :: RawFilePath -> Annex Bool isUnmodifiedUnlocked f = catKeyFile f >>= \case Nothing -> return False - Just k -> sameInodeCache (fromRawFilePath f) =<< Database.Keys.getInodeCaches k + Just k -> sameInodeCache f =<< Database.Keys.getInodeCaches k {- Finds files that may be modified. -} withFilesMaybeModified :: (RawFilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek diff --git a/Command/ContentLocation.hs b/Command/ContentLocation.hs index 9576f86044..ef2e467bb5 100644 --- a/Command/ContentLocation.hs +++ b/Command/ContentLocation.hs @@ -9,6 +9,9 @@ module Command.ContentLocation where import Command import Annex.Content +import qualified Utility.RawFilePath as R + +import qualified Data.ByteString.Char8 as B8 cmd :: Command cmd = noCommit $ noMessages $ @@ -20,10 +23,10 @@ cmd = noCommit $ noMessages $ run :: () -> String -> Annex Bool run _ p = do let k = fromMaybe (giveup "bad key") $ deserializeKey p - maybe (return False) (\f -> liftIO (putStrLn f) >> return True) + maybe (return False) (\f -> liftIO (B8.putStrLn f) >> return True) =<< inAnnex' (pure True) Nothing check k where - check f = ifM (liftIO (doesFileExist f)) + check f = ifM (liftIO (R.doesPathExist f)) ( return (Just f) , return Nothing ) diff --git a/Command/DiffDriver.hs b/Command/DiffDriver.hs index ecc05ca093..e0cef22234 100644 --- a/Command/DiffDriver.hs +++ b/Command/DiffDriver.hs @@ -90,7 +90,8 @@ fixupReq req@(Req {}) = v <- getAnnexLinkTarget' (toRawFilePath (getfile r)) False case parseLinkTargetOrPointer =<< v of Nothing -> return r - Just k -> withObjectLoc k (pure . setfile r) + Just k -> withObjectLoc k $ + pure . setfile r . fromRawFilePath _ -> return r externalDiffer :: String -> [String] -> Differ diff --git a/Command/Find.hs b/Command/Find.hs index 4e71ac845a..eba431c92c 100644 --- a/Command/Find.hs +++ b/Command/Find.hs @@ -93,8 +93,8 @@ keyVars key = , ("bytesize", size show) , ("humansize", size $ roughSize storageUnits True) , ("keyname", decodeBS $ fromKey keyName key) - , ("hashdirlower", hashDirLower def key) - , ("hashdirmixed", hashDirMixed def key) + , ("hashdirlower", fromRawFilePath $ hashDirLower def key) + , ("hashdirmixed", fromRawFilePath $ hashDirMixed def key) , ("mtime", whenavail show $ fromKey keyMtime key) ] where diff --git a/Command/Fix.hs b/Command/Fix.hs index 52e076f30b..e26d184092 100644 --- a/Command/Fix.hs +++ b/Command/Fix.hs @@ -53,11 +53,11 @@ start fixwhat file key = do where fixby = starting "fix" (mkActionItem (key, file)) fixthin = do - obj <- calcRepo $ gitAnnexLocation key - stopUnless (isUnmodified key (fromRawFilePath file) <&&> isUnmodified key obj) $ do + obj <- calcRepo (gitAnnexLocation key) + stopUnless (isUnmodified key file <&&> isUnmodified key obj) $ do thin <- annexThin <$> Annex.getGitConfig fs <- liftIO $ catchMaybeIO $ R.getFileStatus file - os <- liftIO $ catchMaybeIO $ getFileStatus obj + os <- liftIO $ catchMaybeIO $ R.getFileStatus obj case (linkCount <$> fs, linkCount <$> os, thin) of (Just 1, Just 1, True) -> fixby $ makeHardLink file key @@ -65,15 +65,16 @@ start fixwhat file key = do fixby $ breakHardLink file key obj _ -> stop -breakHardLink :: RawFilePath -> Key -> FilePath -> CommandPerform +breakHardLink :: RawFilePath -> Key -> RawFilePath -> CommandPerform breakHardLink file key obj = do replaceFile (fromRawFilePath file) $ \tmp -> do mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file - unlessM (checkedCopyFile key obj tmp mode) $ + let obj' = fromRawFilePath obj + unlessM (checkedCopyFile key obj' tmp mode) $ error "unable to break hard link" thawContent tmp - modifyContent obj $ freezeContent obj - Database.Keys.storeInodeCaches key [fromRawFilePath file] + modifyContent obj' $ freezeContent obj' + Database.Keys.storeInodeCaches key [file] next $ return True makeHardLink :: RawFilePath -> Key -> CommandPerform diff --git a/Command/Fsck.hs b/Command/Fsck.hs index a55b882c09..3010a6ce37 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -223,7 +223,7 @@ fixLink key file = do - in this repository only. -} verifyLocationLog :: Key -> KeyStatus -> ActionItem -> Annex Bool verifyLocationLog key keystatus ai = do - obj <- calcRepo $ gitAnnexLocation key + obj <- fromRawFilePath <$> calcRepo (gitAnnexLocation key) present <- if isKeyUnlockedThin keystatus then liftIO (doesFileExist obj) else inAnnex key @@ -332,11 +332,11 @@ verifyWorkTree key file = do ifM (annexThin <$> Annex.getGitConfig) ( void $ linkFromAnnex key tmp mode , do - obj <- calcRepo $ gitAnnexLocation key + obj <- fromRawFilePath <$> calcRepo (gitAnnexLocation key) void $ checkedCopyFile key obj tmp mode thawContent tmp ) - Database.Keys.storeInodeCaches key [fromRawFilePath file] + Database.Keys.storeInodeCaches key [file] _ -> return () return True @@ -349,8 +349,8 @@ checkKeySize :: Key -> KeyStatus -> ActionItem -> Annex Bool checkKeySize _ KeyUnlockedThin _ = return True checkKeySize key _ ai = do file <- calcRepo $ gitAnnexLocation key - ifM (liftIO $ doesFileExist file) - ( checkKeySizeOr badContent key file ai + ifM (liftIO $ R.doesPathExist file) + ( checkKeySizeOr badContent key (fromRawFilePath file) ai , return True ) @@ -417,10 +417,10 @@ checkKeyUpgrade _ _ _ (AssociatedFile Nothing) = -} checkBackend :: Backend -> Key -> KeyStatus -> AssociatedFile -> Annex Bool checkBackend backend key keystatus afile = do - content <- calcRepo $ gitAnnexLocation key + content <- calcRepo (gitAnnexLocation key) ifM (pure (isKeyUnlockedThin keystatus) <&&> (not <$> isUnmodified key content)) ( nocheck - , checkBackendOr badContent backend key content ai + , checkBackendOr badContent backend key (fromRawFilePath content) ai ) where nocheck = return True @@ -670,8 +670,8 @@ isKeyUnlockedThin KeyMissing = False getKeyStatus :: Key -> Annex KeyStatus getKeyStatus key = catchDefaultIO KeyMissing $ do afs <- not . null <$> Database.Keys.getAssociatedFiles key - obj <- calcRepo $ gitAnnexLocation key - multilink <- ((> 1) . linkCount <$> liftIO (getFileStatus obj)) + obj <- calcRepo (gitAnnexLocation key) + multilink <- ((> 1) . linkCount <$> liftIO (R.getFileStatus obj)) return $ if multilink && afs then KeyUnlockedThin else KeyPresent diff --git a/Command/Import.hs b/Command/Import.hs index 615fe5db1c..7e8ea18642 100644 --- a/Command/Import.hs +++ b/Command/Import.hs @@ -181,7 +181,7 @@ startLocal largematcher mode (srcfile, destfile) = -- weakly the same as the origianlly locked down file's -- inode cache. (Since the file may have been copied, -- its inodes may not be the same.) - newcache <- withTSDelta $ liftIO . genInodeCache destfile + newcache <- withTSDelta $ liftIO . genInodeCache (toRawFilePath destfile) let unchanged = case (newcache, inodeCache (keySource ld)) of (_, Nothing) -> True (Just newc, Just c) | compareWeak c newc -> True diff --git a/Command/Lock.hs b/Command/Lock.hs index e0ca6e4594..6e8a7f4ffb 100644 --- a/Command/Lock.hs +++ b/Command/Lock.hs @@ -20,6 +20,7 @@ import qualified Database.Keys import Annex.Ingest import Logs.Location import Git.FilePath +import qualified Utility.RawFilePath as R cmd :: Command cmd = withGlobalOptions [jsonOptions, annexedMatchingOptions] $ @@ -43,7 +44,7 @@ startNew file key = ifM (isJust <$> isAnnexLink file) | key' == key = cont | otherwise = errorModified go Nothing = - ifM (isUnmodified key (fromRawFilePath file)) + ifM (isUnmodified key file) ( cont , ifM (Annex.getState Annex.force) ( cont @@ -56,37 +57,38 @@ performNew :: RawFilePath -> Key -> CommandPerform performNew file key = do lockdown =<< calcRepo (gitAnnexLocation key) addLink (fromRawFilePath file) key - =<< withTSDelta (liftIO . genInodeCache' file) + =<< withTSDelta (liftIO . genInodeCache file) next $ cleanupNew file key where lockdown obj = do ifM (isUnmodified key obj) ( breakhardlink obj - , repopulate obj + , repopulate (fromRawFilePath obj) ) - whenM (liftIO $ doesFileExist obj) $ - freezeContent obj + whenM (liftIO $ R.doesPathExist obj) $ + freezeContent $ fromRawFilePath obj -- It's ok if the file is hard linked to obj, but if some other -- associated file is, we need to break that link to lock down obj. - breakhardlink obj = whenM (catchBoolIO $ (> 1) . linkCount <$> liftIO (getFileStatus obj)) $ do - mfc <- withTSDelta (liftIO . genInodeCache' file) + breakhardlink obj = whenM (catchBoolIO $ (> 1) . linkCount <$> liftIO (R.getFileStatus obj)) $ do + mfc <- withTSDelta (liftIO . genInodeCache file) unlessM (sameInodeCache obj (maybeToList mfc)) $ do - modifyContent obj $ replaceFile obj $ \tmp -> do - unlessM (checkedCopyFile key obj tmp Nothing) $ + let obj' = fromRawFilePath obj + modifyContent obj' $ replaceFile obj' $ \tmp -> do + unlessM (checkedCopyFile key obj' tmp Nothing) $ giveup "unable to lock file" Database.Keys.storeInodeCaches key [obj] -- Try to repopulate obj from an unmodified associated file. repopulate obj = modifyContent obj $ do g <- Annex.gitRepo - fs <- map fromRawFilePath . map (`fromTopFilePath` g) + fs <- map (`fromTopFilePath` g) <$> Database.Keys.getAssociatedFiles key mfile <- firstM (isUnmodified key) fs liftIO $ nukeFile obj case mfile of Just unmodified -> - unlessM (checkedCopyFile key unmodified obj Nothing) + unlessM (checkedCopyFile key (fromRawFilePath unmodified) obj Nothing) lostcontent Nothing -> lostcontent diff --git a/Command/Migrate.hs b/Command/Migrate.hs index 0f964bb749..2feb879aa5 100644 --- a/Command/Migrate.hs +++ b/Command/Migrate.hs @@ -86,7 +86,7 @@ perform file oldkey oldbackend newbackend = go =<< genkey (fastMigrate oldbacken content <- calcRepo $ gitAnnexLocation oldkey let source = KeySource { keyFilename = fromRawFilePath file - , contentLocation = content + , contentLocation = fromRawFilePath content , inodeCache = Nothing } v <- genKey source nullMeterUpdate (Just newbackend) diff --git a/Command/Multicast.hs b/Command/Multicast.hs index 6c6d2c418b..fcb36800d4 100644 --- a/Command/Multicast.hs +++ b/Command/Multicast.hs @@ -137,7 +137,8 @@ send ups fs = do mk <- lookupFile f case mk of Nothing -> noop - Just k -> withObjectLoc k (addlist f) + Just k -> withObjectLoc k $ + addlist f . fromRawFilePath liftIO $ hClose h serverkey <- uftpKey diff --git a/Command/ReKey.hs b/Command/ReKey.hs index a67d876df7..52984928bd 100644 --- a/Command/ReKey.hs +++ b/Command/ReKey.hs @@ -83,12 +83,12 @@ linkKey file oldkey newkey = ifM (isJust <$> isAnnexLink file) - unlocked file, which would leave the new key unlocked - and vulnerable to corruption. -} ( getViaTmpFromDisk RetrievalAllKeysSecure DefaultVerify newkey $ \tmp -> unVerified $ do - oldobj <- calcRepo (gitAnnexLocation oldkey) + oldobj <- fromRawFilePath <$> calcRepo (gitAnnexLocation oldkey) isJust <$> linkOrCopy' (return True) newkey oldobj tmp Nothing , do {- The file being rekeyed is itself an unlocked file; if - it's hard linked to the old key, that link must be broken. -} - oldobj <- calcRepo (gitAnnexLocation oldkey) + oldobj <- fromRawFilePath <$> calcRepo (gitAnnexLocation oldkey) v <- tryNonAsync $ do st <- liftIO $ R.getFileStatus file when (linkCount st > 1) $ do @@ -97,7 +97,7 @@ linkKey file oldkey newkey = ifM (isJust <$> isAnnexLink file) unlessM (checkedCopyFile oldkey oldobj tmp Nothing) $ error "can't lock old key" thawContent tmp - ic <- withTSDelta (liftIO . genInodeCache' file) + ic <- withTSDelta (liftIO . genInodeCache file) case v of Left e -> do warning (show e) diff --git a/Command/Smudge.hs b/Command/Smudge.hs index 9b5e57ede1..d8f6c08454 100644 --- a/Command/Smudge.hs +++ b/Command/Smudge.hs @@ -108,7 +108,7 @@ clean file = do -- annexed and is unmodified. case oldkey of Nothing -> doingest oldkey - Just ko -> ifM (isUnmodifiedCheap ko file) + Just ko -> ifM (isUnmodifiedCheap ko (toRawFilePath file)) ( liftIO $ emitPointer ko , doingest oldkey ) @@ -174,7 +174,7 @@ shouldAnnex file moldkey = ifM (annexGitAddToAnnex <$> Annex.getGitConfig) Just _ -> return True Nothing -> checkknowninode - checkknowninode = withTSDelta (liftIO . genInodeCache file) >>= \case + checkknowninode = withTSDelta (liftIO . genInodeCache (toRawFilePath file)) >>= \case Nothing -> pure False Just ic -> Database.Keys.isInodeKnown ic =<< sentinalStatus @@ -191,7 +191,7 @@ emitPointer = S.putStr . formatPointer getMoveRaceRecovery :: Key -> RawFilePath -> Annex () getMoveRaceRecovery k file = void $ tryNonAsync $ whenM (inAnnex k) $ do - obj <- toRawFilePath <$> calcRepo (gitAnnexLocation k) + obj <- calcRepo (gitAnnexLocation k) -- Cannot restage because git add is running and has -- the index locked. populatePointerFile (Restage False) k obj file >>= \case @@ -207,7 +207,7 @@ updateSmudged :: Restage -> Annex () updateSmudged restage = streamSmudged $ \k topf -> do f <- fromRepo (fromTopFilePath topf) whenM (inAnnex k) $ do - obj <- toRawFilePath <$> calcRepo (gitAnnexLocation k) + obj <- calcRepo (gitAnnexLocation k) unlessM (isJust <$> populatePointerFile restage k obj f) $ liftIO (isPointerFile f) >>= \case Just k' | k' == k -> toplevelWarning False $ diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs index 292697a781..bf8c24cd5d 100644 --- a/Command/TestRemote.hs +++ b/Command/TestRemote.hs @@ -168,7 +168,7 @@ test st r k = catMaybes get , Just $ check "fsck downloaded object" fsck , Just $ check "retrieveKeyFile resume from 33%" $ do - loc <- Annex.calcRepo (gitAnnexLocation k) + loc <- fromRawFilePath <$> Annex.calcRepo (gitAnnexLocation k) tmp <- prepTmp k partial <- liftIO $ bracket (openBinaryFile loc ReadMode) hClose $ \h -> do sz <- hFileSize h @@ -184,7 +184,7 @@ test st r k = catMaybes get , Just $ check "fsck downloaded object" fsck , Just $ check "retrieveKeyFile resume from end" $ do - loc <- Annex.calcRepo (gitAnnexLocation k) + loc <- fromRawFilePath <$> Annex.calcRepo (gitAnnexLocation k) tmp <- prepTmp k void $ liftIO $ copyFileExternal CopyAllMetaData loc tmp lockContentForRemoval k removeAnnex @@ -240,7 +240,7 @@ testExportTree st (Just _) ea k1 k2 = check desc a = testCase desc $ Annex.eval st (Annex.setOutput QuietOutput >> a) @? "failed" storeexport k = do - loc <- Annex.calcRepo (gitAnnexLocation k) + loc <- fromRawFilePath <$> Annex.calcRepo (gitAnnexLocation k) Remote.storeExport ea loc k testexportlocation nullMeterUpdate retrieveexport k = withTmpFile "exported" $ \tmp h -> do liftIO $ hClose h diff --git a/Command/Unannex.hs b/Command/Unannex.hs index 356ff1d946..d63f9a6b4f 100644 --- a/Command/Unannex.hs +++ b/Command/Unannex.hs @@ -46,7 +46,7 @@ perform file key = do cleanup :: RawFilePath -> Key -> CommandCleanup cleanup file key = do Database.Keys.removeAssociatedFile key =<< inRepo (toTopFilePath file) - src <- calcRepo $ gitAnnexLocation key + src <- fromRawFilePath <$> calcRepo (gitAnnexLocation key) ifM (Annex.getState Annex.fast) ( do -- Only make a hard link if the annexed file does not diff --git a/Command/Uninit.hs b/Command/Uninit.hs index 6c62694543..29278a6c4e 100644 --- a/Command/Uninit.hs +++ b/Command/Uninit.hs @@ -17,6 +17,7 @@ import qualified Database.Keys import Annex.Content import Annex.Init import Utility.FileMode +import qualified Utility.RawFilePath as R cmd :: Command cmd = addCheck check $ @@ -117,5 +118,5 @@ removeUnannexed = go [] , go (k:c) ks ) enoughlinks f = catchBoolIO $ do - s <- getFileStatus f + s <- R.getFileStatus f return $ linkCount s > 1 diff --git a/Command/Unused.hs b/Command/Unused.hs index 7f49440e6b..78400db7e1 100644 --- a/Command/Unused.hs +++ b/Command/Unused.hs @@ -283,7 +283,7 @@ associatedFilesFilter = filterM go checkunmodified _ [] = return True checkunmodified cs (f:fs) = do relf <- fromRepo $ fromTopFilePath f - ifM (sameInodeCache (fromRawFilePath relf) cs) + ifM (sameInodeCache relf cs) ( return False , checkunmodified cs fs ) diff --git a/Database/Keys.hs b/Database/Keys.hs index b04dff02be..48d51caf4e 100644 --- a/Database/Keys.hs +++ b/Database/Keys.hs @@ -169,13 +169,13 @@ removeAssociatedFile :: Key -> TopFilePath -> Annex () removeAssociatedFile k = runWriterIO . SQL.removeAssociatedFile (toIKey k) {- Stats the files, and stores their InodeCaches. -} -storeInodeCaches :: Key -> [FilePath] -> Annex () +storeInodeCaches :: Key -> [RawFilePath] -> Annex () storeInodeCaches k fs = storeInodeCaches' k fs [] -storeInodeCaches' :: Key -> [FilePath] -> [InodeCache] -> Annex () +storeInodeCaches' :: Key -> [RawFilePath] -> [InodeCache] -> Annex () storeInodeCaches' k fs ics = withTSDelta $ \d -> addInodeCaches k . (++ ics) . catMaybes - =<< liftIO (mapM (`genInodeCache` d) fs) + =<< liftIO (mapM (\f -> genInodeCache f d) fs) addInodeCaches :: Key -> [InodeCache] -> Annex () addInodeCaches k is = runWriterIO $ SQL.addInodeCaches (toIKey k) is @@ -223,7 +223,7 @@ reconcileStaged :: H.DbQueue -> Annex () reconcileStaged qh = do gitindex <- inRepo currentIndexFile indexcache <- fromRepo gitAnnexKeysDbIndexCache - withTSDelta (liftIO . genInodeCache gitindex) >>= \case + withTSDelta (liftIO . genInodeCache (toRawFilePath gitindex)) >>= \case Just cur -> liftIO (maybe Nothing readInodeCache <$> catchMaybeIO (readFile indexcache)) >>= \case Nothing -> go cur indexcache @@ -295,10 +295,10 @@ reconcileStaged qh = do keyloc <- calcRepo (gitAnnexLocation key) keypopulated <- sameInodeCache keyloc caches p <- fromRepo $ fromTopFilePath file - filepopulated <- sameInodeCache (fromRawFilePath p) caches + filepopulated <- sameInodeCache p caches case (keypopulated, filepopulated) of (True, False) -> - populatePointerFile (Restage True) key (toRawFilePath keyloc) p >>= \case + populatePointerFile (Restage True) key keyloc p >>= \case Nothing -> return () Just ic -> liftIO $ SQL.addInodeCaches ikey [ic] (SQL.WriteHandle qh) diff --git a/Limit.hs b/Limit.hs index 9e8ece2d11..2069822711 100644 --- a/Limit.hs +++ b/Limit.hs @@ -33,6 +33,7 @@ import Git.Types (RefDate(..)) import Utility.Glob import Utility.HumanTime import Utility.DataUnits +import qualified Utility.RawFilePath as R import Data.Time.Clock.POSIX import qualified Data.Set as S @@ -117,7 +118,8 @@ addMagicLimit limitname querymagic selectprovidedinfo glob = do -- When the file is an annex symlink, get magic of the -- object file. Nothing -> isAnnexLink (toRawFilePath f) >>= \case - Just k -> withObjectLoc k $ querymagic magic + Just k -> withObjectLoc k $ + querymagic magic . fromRawFilePath Nothing -> querymagic magic f matchMagic :: String -> (Magic -> FilePath -> Annex (Maybe String)) -> (ProvidedInfo -> OptInfo String) -> Maybe Magic -> MkLimit Annex @@ -363,7 +365,7 @@ addAccessedWithin duration = do where check now k = inAnnexCheck k $ \f -> liftIO $ catchDefaultIO False $ do - s <- getFileStatus f + s <- R.getFileStatus f let accessed = realToFrac (accessTime s) let delta = now - accessed return $ delta <= secs diff --git a/Logs.hs b/Logs.hs index d612aa8d56..18a045b452 100644 --- a/Logs.hs +++ b/Logs.hs @@ -13,6 +13,7 @@ import Annex.Common import Annex.DirHashes import qualified Data.ByteString as S +import qualified System.FilePath.ByteString as P {- There are several varieties of log file formats. -} data LogVariety @@ -117,19 +118,19 @@ exportLog = "export.log" {- The pathname of the location log file for a given key. -} locationLogFile :: GitConfig -> Key -> RawFilePath -locationLogFile config key = toRawFilePath $ - branchHashDir config key keyFile key ++ ".log" +locationLogFile config key = + branchHashDir config key P. keyFile' key <> ".log" {- The filename of the url log for a given key. -} urlLogFile :: GitConfig -> Key -> RawFilePath -urlLogFile config key = toRawFilePath $ - branchHashDir config key keyFile key ++ decodeBS' urlLogExt +urlLogFile config key = + branchHashDir config key P. keyFile' key <> urlLogExt {- Old versions stored the urls elsewhere. -} oldurlLogs :: GitConfig -> Key -> [RawFilePath] -oldurlLogs config key = map toRawFilePath - [ "remote/web" hdir serializeKey key ++ ".log" - , "remote/web" hdir keyFile key ++ ".log" +oldurlLogs config key = + [ "remote/web" P. hdir P. serializeKey' key <> ".log" + , "remote/web" P. hdir P. keyFile' key <> ".log" ] where hdir = branchHashDir config key @@ -144,7 +145,7 @@ isUrlLog file = urlLogExt `S.isSuffixOf` file {- The filename of the remote state log for a given key. -} remoteStateLogFile :: GitConfig -> Key -> RawFilePath remoteStateLogFile config key = - toRawFilePath (branchHashDir config key keyFile key) + (branchHashDir config key P. keyFile' key) <> remoteStateLogExt remoteStateLogExt :: S.ByteString @@ -156,7 +157,7 @@ isRemoteStateLog path = remoteStateLogExt `S.isSuffixOf` path {- The filename of the chunk log for a given key. -} chunkLogFile :: GitConfig -> Key -> RawFilePath chunkLogFile config key = - toRawFilePath (branchHashDir config key keyFile key) + (branchHashDir config key P. keyFile' key) <> chunkLogExt chunkLogExt :: S.ByteString @@ -168,7 +169,7 @@ isChunkLog path = chunkLogExt `S.isSuffixOf` path {- The filename of the metadata log for a given key. -} metaDataLogFile :: GitConfig -> Key -> RawFilePath metaDataLogFile config key = - toRawFilePath (branchHashDir config key keyFile key) + (branchHashDir config key P. keyFile' key) <> metaDataLogExt metaDataLogExt :: S.ByteString @@ -180,7 +181,7 @@ isMetaDataLog path = metaDataLogExt `S.isSuffixOf` path {- The filename of the remote metadata log for a given key. -} remoteMetaDataLogFile :: GitConfig -> Key -> RawFilePath remoteMetaDataLogFile config key = - toRawFilePath (branchHashDir config key keyFile key) + (branchHashDir config key P. keyFile' key) <> remoteMetaDataLogExt remoteMetaDataLogExt :: S.ByteString @@ -192,7 +193,7 @@ isRemoteMetaDataLog path = remoteMetaDataLogExt `S.isSuffixOf` path {- The filename of the remote content identifier log for a given key. -} remoteContentIdentifierLogFile :: GitConfig -> Key -> RawFilePath remoteContentIdentifierLogFile config key = - toRawFilePath (branchHashDir config key keyFile key) + (branchHashDir config key P. keyFile' key) <> remoteContentIdentifierExt remoteContentIdentifierExt :: S.ByteString diff --git a/P2P/Annex.hs b/P2P/Annex.hs index dd84668bf8..bcdde75cd1 100644 --- a/P2P/Annex.hs +++ b/P2P/Annex.hs @@ -47,7 +47,7 @@ runLocal runst runner a = case a of size <- liftIO $ catchDefaultIO 0 $ getFileSize f runner (next (Len size)) ContentSize k next -> do - let getsize = liftIO . catchMaybeIO . getFileSize + let getsize = liftIO . catchMaybeIO . getFileSize . fromRawFilePath size <- inAnnex' isJust Nothing getsize k runner (next (Len <$> size)) ReadContent k af o sender next -> do diff --git a/Remote/Adb.hs b/Remote/Adb.hs index 03e3819cff..e7e8fae3b9 100644 --- a/Remote/Adb.hs +++ b/Remote/Adb.hs @@ -212,7 +212,7 @@ androidHashDir :: AndroidPath -> Key -> AndroidPath androidHashDir adir k = AndroidPath $ fromAndroidPath adir ++ "/" ++ hdir where - hdir = replace [pathSeparator] "/" (hashDirLower def k) + hdir = replace [pathSeparator] "/" (fromRawFilePath (hashDirLower def k)) storeExportM :: AndroidSerial -> AndroidPath -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool storeExportM serial adir src _k loc _p = store' serial dest src diff --git a/Remote/Directory.hs b/Remote/Directory.hs index 0387474f9a..933ccd23ce 100644 --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -127,7 +127,7 @@ directorySetup _ mu _ c gc = do - We try more than one since we used to write to different hash - directories. -} locations :: FilePath -> Key -> [FilePath] -locations d k = map (d ) (keyPaths k) +locations d k = map (\f -> d fromRawFilePath f) (keyPaths k) {- Returns the location off a Key in the directory. If the key is - present, returns the location that is actually used, otherwise @@ -139,7 +139,8 @@ getLocation d k = do {- Directory where the file(s) for a key are stored. -} storeDir :: FilePath -> Key -> FilePath -storeDir d k = addTrailingPathSeparator $ d hashDirLower def k keyFile k +storeDir d k = addTrailingPathSeparator $ + d fromRawFilePath (hashDirLower def k) keyFile k {- Check if there is enough free disk space in the remote's directory to - store the key. Note that the unencrypted key size is checked. -} diff --git a/Remote/External.hs b/Remote/External.hs index 2b5c99457a..4c4c156848 100644 --- a/Remote/External.hs +++ b/Remote/External.hs @@ -383,9 +383,9 @@ handleRequest' st external req mp responsehandler handleRemoteRequest (PROGRESS bytesprocessed) = maybe noop (\a -> liftIO $ a bytesprocessed) mp handleRemoteRequest (DIRHASH k) = - send $ VALUE $ hashDirMixed def k + send $ VALUE $ fromRawFilePath $ hashDirMixed def k handleRemoteRequest (DIRHASH_LOWER k) = - send $ VALUE $ hashDirLower def k + send $ VALUE $ fromRawFilePath $ hashDirLower def k handleRemoteRequest (SETCONFIG setting value) = liftIO $ atomically $ modifyTVar' (externalConfig st) $ M.insert setting value diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs index 4682637eaf..c3a3f31348 100644 --- a/Remote/GCrypt.hs +++ b/Remote/GCrypt.hs @@ -422,7 +422,8 @@ checkKey' repo r rsyncopts k {- Annexed objects are hashed using lower-case directories for max - portability. -} gCryptLocation :: Git.Repo -> Key -> FilePath -gCryptLocation repo key = Git.repoLocation repo objectDir keyPath key (hashDirLower def) +gCryptLocation repo key = Git.repoLocation repo objectDir + fromRawFilePath (keyPath key (hashDirLower def)) data AccessMethod = AccessDirect | AccessShell diff --git a/Remote/Git.hs b/Remote/Git.hs index 459cd80d65..b6dd02ae5f 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -61,6 +61,7 @@ import Creds import Types.NumCopies import Annex.Action import Messages.Progress +import qualified Utility.RawFilePath as R #ifndef mingw32_HOST_OS import Utility.FileMode @@ -393,9 +394,9 @@ keyUrls gc repo r key = map tourl locs' | remoteAnnexBare remoteconfig == Just False = reverse (annexLocations gc key) | otherwise = annexLocations gc key #ifndef mingw32_HOST_OS - locs' = locs + locs' = map fromRawFilePath locs #else - locs' = map (replace "\\" "/") locs + locs' = map (replace "\\" "/" . fromRawFilePath) locs #endif remoteconfig = gitconfig r @@ -599,9 +600,9 @@ copyFromRemoteCheap' repo r st key af file | not $ Git.repoIsUrl repo = guardUsable repo (return False) $ do gc <- getGitConfigFromState st loc <- liftIO $ gitAnnexLocation key repo gc - liftIO $ ifM (doesFileExist loc) + liftIO $ ifM (R.doesPathExist loc) ( do - absloc <- absPath loc + absloc <- absPath (fromRawFilePath loc) catchBoolIO $ do createSymbolicLink absloc file return True diff --git a/Remote/Hook.hs b/Remote/Hook.hs index f0a67d808e..897e73cc1f 100644 --- a/Remote/Hook.hs +++ b/Remote/Hook.hs @@ -104,7 +104,8 @@ hookEnv action k f = Just <$> mergeenv (fileenv f ++ keyenv) ] fileenv Nothing = [] fileenv (Just file) = [envvar "FILE" file] - hashbits = map takeDirectory $ splitPath $ hashDirMixed def k + hashbits = map takeDirectory $ splitPath $ + fromRawFilePath $ hashDirMixed def k lookupHook :: HookName -> Action -> Annex (Maybe String) lookupHook hookname action = do diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs index 566f95bab6..f171b69e60 100644 --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -183,7 +183,7 @@ rsyncSetup _ mu _ c gc = do store :: RsyncOpts -> Key -> FilePath -> MeterUpdate -> Annex Bool store o k src meterupdate = storeGeneric o meterupdate basedest populatedest where - basedest = Prelude.head (keyPaths k) + basedest = fromRawFilePath $ Prelude.head (keyPaths k) populatedest dest = liftIO $ if canrename then do rename src dest @@ -222,7 +222,7 @@ remove :: RsyncOpts -> Remover remove o k = removeGeneric o includes where includes = concatMap use dirHashes - use h = let dir = h def k in + use h = let dir = fromRawFilePath (h def k) in [ parentDir dir , dir -- match content directory and anything in it diff --git a/Remote/Rsync/RsyncUrl.hs b/Remote/Rsync/RsyncUrl.hs index 4c2f10843c..2b0dbc1966 100644 --- a/Remote/Rsync/RsyncUrl.hs +++ b/Remote/Rsync/RsyncUrl.hs @@ -13,13 +13,14 @@ import Types import Annex.Locations import Utility.Rsync import Utility.SafeCommand - -import Data.Default -import System.FilePath.Posix +import Utility.FileSystemEncoding +import Annex.DirHashes #ifdef mingw32_HOST_OS import Utility.Split #endif -import Annex.DirHashes + +import Data.Default +import System.FilePath.Posix type RsyncUrl = String @@ -42,7 +43,7 @@ mkRsyncUrl o f = rsyncUrl o rsyncEscape o f rsyncUrls :: RsyncOpts -> Key -> [RsyncUrl] rsyncUrls o k = map use dirHashes where - use h = rsyncUrl o hash h rsyncEscape o (f f) + use h = rsyncUrl o fromRawFilePath (hash h) rsyncEscape o (f f) f = keyFile k #ifndef mingw32_HOST_OS hash h = h def k diff --git a/Remote/WebDAV/DavLocation.hs b/Remote/WebDAV/DavLocation.hs index 4464ed2d36..3893533a22 100644 --- a/Remote/WebDAV/DavLocation.hs +++ b/Remote/WebDAV/DavLocation.hs @@ -39,9 +39,9 @@ keyDir :: Key -> DavLocation keyDir k = addTrailingPathSeparator $ hashdir keyFile k where #ifndef mingw32_HOST_OS - hashdir = hashDirLower def k + hashdir = fromRawFilePath $ hashDirLower def k #else - hashdir = replace "\\" "/" (hashDirLower def k) + hashdir = replace "\\" "/" (fromRawFilePath $ hashDirLower def k) #endif keyLocation :: Key -> DavLocation diff --git a/Test.hs b/Test.hs index 4752ff07e2..7bcfdd3560 100644 --- a/Test.hs +++ b/Test.hs @@ -1638,7 +1638,8 @@ test_crypto = do checkFile mvariant filename = Utility.Gpg.checkEncryptionFile gpgcmd filename $ if mvariant == Just Types.Crypto.PubKey then ks else Nothing - serializeKeys cipher = Annex.Locations.keyPaths . + serializeKeys cipher = map fromRawFilePath . + Annex.Locations.keyPaths . Crypto.encryptKey Types.Crypto.HmacSha1 cipher #else test_crypto = putStrLn "gpg testing not implemented on Windows" diff --git a/Upgrade/V1.hs b/Upgrade/V1.hs index bad1183dfd..e311044664 100644 --- a/Upgrade/V1.hs +++ b/Upgrade/V1.hs @@ -236,9 +236,9 @@ logFile1 repo key = Upgrade.V2.gitStateDir repo ++ keyFile1 key ++ ".log" logFile2 :: Key -> Git.Repo -> String logFile2 = logFile' (hashDirLower def) -logFile' :: (Key -> FilePath) -> Key -> Git.Repo -> String +logFile' :: (Key -> RawFilePath) -> Key -> Git.Repo -> String logFile' hasher key repo = - gitStateDir repo ++ hasher key ++ keyFile key ++ ".log" + gitStateDir repo ++ fromRawFilePath (hasher key) ++ keyFile key ++ ".log" stateDir :: FilePath stateDir = addTrailingPathSeparator ".git-annex" diff --git a/Upgrade/V5.hs b/Upgrade/V5.hs index 7cbdd04e65..a8a84283b3 100644 --- a/Upgrade/V5.hs +++ b/Upgrade/V5.hs @@ -135,7 +135,7 @@ upgradeDirectWorkTree = do -- is just not populated with it. Since the work tree -- file is recorded as an associated file, things will -- still work that way, it's just not ideal. - ic <- withTSDelta (liftIO . genInodeCache f) + ic <- withTSDelta (liftIO . genInodeCache (toRawFilePath f)) void $ Content.linkToAnnex k f ic , unlessM (Content.inAnnex k) $ do -- Worktree file was deleted or modified; diff --git a/Upgrade/V5/Direct.hs b/Upgrade/V5/Direct.hs index baf7dae9a0..600efc616d 100644 --- a/Upgrade/V5/Direct.hs +++ b/Upgrade/V5/Direct.hs @@ -107,7 +107,9 @@ removeAssociatedFiles key = do - expected mtime and inode. -} goodContent :: Key -> FilePath -> Annex Bool -goodContent key file = sameInodeCache file =<< recordedInodeCache key +goodContent key file = + sameInodeCache (toRawFilePath file) + =<< recordedInodeCache key {- Gets the recorded inode cache for a key. - diff --git a/Utility/InodeCache.hs b/Utility/InodeCache.hs index a918e7bd08..d14d1f9d15 100644 --- a/Utility/InodeCache.hs +++ b/Utility/InodeCache.hs @@ -22,7 +22,6 @@ module Utility.InodeCache ( readInodeCache, showInodeCache, genInodeCache, - genInodeCache', toInodeCache, likeInodeCacheWeak, @@ -182,12 +181,8 @@ readInodeCache s = case words s of return $ InodeCache $ InodeCachePrim i sz (MTimeHighRes t) _ -> Nothing -genInodeCache :: FilePath -> TSDelta -> IO (Maybe InodeCache) +genInodeCache :: RawFilePath -> TSDelta -> IO (Maybe InodeCache) genInodeCache f delta = catchDefaultIO Nothing $ - toInodeCache delta f =<< getFileStatus f - -genInodeCache' :: RawFilePath -> TSDelta -> IO (Maybe InodeCache) -genInodeCache' f delta = catchDefaultIO Nothing $ toInodeCache delta (fromRawFilePath f) =<< R.getFileStatus f toInodeCache :: TSDelta -> FilePath -> FileStatus -> IO (Maybe InodeCache) @@ -208,8 +203,8 @@ toInodeCache (TSDelta getdelta) f s - Its InodeCache at the time of its creation is written to the cache file, - so changes can later be detected. -} data SentinalFile = SentinalFile - { sentinalFile :: FilePath - , sentinalCacheFile :: FilePath + { sentinalFile :: RawFilePath + , sentinalCacheFile :: RawFilePath } deriving (Show) @@ -226,8 +221,8 @@ noTSDelta = TSDelta (pure 0) writeSentinalFile :: SentinalFile -> IO () writeSentinalFile s = do - writeFile (sentinalFile s) "" - maybe noop (writeFile (sentinalCacheFile s) . showInodeCache) + writeFile (fromRawFilePath (sentinalFile s)) "" + maybe noop (writeFile (fromRawFilePath (sentinalCacheFile s)) . showInodeCache) =<< genInodeCache (sentinalFile s) noTSDelta data SentinalStatus = SentinalStatus @@ -256,7 +251,7 @@ checkSentinalFile s = do Just new -> return $ calc old new where loadoldcache = catchDefaultIO Nothing $ - readInodeCache <$> readFile (sentinalCacheFile s) + readInodeCache <$> readFile (fromRawFilePath (sentinalCacheFile s)) gennewcache = genInodeCache (sentinalFile s) noTSDelta calc (InodeCache (InodeCachePrim oldinode oldsize oldmtime)) (InodeCache (InodeCachePrim newinode newsize newmtime)) = SentinalStatus (not unchanged) tsdelta @@ -281,7 +276,7 @@ checkSentinalFile s = do dummy = SentinalStatus True noTSDelta sentinalFileExists :: SentinalFile -> IO Bool -sentinalFileExists s = allM doesFileExist [sentinalCacheFile s, sentinalFile s] +sentinalFileExists s = allM R.doesPathExist [sentinalCacheFile s, sentinalFile s] instance Arbitrary InodeCache where arbitrary = diff --git a/Utility/MD5.hs b/Utility/MD5.hs index d0475bf480..aabb5d724b 100644 --- a/Utility/MD5.hs +++ b/Utility/MD5.hs @@ -8,13 +8,14 @@ module Utility.MD5 where import Data.Bits import Data.Word +import Data.Char -display_32bits_as_dir :: Word32 -> String +display_32bits_as_dir :: Word32 -> [Word8] display_32bits_as_dir w = trim $ swap_pairs cs where -- Need 32 characters to use. To avoid inaverdently making -- a real word, use letters that appear less frequently. - chars = ['0'..'9'] ++ "zqjxkmvwgpfZQJXKMVWGPF" + chars = map (fromIntegral . ord) (['0'..'9'] ++ "zqjxkmvwgpfZQJXKMVWGPF") cs = map (\x -> getc $ (shiftR w (6*x)) .&. 31) [0..7] getc n = chars !! fromIntegral n swap_pairs (x1:x2:xs) = x2:x1:swap_pairs xs diff --git a/Utility/RawFilePath.hs b/Utility/RawFilePath.hs index a62ba65e51..426f5633a3 100644 --- a/Utility/RawFilePath.hs +++ b/Utility/RawFilePath.hs @@ -19,14 +19,20 @@ module Utility.RawFilePath ( readSymbolicLink, getFileStatus, getSymbolicLinkStatus, + doesPathExist, ) where #ifndef mingw32_HOST_OS import Utility.FileSystemEncoding (RawFilePath) import System.Posix.Files.ByteString + +doesPathExist :: RawFilePath -> IO Bool +doesPathExist = fileExist + #else import qualified Data.ByteString as B import qualified System.PosixCompat as P +import qualified System.Directory as D import Utility.FileSystemEncoding readSymbolicLink :: RawFilePath -> IO RawFilePath @@ -37,4 +43,7 @@ getFileStatus = P.getFileStatus . fromRawFilePath getSymbolicLinkStatus :: RawFilePath -> IO FileStatus getSymbolicLinkStatus = P.getSymbolicLinkStatus . fromRawFilePath + +doesPathExist :: RawFilePath -> IO Bool +doesPathExist = D.doesPathExist . fromRawFilePath #endif diff --git a/doc/todo/optimize_by_converting_String_to_ByteString.mdwn b/doc/todo/optimize_by_converting_String_to_ByteString.mdwn index 7ac7efe382..4a6d2b6dcd 100644 --- a/doc/todo/optimize_by_converting_String_to_ByteString.mdwn +++ b/doc/todo/optimize_by_converting_String_to_ByteString.mdwn @@ -11,26 +11,12 @@ than find so the improvement is not as large. The `bs` branch is in a mergeable state now, but still needs work: +* Profile various commands and look for hot spots. + * Eliminate all the fromRawFilePath, toRawFilePath, encodeBS, 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. Known hot spots: + some places where a value is converted back and forth several times. - * 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. It also needs a ByteString.readFile - for RawFilePath. - -* System.FilePath is not available for RawFilePath, and many of the - conversions are to get a FilePath in order to use that library. - - It should be entirely straightforward to make a version of System.FilePath - that can operate on RawFilePath, except possibly there could be some - complications due to Windows. - * Use versions of IO actions like getFileStatus that take a RawFilePath, avoiding a conversion. Note that these are only available on unix, not windows, so a compatability shim will be needed. diff --git a/doc/todo/optimize_by_converting_String_to_ByteString/comment_3_5cad0557a1409703f8c71078f0785309._comment b/doc/todo/optimize_by_converting_String_to_ByteString/comment_3_5cad0557a1409703f8c71078f0785309._comment new file mode 100644 index 0000000000..c888f617c0 --- /dev/null +++ b/doc/todo/optimize_by_converting_String_to_ByteString/comment_3_5cad0557a1409703f8c71078f0785309._comment @@ -0,0 +1,40 @@ +[[!comment format=mdwn + username="joey" + subject="""comment 3""" + date="2019-12-11T18:16:13Z" + content=""" +Updated profiling. git-annex find is now ByteString end-to-end! +Note the massive reduction in alloc, and improved runtime. + + Wed Dec 11 14:41 2019 Time and Allocation Profiling Report (Final) + + git-annex +RTS -p -RTS find + + total time = 1.51 secs (1515 ticks @ 1000 us, 1 processor) + total alloc = 608,475,328 bytes (excludes profiling overheads) + + COST CENTRE MODULE SRC %time %alloc + + keyFile' Annex.Locations Annex/Locations.hs:(590,1)-(600,30) 8.2 16.6 + >>=.\.succ' Data.Attoparsec.Internal.Types Data/Attoparsec/Internal/Types.hs:146:13-76 4.7 0.7 + getAnnexLinkTarget'.probesymlink Annex.Link Annex/Link.hs:79:9-46 4.2 7.6 + >>=.\ Data.Attoparsec.Internal.Types Data/Attoparsec/Internal/Types.hs:(146,9)-(147,44) 3.9 2.3 + parseLinkTarget Annex.Link Annex/Link.hs:(255,1)-(263,25) 3.9 11.8 + doesPathExist Utility.RawFilePath Utility/RawFilePath.hs:30:1-25 3.4 0.6 + keyFile'.esc Annex.Locations Annex/Locations.hs:(596,9)-(600,30) 3.2 14.7 + fileKey' Annex.Locations Annex/Locations.hs:(609,1)-(619,41) 3.0 4.7 + parseLinkTargetOrPointer Annex.Link Annex/Link.hs:(240,1)-(244,25) 2.8 0.2 + hashUpdates.\.\.\ Crypto.Hash Crypto/Hash.hs:85:48-99 2.5 0.1 + combineAlways System.FilePath.Posix.ByteString System/FilePath/Posix/../Internal.hs:(698,1)-(704,67) 2.0 3.3 + getState Annex Annex.hs:(251,1)-(254,27) 2.0 1.1 + withPtr.makeTrampoline Basement.Block.Base Basement/Block/Base.hs:(401,5)-(404,31) 1.9 1.7 + withMutablePtrHint Basement.Block.Base Basement/Block/Base.hs:(468,1)-(482,50) 1.8 1.2 + parseKeyVariety Types.Key Types/Key.hs:(323,1)-(371,42) 1.8 0.0 + fileKey'.go Annex.Locations Annex/Locations.hs:611:9-55 1.7 2.2 + isLinkToAnnex Annex.Link Annex/Link.hs:(299,1)-(305,47) 1.7 1.0 + hashDirMixed Annex.DirHashes Annex/DirHashes.hs:(82,1)-(90,27) 1.7 1.3 + primitive Basement.Monad Basement/Monad.hs:72:5-18 1.6 0.1 + withPtr Basement.Block.Base Basement/Block/Base.hs:(395,1)-(404,31) 1.5 1.6 + mkKeySerialization Types.Key Types/Key.hs:(115,1)-(117,22) 1.1 2.8 + decimal.step Data.Attoparsec.ByteString.Char8 Data/Attoparsec/ByteString/Char8.hs:448:9-49 0.8 1.2 +"""]] diff --git a/stack.yaml b/stack.yaml index d97bf2f263..dde1d76583 100644 --- a/stack.yaml +++ b/stack.yaml @@ -24,6 +24,7 @@ extra-deps: - sandi-0.5 - http-client-0.5.14 - silently-1.2.5.1 +- filepath-bytestring-1.4.2.1.0 explicit-setup-deps: git-annex: true resolver: lts-13.29 From cee0d738fc93e12e58f61f32d248862bd969f6f7 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 11 Dec 2019 17:08:08 -0400 Subject: [PATCH 29/42] match also / path separator on windows --- Annex/Journal.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Annex/Journal.hs b/Annex/Journal.hs index 937e183e22..b6124e2f72 100644 --- a/Annex/Journal.hs +++ b/Annex/Journal.hs @@ -112,7 +112,7 @@ journalFile :: RawFilePath -> Git.Repo -> RawFilePath journalFile file repo = gitAnnexJournalDir' repo P. S.map mangle file where mangle c - | c == P.pathSeparator = fromIntegral (ord '_') + | P.isPathSeparator c = fromIntegral (ord '_') | otherwise = c {- Converts a journal file (relative to the journal dir) back to the From 2e4de42d558de4f890b86c0506bfdc9e28144a8b Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 11 Dec 2019 17:08:26 -0400 Subject: [PATCH 30/42] bug in this branch --- doc/todo/optimize_by_converting_String_to_ByteString.mdwn | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/doc/todo/optimize_by_converting_String_to_ByteString.mdwn b/doc/todo/optimize_by_converting_String_to_ByteString.mdwn index 4a6d2b6dcd..fa92281686 100644 --- a/doc/todo/optimize_by_converting_String_to_ByteString.mdwn +++ b/doc/todo/optimize_by_converting_String_to_ByteString.mdwn @@ -11,6 +11,11 @@ than find so the improvement is not as large. The `bs` branch is in a mergeable state now, but still needs work: +* There's a bug impacting WORM keys with / in the keyname. + The files stored in the git-annex branch used to have the `/` changed + to `_`, but on the bs branch that does not happen. git also outputs + a message about "Ignoring" the file. + * Profile various commands and look for hot spots. * Eliminate all the fromRawFilePath, toRawFilePath, encodeBS, From 7a41f94e8435224e69c8ee82db87753500f1360e Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 11 Dec 2019 17:09:50 -0400 Subject: [PATCH 31/42] add test case for bug --- doc/todo/optimize_by_converting_String_to_ByteString.mdwn | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/doc/todo/optimize_by_converting_String_to_ByteString.mdwn b/doc/todo/optimize_by_converting_String_to_ByteString.mdwn index fa92281686..26e4c0a943 100644 --- a/doc/todo/optimize_by_converting_String_to_ByteString.mdwn +++ b/doc/todo/optimize_by_converting_String_to_ByteString.mdwn @@ -16,6 +16,11 @@ The `bs` branch is in a mergeable state now, but still needs work: to `_`, but on the bs branch that does not happen. git also outputs a message about "Ignoring" the file. + Test case: + + git config annex.backend WORM + git annex addurl http://localhost/~joey/index.html + * Profile various commands and look for hot spots. * Eliminate all the fromRawFilePath, toRawFilePath, encodeBS, From 8ed171c69f1b0428a606e20bf439f03d6d10da96 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 11 Dec 2019 17:12:13 -0400 Subject: [PATCH 32/42] more info for debugging --- doc/todo/optimize_by_converting_String_to_ByteString.mdwn | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/doc/todo/optimize_by_converting_String_to_ByteString.mdwn b/doc/todo/optimize_by_converting_String_to_ByteString.mdwn index 26e4c0a943..d190fd0508 100644 --- a/doc/todo/optimize_by_converting_String_to_ByteString.mdwn +++ b/doc/todo/optimize_by_converting_String_to_ByteString.mdwn @@ -21,6 +21,12 @@ The `bs` branch is in a mergeable state now, but still needs work: git config annex.backend WORM git annex addurl http://localhost/~joey/index.html + Hmm, that prints out the Ignoring message, and the file does not get + written to the git-annex branch. But in my big repo, I saw the message + and saw a file in the branch, with `/` in its keyname. Earlier in the + branch, the same key used `_`. (Look for "36bfe385607b32c4d5150404c0" to + find it again.) + * Profile various commands and look for hot spots. * Eliminate all the fromRawFilePath, toRawFilePath, encodeBS, From 3d38ec9585b5332a95f171388d5ea068954509e3 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 18 Dec 2019 11:29:34 -0400 Subject: [PATCH 33/42] fix fileJournal My ByteString rewrite oversimplified it, resulting in any _ in a journal file turning into a / in the git-annex branch, which was often the wrong filename, or sometimes (//) an invalid filename that git refused to add. --- Annex/Journal.hs | 29 ++++++++++++------- ...ze_by_converting_String_to_ByteString.mdwn | 18 ++---------- 2 files changed, 21 insertions(+), 26 deletions(-) diff --git a/Annex/Journal.hs b/Annex/Journal.hs index b6124e2f72..34b21d1129 100644 --- a/Annex/Journal.hs +++ b/Annex/Journal.hs @@ -100,29 +100,38 @@ journalDirty = do `catchIO` (const $ doesDirectoryExist d) {- Produces a filename to use in the journal for a file on the branch. - - - - The input filename is assumed to not contain any '_' character, - - since path separators are replaced with that. - - The journal typically won't have a lot of files in it, so the hashing - used in the branch is not necessary, and all the files are put directly - in the journal directory. -} journalFile :: RawFilePath -> Git.Repo -> RawFilePath -journalFile file repo = gitAnnexJournalDir' repo P. S.map mangle file +journalFile file repo = gitAnnexJournalDir' repo P. S.concatMap mangle file where mangle c - | P.isPathSeparator c = fromIntegral (ord '_') - | otherwise = c + | P.isPathSeparator c = S.singleton underscore + | c == underscore = S.pack [underscore, underscore] + | otherwise = S.singleton c + underscore = fromIntegral (ord '_') {- Converts a journal file (relative to the journal dir) back to the - filename on the branch. -} fileJournal :: RawFilePath -> RawFilePath -fileJournal = S.map unmangle +fileJournal = go where - unmangle c - | c == fromIntegral (ord '_') = P.pathSeparator - | otherwise = c + go b = + let (h, t) = S.break (== underscore) b + in h <> case S.uncons t of + Nothing -> t + Just (_u, t') -> case S.uncons t' of + Nothing -> t' + Just (w, t'') + | w == underscore -> + S.cons underscore (go t'') + | otherwise -> + S.cons P.pathSeparator (go t') + + underscore = fromIntegral (ord '_') {- Sentinal value, only produced by lockJournal; required - as a parameter by things that need to ensure the journal is diff --git a/doc/todo/optimize_by_converting_String_to_ByteString.mdwn b/doc/todo/optimize_by_converting_String_to_ByteString.mdwn index d190fd0508..036cc083cd 100644 --- a/doc/todo/optimize_by_converting_String_to_ByteString.mdwn +++ b/doc/todo/optimize_by_converting_String_to_ByteString.mdwn @@ -11,24 +11,10 @@ than find so the improvement is not as large. The `bs` branch is in a mergeable state now, but still needs work: -* There's a bug impacting WORM keys with / in the keyname. - The files stored in the git-annex branch used to have the `/` changed - to `_`, but on the bs branch that does not happen. git also outputs - a message about "Ignoring" the file. - - Test case: - - git config annex.backend WORM - git annex addurl http://localhost/~joey/index.html - - Hmm, that prints out the Ignoring message, and the file does not get - written to the git-annex branch. But in my big repo, I saw the message - and saw a file in the branch, with `/` in its keyname. Earlier in the - branch, the same key used `_`. (Look for "36bfe385607b32c4d5150404c0" to - find it again.) - * Profile various commands and look for hot spots. +* ByteString.Char8.putStrLn may truncate? + * Eliminate all the fromRawFilePath, toRawFilePath, encodeBS, decodeBS conversions. Or at least most of them. There are likely some places where a value is converted back and forth several times. From 0246ecbe948613799e4470ebd24f8a4d6253a0da Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 18 Dec 2019 12:12:51 -0400 Subject: [PATCH 34/42] update --- ...mize_by_converting_String_to_ByteString.mdwn | 17 ++++++----------- 1 file changed, 6 insertions(+), 11 deletions(-) diff --git a/doc/todo/optimize_by_converting_String_to_ByteString.mdwn b/doc/todo/optimize_by_converting_String_to_ByteString.mdwn index 036cc083cd..3cfab05107 100644 --- a/doc/todo/optimize_by_converting_String_to_ByteString.mdwn +++ b/doc/todo/optimize_by_converting_String_to_ByteString.mdwn @@ -9,17 +9,12 @@ Benchmarking `git-annex find`, speedups range from 28-66%. The files fly by much more snappily. Other commands likely also speed up, but do more work than find so the improvement is not as large. -The `bs` branch is in a mergeable state now, but still needs work: +The `bs` branch is in a mergeable state now, except for: -* Profile various commands and look for hot spots. +* filepath-bytestring probably has issues with utf16 filenames + on Windows. See its TODO. -* ByteString.Char8.putStrLn may truncate? +Stuff not entirely finished: -* Eliminate all the fromRawFilePath, toRawFilePath, encodeBS, - decodeBS conversions. Or at least most of them. There are likely - some places where a value is converted back and forth several times. - -* Use versions of IO actions like getFileStatus that take a RawFilePath, - avoiding a conversion. Note that these are only available on unix, not - windows, so a compatability shim will be needed. - (I can't seem to find any library that provides one.) +* Profile various commands and look for hot spots involving conversion + between RawFilePath and FilePath. From 322c542b5ce607eeb53a76f1280df3887e8efab6 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 18 Dec 2019 13:26:06 -0400 Subject: [PATCH 35/42] fix ByteString conversion on windows the encode' and decode' functions on Windows should not apply the filesystem encoding, which does not work there. Instead, convert to and from UTF-8. Also, avoid exporting encodeW8 and decodeW8. Both use the filesystem encoding, so won't work as expected on windows. --- Annex/Ssh.hs | 3 ++- Backend/Utilities.hs | 6 ++++-- Utility/FileSystemEncoding.hs | 20 ++++++++++++++++---- Utility/Metered.hs | 2 +- 4 files changed, 23 insertions(+), 8 deletions(-) diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs index a4cb5013eb..9fea51a929 100644 --- a/Annex/Ssh.hs +++ b/Annex/Ssh.hs @@ -43,6 +43,7 @@ import Annex.LockPool #endif import Control.Concurrent.STM +import qualified Data.ByteString as S {- Some ssh commands are fed stdin on a pipe and so should be allowed to - consume it. But ssh commands that are not piped stdin should generally @@ -325,7 +326,7 @@ sizeof_sockaddr_un_sun_path = 100 {- Note that this looks at the true length of the path in bytes, as it will - appear on disk. -} valid_unix_socket_path :: FilePath -> Bool -valid_unix_socket_path f = length (decodeW8 f) < sizeof_sockaddr_un_sun_path +valid_unix_socket_path f = S.length (encodeBS f) < sizeof_sockaddr_un_sun_path {- Parses the SSH port, and returns the other OpenSSH options. If - several ports are found, the last one takes precedence. -} diff --git a/Backend/Utilities.hs b/Backend/Utilities.hs index bcb0c4bda4..0baaa476c9 100644 --- a/Backend/Utilities.hs +++ b/Backend/Utilities.hs @@ -11,6 +11,7 @@ import Annex.Common import Utility.Hash import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L {- Generates a keyName from an input string. Takes care of sanitizing it. - If it's not too long, the full string is used as the keyName. @@ -21,11 +22,12 @@ genKeyName s -- Avoid making keys longer than the length of a SHA256 checksum. | bytelen > sha256len = encodeBS' $ truncateFilePath (sha256len - md5len - 1) s' ++ "-" ++ - show (md5 (encodeBL s)) + show (md5 bl) | otherwise = encodeBS' s' where s' = preSanitizeKeyName s - bytelen = length (decodeW8 s') + bl = encodeBL s + bytelen = fromIntegral $ L.length bl sha256len = 64 md5len = 32 diff --git a/Utility/FileSystemEncoding.hs b/Utility/FileSystemEncoding.hs index bb3738ed96..f9e98145a7 100644 --- a/Utility/FileSystemEncoding.hs +++ b/Utility/FileSystemEncoding.hs @@ -23,10 +23,6 @@ module Utility.FileSystemEncoding ( encodeBL', decodeBS', encodeBS', - decodeW8, - encodeW8, - encodeW8NUL, - decodeW8NUL, truncateFilePath, s2w8, w82s, @@ -148,16 +144,32 @@ encodeBS = S8.fromString {- Faster version that assumes the string does not contain NUL; - if it does it will be truncated before the NUL. -} decodeBS' :: S.ByteString -> FilePath +#ifndef mingw32_HOST_OS decodeBS' = encodeW8 . S.unpack +#else +decodeBS' = S8.toString +#endif encodeBS' :: FilePath -> S.ByteString +#ifndef mingw32_HOST_OS encodeBS' = S.pack . decodeW8 +#else +encodeBS' = S8.fromString +#endif decodeBL' :: L.ByteString -> FilePath +#ifndef mingw32_HOST_OS decodeBL' = encodeW8 . L.unpack +#else +decodeBL' = L8.toString +#endif encodeBL' :: FilePath -> L.ByteString +#ifndef mingw32_HOST_OS encodeBL' = L.pack . decodeW8 +#else +encodeBL' = L8.fromString +#endif {- Recent versions of the unix package have this alias; defined here - for backwards compatibility. -} diff --git a/Utility/Metered.hs b/Utility/Metered.hs index 53e253eccb..ec16e334c7 100644 --- a/Utility/Metered.hs +++ b/Utility/Metered.hs @@ -258,7 +258,7 @@ commandMeter' progressparser oh meterupdate cmd params = unless (quietMode oh) $ do S.hPut stdout b hFlush stdout - let s = encodeW8 (S.unpack b) + let s = decodeBS b let (mbytes, buf') = progressparser (buf++s) case mbytes of Nothing -> feedprogress prev buf' h From 75c40279c1600da157c2ba0981989da9eaf1c502 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 18 Dec 2019 13:33:18 -0400 Subject: [PATCH 36/42] use conversion functions from filepath-bytestring Behavior should be the same, but I'd hope to eventually get rid of most of Utility.FileSystemEncoding and this is a first step. --- Utility/FileSystemEncoding.hs | 15 +++------------ ...timize_by_converting_String_to_ByteString.mdwn | 5 +---- git-annex.cabal | 2 +- stack.yaml | 2 +- 4 files changed, 6 insertions(+), 18 deletions(-) diff --git a/Utility/FileSystemEncoding.hs b/Utility/FileSystemEncoding.hs index f9e98145a7..4c099ff3a4 100644 --- a/Utility/FileSystemEncoding.hs +++ b/Utility/FileSystemEncoding.hs @@ -43,6 +43,7 @@ import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.UTF8 as S8 import qualified Data.ByteString.Lazy.UTF8 as L8 #endif +import System.FilePath.ByteString (RawFilePath, encodeFilePath, decodeFilePath) import Utility.Exception import Utility.Split @@ -171,21 +172,11 @@ encodeBL' = L.pack . decodeW8 encodeBL' = L8.fromString #endif -{- Recent versions of the unix package have this alias; defined here - - for backwards compatibility. -} -type RawFilePath = S.ByteString - -{- Note that the RawFilePath is assumed to never contain NUL, - - since filename's don't. This should only be used with actual - - RawFilePaths not arbitrary ByteString that may contain NUL. -} fromRawFilePath :: RawFilePath -> FilePath -fromRawFilePath = decodeBS' +fromRawFilePath = decodeFilePath -{- Note that the FilePath is assumed to never contain NUL, - - since filename's don't. This should only be used with actual FilePaths - - not arbitrary String that may contain NUL. -} toRawFilePath :: FilePath -> RawFilePath -toRawFilePath = encodeBS' +toRawFilePath = encodeFilePath {- Converts a [Word8] to a FilePath, encoding using the filesystem encoding. - diff --git a/doc/todo/optimize_by_converting_String_to_ByteString.mdwn b/doc/todo/optimize_by_converting_String_to_ByteString.mdwn index 3cfab05107..9fcc9e5319 100644 --- a/doc/todo/optimize_by_converting_String_to_ByteString.mdwn +++ b/doc/todo/optimize_by_converting_String_to_ByteString.mdwn @@ -9,10 +9,7 @@ Benchmarking `git-annex find`, speedups range from 28-66%. The files fly by much more snappily. Other commands likely also speed up, but do more work than find so the improvement is not as large. -The `bs` branch is in a mergeable state now, except for: - -* filepath-bytestring probably has issues with utf16 filenames - on Windows. See its TODO. +The `bs` branch is in a mergeable state now. Stuff not entirely finished: diff --git a/git-annex.cabal b/git-annex.cabal index d18151368f..508781312e 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -320,7 +320,7 @@ Executable git-annex directory (>= 1.2), disk-free-space, filepath, - filepath-bytestring, + filepath-bytestring (>= 1.4.2.1.1), IfElse, hslogger, monad-logger, diff --git a/stack.yaml b/stack.yaml index dde1d76583..887fd68529 100644 --- a/stack.yaml +++ b/stack.yaml @@ -24,7 +24,7 @@ extra-deps: - sandi-0.5 - http-client-0.5.14 - silently-1.2.5.1 -- filepath-bytestring-1.4.2.1.0 +- filepath-bytestring-1.4.2.1.1 explicit-setup-deps: git-annex: true resolver: lts-13.29 From 1bc7055a213e6b2608bd33b96d11a07c8932bf29 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 18 Dec 2019 13:53:10 -0400 Subject: [PATCH 37/42] add back changelog entry --- CHANGELOG | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/CHANGELOG b/CHANGELOG index a3c748ce93..6c9ba624f9 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -4,6 +4,10 @@ git-annex (7.20191115) UNRELEASED; urgency=medium and whereis that only report on the state of the repository. Commands like get also sped up in cases where they have to check a lot of files but only transfer a few files. Speedups range from 30-100%. + * Sped up many git-annex commands that operate on many files, by + avoiding reserialization of keys. + find is 7% faster; whereis is 3% faster; and git-annex get when + all files are already present is 5% faster * Stop displaying rsync progress, and use git-annex's own progress display for local-to-local repo transfers. * git-lfs: The url provided to initremote/enableremote will now be From 007397a2c8e9152b81696d610c8695699a3ab42a Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 18 Dec 2019 14:46:05 -0400 Subject: [PATCH 38/42] added dep for custom-setup stack build failed w/o this though cabal old-build succeeded. --- git-annex.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/git-annex.cabal b/git-annex.cabal index 508781312e..52cea18f6a 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -296,6 +296,7 @@ source-repository head custom-setup Setup-Depends: base (>= 4.11.1.0), hslogger, split, unix-compat, process, filepath, exceptions, bytestring, directory, IfElse, data-default, + filepath-bytestring (>= 1.4.2.1.1), utf8-string, transformers, Cabal Executable git-annex From 7b7e0d8a863d1e980591266e9178d323cf830868 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 18 Dec 2019 15:19:19 -0400 Subject: [PATCH 39/42] wrap up --- ..._95f5afb616c7eba60473cdeb85a070b0._comment | 40 +++++++++++++++++++ ...ze_by_converting_String_to_ByteString.mdwn | 2 +- 2 files changed, 41 insertions(+), 1 deletion(-) create mode 100644 doc/profiling/comment_7_95f5afb616c7eba60473cdeb85a070b0._comment diff --git a/doc/profiling/comment_7_95f5afb616c7eba60473cdeb85a070b0._comment b/doc/profiling/comment_7_95f5afb616c7eba60473cdeb85a070b0._comment new file mode 100644 index 0000000000..05db73f4fb --- /dev/null +++ b/doc/profiling/comment_7_95f5afb616c7eba60473cdeb85a070b0._comment @@ -0,0 +1,40 @@ +[[!comment format=mdwn + username="joey" + subject="""comment 7""" + date="2019-12-18T19:18:04Z" + content=""" +Updated profiling. git-annex find is now ByteString end-to-end! +Note the massive reduction in alloc, and improved runtime. + + Wed Dec 11 14:41 2019 Time and Allocation Profiling Report (Final) + + git-annex +RTS -p -RTS find + + total time = 1.51 secs (1515 ticks @ 1000 us, 1 processor) + total alloc = 608,475,328 bytes (excludes profiling overheads) + + COST CENTRE MODULE SRC %time %alloc + + keyFile' Annex.Locations Annex/Locations.hs:(590,1)-(600,30) 8.2 16.6 + >>=.\.succ' Data.Attoparsec.Internal.Types Data/Attoparsec/Internal/Types.hs:146:13-76 4.7 0.7 + getAnnexLinkTarget'.probesymlink Annex.Link Annex/Link.hs:79:9-46 4.2 7.6 + >>=.\ Data.Attoparsec.Internal.Types Data/Attoparsec/Internal/Types.hs:(146,9)-(147,44) 3.9 2.3 + parseLinkTarget Annex.Link Annex/Link.hs:(255,1)-(263,25) 3.9 11.8 + doesPathExist Utility.RawFilePath Utility/RawFilePath.hs:30:1-25 3.4 0.6 + keyFile'.esc Annex.Locations Annex/Locations.hs:(596,9)-(600,30) 3.2 14.7 + fileKey' Annex.Locations Annex/Locations.hs:(609,1)-(619,41) 3.0 4.7 + parseLinkTargetOrPointer Annex.Link Annex/Link.hs:(240,1)-(244,25) 2.8 0.2 + hashUpdates.\.\.\ Crypto.Hash Crypto/Hash.hs:85:48-99 2.5 0.1 + combineAlways System.FilePath.Posix.ByteString System/FilePath/Posix/../Internal.hs:(698,1)-(704,67) 2.0 3.3 + getState Annex Annex.hs:(251,1)-(254,27) 2.0 1.1 + withPtr.makeTrampoline Basement.Block.Base Basement/Block/Base.hs:(401,5)-(404,31) 1.9 1.7 + withMutablePtrHint Basement.Block.Base Basement/Block/Base.hs:(468,1)-(482,50) 1.8 1.2 + parseKeyVariety Types.Key Types/Key.hs:(323,1)-(371,42) 1.8 0.0 + fileKey'.go Annex.Locations Annex/Locations.hs:611:9-55 1.7 2.2 + isLinkToAnnex Annex.Link Annex/Link.hs:(299,1)-(305,47) 1.7 1.0 + hashDirMixed Annex.DirHashes Annex/DirHashes.hs:(82,1)-(90,27) 1.7 1.3 + primitive Basement.Monad Basement/Monad.hs:72:5-18 1.6 0.1 + withPtr Basement.Block.Base Basement/Block/Base.hs:(395,1)-(404,31) 1.5 1.6 + mkKeySerialization Types.Key Types/Key.hs:(115,1)-(117,22) 1.1 2.8 + decimal.step Data.Attoparsec.ByteString.Char8 Data/Attoparsec/ByteString/Char8.hs:448:9-49 0.8 1.2 +"""]] diff --git a/doc/todo/optimize_by_converting_String_to_ByteString.mdwn b/doc/todo/optimize_by_converting_String_to_ByteString.mdwn index 9fcc9e5319..830f18d549 100644 --- a/doc/todo/optimize_by_converting_String_to_ByteString.mdwn +++ b/doc/todo/optimize_by_converting_String_to_ByteString.mdwn @@ -9,7 +9,7 @@ Benchmarking `git-annex find`, speedups range from 28-66%. The files fly by much more snappily. Other commands likely also speed up, but do more work than find so the improvement is not as large. -The `bs` branch is in a mergeable state now. +The `bs` branch is in a mergeable state now. [[done]] Stuff not entirely finished: From 16125694eb5648f6503fb84ff8959c198ab19cdc Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 18 Dec 2019 15:57:40 -0400 Subject: [PATCH 40/42] keep filename ByteString Minor optimisation, since it still has to be copied from lazy to strict, but it will add up when doing a big merge. --- Git/UnionMerge.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/Git/UnionMerge.hs b/Git/UnionMerge.hs index 85d9687e4c..e046895a1c 100644 --- a/Git/UnionMerge.hs +++ b/Git/UnionMerge.hs @@ -70,18 +70,18 @@ diffOpts = ["--raw", "-z", "-r", "--no-renames", "-l0"] doMerge :: HashObjectHandle -> CatFileHandle -> [String] -> Repo -> Streamer doMerge hashhandle ch differ repo streamer = do (diff, cleanup) <- pipeNullSplit (map Param differ) repo - go (map decodeBL' diff) + go diff void $ cleanup where go [] = noop - go (info:file:rest) = mergeFile info file hashhandle ch >>= + go (info:file:rest) = mergeFile (decodeBL' info) (L.toStrict file) hashhandle ch >>= maybe (go rest) (\l -> streamer l >> go rest) go (_:[]) = error $ "parse error " ++ show differ {- Given an info line from a git raw diff, and the filename, generates - a line suitable for update-index that union merges the two sides of the - diff. -} -mergeFile :: String -> FilePath -> HashObjectHandle -> CatFileHandle -> IO (Maybe L.ByteString) +mergeFile :: String -> RawFilePath -> HashObjectHandle -> CatFileHandle -> IO (Maybe L.ByteString) mergeFile info file hashhandle h = case filter (/= nullSha) [Ref asha, Ref bsha] of [] -> return Nothing (sha:[]) -> use sha @@ -91,7 +91,7 @@ mergeFile info file hashhandle h = case filter (/= nullSha) [Ref asha, Ref bsha] where [_colonmode, _bmode, asha, bsha, _status] = words info use sha = return $ Just $ - updateIndexLine sha TreeFile $ asTopFilePath $ toRawFilePath file + updateIndexLine sha TreeFile $ asTopFilePath file -- Get file and split into lines to union merge. -- The encoding of the file is assumed to be either ASCII or utf-8; -- in either case it's safe to split on \n From 9e9def2dc0a0b84a2f98805fd1c170fdc486cf16 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 18 Dec 2019 16:11:14 -0400 Subject: [PATCH 41/42] todo --- doc/todo/optimise_journal_access.mdwn | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) create mode 100644 doc/todo/optimise_journal_access.mdwn diff --git a/doc/todo/optimise_journal_access.mdwn b/doc/todo/optimise_journal_access.mdwn new file mode 100644 index 0000000000..a49441cf5e --- /dev/null +++ b/doc/todo/optimise_journal_access.mdwn @@ -0,0 +1,21 @@ +Often a command will need to read a number of files from the git-annex +branch, and it uses getJournalFile for each to check for any journalled +change that has not reached the branch. But typically, the journal is empty +and in such a case, that's a lot of time spent trying to open journal files +that DNE. + +Profiling eg, `git annex find --in web` shows things called by getJournalFile +use around 5% of runtime. + +What if, once at startup, it checked if the journal was entirely empty. +If so, it can remember that, and avoid reading journal files. +Perhaps paired with staging the journal if it's not empty. + +This could lead to behavior changes in some cases where one command is +writing changes and another command used to read them from the journal and +may no longer do so. But any such behavior change is of a behavior that +used to involve a race; the reader could just as well be ahead of the +writer and it would have already behaved as it would after the change. + +But: When a process writes to the journal, it will need to update its state +to remember it's no longer empty. --[[Joey]] From 686791c4ed948db37eee2bdc8dbcca5f539c1b1a Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 18 Dec 2019 16:45:03 -0400 Subject: [PATCH 42/42] more RawFilePath Remove dup definitions and just use the RawFilePath one. etc are enough faster that it's probably faster than building a String directly, although I have not benchmarked. --- Annex/Content.hs | 9 +- Annex/Content/LowLevel.hs | 2 +- Annex/Link.hs | 6 +- Annex/Locations.hs | 156 +++++++++--------- Annex/Perms.hs | 2 +- Annex/VariantFile.hs | 2 +- Assistant/Repair.hs | 2 +- Command/AddUnused.hs | 2 +- Command/Fsck.hs | 4 +- Command/Info.hs | 4 +- Command/Map.hs | 4 +- Command/Uninit.hs | 2 +- Database/Keys.hs | 5 +- Logs.hs | 18 +- Logs/Transfer.hs | 6 +- Remote/BitTorrent.hs | 4 +- Remote/Directory.hs | 7 +- Remote/Directory/LegacyChunked.hs | 2 +- Remote/GCrypt.hs | 4 +- Remote/Helper/Chunked/Legacy.hs | 2 +- Remote/Rsync.hs | 2 +- Remote/Rsync/RsyncUrl.hs | 2 +- Remote/WebDAV/DavLocation.hs | 6 +- Upgrade/V0.hs | 2 +- Upgrade/V1.hs | 2 +- ...imise_by_converting_Ref_to_ByteString.mdwn | 3 + 26 files changed, 140 insertions(+), 120 deletions(-) create mode 100644 doc/todo/optimise_by_converting_Ref_to_ByteString.mdwn diff --git a/Annex/Content.hs b/Annex/Content.hs index 74dd17886e..7c57cf5040 100644 --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -91,6 +91,8 @@ import Annex.Concurrent import Types.WorkerPool import qualified Utility.RawFilePath as R +import qualified System.FilePath.ByteString as P + {- Checks if a given key's content is currently present. -} inAnnex :: Key -> Annex Bool inAnnex key = inAnnexCheck key $ liftIO . R.doesPathExist @@ -742,7 +744,7 @@ listKeys keyloc = do if depth < 2 then do contents' <- filterM (present s) contents - let keys = mapMaybe (fileKey . takeFileName) contents' + let keys = mapMaybe (fileKey . P.takeFileName . toRawFilePath) contents' continue keys [] else do let deeper = walk s (depth - 1) @@ -816,7 +818,7 @@ dirKeys dirspec = do contents <- liftIO $ getDirectoryContents dir files <- liftIO $ filterM doesFileExist $ map (dir ) contents - return $ mapMaybe (fileKey . takeFileName) files + return $ mapMaybe (fileKey . P.takeFileName . toRawFilePath) files , return [] ) @@ -835,7 +837,8 @@ staleKeysPrune dirspec nottransferred = do dir <- fromRepo dirspec forM_ dups $ \k -> - pruneTmpWorkDirBefore (dir keyFile k) (liftIO . removeFile) + pruneTmpWorkDirBefore (dir fromRawFilePath (keyFile k)) + (liftIO . removeFile) if nottransferred then do diff --git a/Annex/Content/LowLevel.hs b/Annex/Content/LowLevel.hs index 546e647def..39e187de76 100644 --- a/Annex/Content/LowLevel.hs +++ b/Annex/Content/LowLevel.hs @@ -128,7 +128,7 @@ checkDiskSpace' need destdir key alreadythere samefilesystem = ifM (Annex.getSta _ -> return True ) where - dir = maybe (fromRepo gitAnnexDir) return destdir + dir = maybe (fromRawFilePath <$> fromRepo gitAnnexDir) return destdir needMoreDiskSpace :: Integer -> String needMoreDiskSpace n = "not enough free space, need " ++ diff --git a/Annex/Link.hs b/Annex/Link.hs index ede132a5b9..faed59f192 100644 --- a/Annex/Link.hs +++ b/Annex/Link.hs @@ -253,7 +253,7 @@ parseLinkTargetOrPointerLazy b = {- Parses a symlink target to a Key. -} parseLinkTarget :: S.ByteString -> Maybe Key parseLinkTarget l - | isLinkToAnnex l = fileKey' $ snd $ S8.breakEnd pathsep l + | isLinkToAnnex l = fileKey $ snd $ S8.breakEnd pathsep l | otherwise = Nothing where pathsep '/' = True @@ -263,9 +263,9 @@ parseLinkTarget l pathsep _ = False formatPointer :: Key -> S.ByteString -formatPointer k = prefix <> keyFile' k <> nl +formatPointer k = prefix <> keyFile k <> nl where - prefix = toInternalGitPath $ toRawFilePath (pathSeparator:objectDir) + prefix = toInternalGitPath $ P.pathSeparator `S.cons` objectDir' nl = S8.singleton '\n' {- Maximum size of a file that could be a pointer to a key. diff --git a/Annex/Locations.hs b/Annex/Locations.hs index 36858a72bb..bb8138f3fa 100644 --- a/Annex/Locations.hs +++ b/Annex/Locations.hs @@ -9,9 +9,7 @@ module Annex.Locations ( keyFile, - keyFile', fileKey, - fileKey', keyPaths, keyPath, annexDir, @@ -124,19 +122,16 @@ import qualified Utility.RawFilePath as R {- The directory git annex uses for local state, relative to the .git - directory -} -annexDir :: FilePath -annexDir = addTrailingPathSeparator "annex" - -annexDir' :: RawFilePath -annexDir' = P.addTrailingPathSeparator "annex" +annexDir :: RawFilePath +annexDir = P.addTrailingPathSeparator "annex" {- The directory git annex uses for locally available object content, - relative to the .git directory -} objectDir :: FilePath -objectDir = addTrailingPathSeparator $ annexDir "objects" +objectDir = fromRawFilePath objectDir' objectDir' :: RawFilePath -objectDir' = P.addTrailingPathSeparator $ annexDir' P. "objects" +objectDir' = P.addTrailingPathSeparator $ annexDir P. "objects" {- Annexed file's possible locations relative to the .git directory. - There are two different possibilities, using different hashes. @@ -260,46 +255,51 @@ gitAnnexInodeCache key r config = do return $ fromRawFilePath loc ++ ".cache" gitAnnexInodeSentinal :: Git.Repo -> RawFilePath -gitAnnexInodeSentinal r = gitAnnexDir' r P. "sentinal" +gitAnnexInodeSentinal r = gitAnnexDir r P. "sentinal" gitAnnexInodeSentinalCache :: Git.Repo -> RawFilePath gitAnnexInodeSentinalCache r = gitAnnexInodeSentinal r <> ".cache" {- The annex directory of a repository. -} -gitAnnexDir :: Git.Repo -> FilePath -gitAnnexDir r = addTrailingPathSeparator $ fromRawFilePath (Git.localGitDir r) annexDir - -gitAnnexDir' :: Git.Repo -> RawFilePath -gitAnnexDir' r = P.addTrailingPathSeparator $ Git.localGitDir r P. annexDir' +gitAnnexDir :: Git.Repo -> RawFilePath +gitAnnexDir r = P.addTrailingPathSeparator $ Git.localGitDir r P. annexDir {- The part of the annex directory where file contents are stored. -} gitAnnexObjectDir :: Git.Repo -> FilePath -gitAnnexObjectDir r = addTrailingPathSeparator $ fromRawFilePath (Git.localGitDir r) objectDir +gitAnnexObjectDir r = fromRawFilePath $ + P.addTrailingPathSeparator $ Git.localGitDir r P. objectDir' {- .git/annex/tmp/ is used for temp files for key's contents -} gitAnnexTmpObjectDir :: Git.Repo -> FilePath -gitAnnexTmpObjectDir r = addTrailingPathSeparator $ gitAnnexDir r "tmp" +gitAnnexTmpObjectDir = fromRawFilePath . gitAnnexTmpObjectDir' + +gitAnnexTmpObjectDir' :: Git.Repo -> RawFilePath +gitAnnexTmpObjectDir' r = P.addTrailingPathSeparator $ gitAnnexDir r P. "tmp" {- .git/annex/othertmp/ is used for other temp files -} gitAnnexTmpOtherDir :: Git.Repo -> FilePath -gitAnnexTmpOtherDir r = addTrailingPathSeparator $ gitAnnexDir r "othertmp" +gitAnnexTmpOtherDir r = fromRawFilePath $ + P.addTrailingPathSeparator $ gitAnnexDir r P. "othertmp" {- Lock file for gitAnnexTmpOtherDir. -} gitAnnexTmpOtherLock :: Git.Repo -> FilePath -gitAnnexTmpOtherLock r = gitAnnexDir r "othertmp.lck" +gitAnnexTmpOtherLock r = fromRawFilePath $ gitAnnexDir r P. "othertmp.lck" {- .git/annex/misctmp/ was used by old versions of git-annex and is still - used during initialization -} gitAnnexTmpOtherDirOld :: Git.Repo -> FilePath -gitAnnexTmpOtherDirOld r = addTrailingPathSeparator $ gitAnnexDir r "misctmp" +gitAnnexTmpOtherDirOld r = fromRawFilePath $ + P.addTrailingPathSeparator $ gitAnnexDir r P. "misctmp" {- .git/annex/watchtmp/ is used by the watcher and assistant -} gitAnnexTmpWatcherDir :: Git.Repo -> FilePath -gitAnnexTmpWatcherDir r = addTrailingPathSeparator $ gitAnnexDir r "watchtmp" +gitAnnexTmpWatcherDir r = fromRawFilePath $ + P.addTrailingPathSeparator $ gitAnnexDir r P. "watchtmp" {- The temp file to use for a given key's content. -} gitAnnexTmpObjectLocation :: Key -> Git.Repo -> FilePath -gitAnnexTmpObjectLocation key r = gitAnnexTmpObjectDir r keyFile key +gitAnnexTmpObjectLocation key r = fromRawFilePath $ + gitAnnexTmpObjectDir' r P. keyFile key {- Given a temp file such as gitAnnexTmpObjectLocation, makes a name for a - subdirectory in the same location, that can be used as a work area @@ -316,19 +316,21 @@ gitAnnexTmpWorkDir p = {- .git/annex/bad/ is used for bad files found during fsck -} gitAnnexBadDir :: Git.Repo -> FilePath -gitAnnexBadDir r = addTrailingPathSeparator $ gitAnnexDir r "bad" +gitAnnexBadDir r = fromRawFilePath $ + P.addTrailingPathSeparator $ gitAnnexDir r P. "bad" {- The bad file to use for a given key. -} gitAnnexBadLocation :: Key -> Git.Repo -> FilePath -gitAnnexBadLocation key r = gitAnnexBadDir r keyFile key +gitAnnexBadLocation key r = gitAnnexBadDir r fromRawFilePath (keyFile key) {- .git/annex/foounused is used to number possibly unused keys -} gitAnnexUnusedLog :: FilePath -> Git.Repo -> FilePath -gitAnnexUnusedLog prefix r = gitAnnexDir r (prefix ++ "unused") +gitAnnexUnusedLog prefix r = + fromRawFilePath (gitAnnexDir r) (prefix ++ "unused") {- .git/annex/keys/ contains a database of information about keys. -} gitAnnexKeysDb :: Git.Repo -> FilePath -gitAnnexKeysDb r = gitAnnexDir r "keys" +gitAnnexKeysDb r = fromRawFilePath $ gitAnnexDir r P. "keys" {- Lock file for the keys database. -} gitAnnexKeysDbLock :: Git.Repo -> FilePath @@ -342,7 +344,8 @@ gitAnnexKeysDbIndexCache r = gitAnnexKeysDb r ++ ".cache" {- .git/annex/fsck/uuid/ is used to store information about incremental - fscks. -} gitAnnexFsckDir :: UUID -> Git.Repo -> FilePath -gitAnnexFsckDir u r = gitAnnexDir r "fsck" fromUUID u +gitAnnexFsckDir u r = fromRawFilePath $ + gitAnnexDir r P. "fsck" P. fromUUID u {- used to store information about incremental fscks. -} gitAnnexFsckState :: UUID -> Git.Repo -> FilePath @@ -358,20 +361,21 @@ gitAnnexFsckDbLock u r = gitAnnexFsckDir u r "fsck.lck" {- .git/annex/fsckresults/uuid is used to store results of git fscks -} gitAnnexFsckResultsLog :: UUID -> Git.Repo -> FilePath -gitAnnexFsckResultsLog u r = gitAnnexDir r "fsckresults" fromUUID u +gitAnnexFsckResultsLog u r = fromRawFilePath $ + gitAnnexDir r P. "fsckresults" P. fromUUID u {- .git/annex/smudge.log is used to log smudges worktree files that need to - be updated. -} gitAnnexSmudgeLog :: Git.Repo -> FilePath -gitAnnexSmudgeLog r = gitAnnexDir r "smudge.log" +gitAnnexSmudgeLog r = fromRawFilePath $ gitAnnexDir r P. "smudge.log" gitAnnexSmudgeLock :: Git.Repo -> FilePath -gitAnnexSmudgeLock r = gitAnnexDir r "smudge.lck" +gitAnnexSmudgeLock r = fromRawFilePath $ gitAnnexDir r P. "smudge.lck" {- .git/annex/export/uuid/ is used to store information about - exports to special remotes. -} gitAnnexExportDir :: UUID -> Git.Repo -> FilePath -gitAnnexExportDir u r = gitAnnexDir r "export" fromUUID u +gitAnnexExportDir u r = fromRawFilePath (gitAnnexDir r) "export" fromUUID u {- Directory containing database used to record export info. -} gitAnnexExportDbDir :: UUID -> Git.Repo -> FilePath @@ -388,7 +392,8 @@ gitAnnexExportUpdateLock u r = gitAnnexExportDbDir u r ++ ".upl" {- Log file used to keep track of files that were in the tree exported to a - remote, but were excluded by its preferred content settings. -} gitAnnexExportExcludeLog :: UUID -> Git.Repo -> FilePath -gitAnnexExportExcludeLog u r = gitAnnexDir r "export.ex" fromUUID u +gitAnnexExportExcludeLog u r = fromRawFilePath $ + gitAnnexDir r P. "export.ex" P. fromUUID u {- Directory containing database used to record remote content ids. - @@ -396,7 +401,7 @@ gitAnnexExportExcludeLog u r = gitAnnexDir r "export.ex" fromUUID u - need to be rebuilt with a new name.) -} gitAnnexContentIdentifierDbDir :: Git.Repo -> FilePath -gitAnnexContentIdentifierDbDir r = gitAnnexDir r "cids" +gitAnnexContentIdentifierDbDir r = fromRawFilePath $ gitAnnexDir r P. "cids" {- Lock file for writing to the content id database. -} gitAnnexContentIdentifierLock :: Git.Repo -> FilePath @@ -405,128 +410,137 @@ gitAnnexContentIdentifierLock r = gitAnnexContentIdentifierDbDir r ++ ".lck" {- .git/annex/schedulestate is used to store information about when - scheduled jobs were last run. -} gitAnnexScheduleState :: Git.Repo -> FilePath -gitAnnexScheduleState r = gitAnnexDir r "schedulestate" +gitAnnexScheduleState r = fromRawFilePath $ gitAnnexDir r P. "schedulestate" {- .git/annex/creds/ is used to store credentials to access some special - remotes. -} gitAnnexCredsDir :: Git.Repo -> FilePath -gitAnnexCredsDir r = addTrailingPathSeparator $ gitAnnexDir r "creds" +gitAnnexCredsDir r = fromRawFilePath $ + P.addTrailingPathSeparator $ gitAnnexDir r P. "creds" {- .git/annex/certificate.pem and .git/annex/key.pem are used by the webapp - when HTTPS is enabled -} gitAnnexWebCertificate :: Git.Repo -> FilePath -gitAnnexWebCertificate r = gitAnnexDir r "certificate.pem" +gitAnnexWebCertificate r = fromRawFilePath $ gitAnnexDir r P. "certificate.pem" gitAnnexWebPrivKey :: Git.Repo -> FilePath -gitAnnexWebPrivKey r = gitAnnexDir r "privkey.pem" +gitAnnexWebPrivKey r = fromRawFilePath $ gitAnnexDir r P. "privkey.pem" {- .git/annex/feeds/ is used to record per-key (url) state by importfeeds -} gitAnnexFeedStateDir :: Git.Repo -> FilePath -gitAnnexFeedStateDir r = addTrailingPathSeparator $ gitAnnexDir r "feedstate" +gitAnnexFeedStateDir r = fromRawFilePath $ + P.addTrailingPathSeparator $ gitAnnexDir r P. "feedstate" gitAnnexFeedState :: Key -> Git.Repo -> FilePath -gitAnnexFeedState k r = gitAnnexFeedStateDir r keyFile k +gitAnnexFeedState k r = gitAnnexFeedStateDir r fromRawFilePath (keyFile k) {- .git/annex/merge/ is used as a empty work tree for direct mode merges and - merges in adjusted branches. -} gitAnnexMergeDir :: Git.Repo -> FilePath -gitAnnexMergeDir r = addTrailingPathSeparator $ gitAnnexDir r "merge" +gitAnnexMergeDir r = fromRawFilePath $ + P.addTrailingPathSeparator $ gitAnnexDir r P. "merge" {- .git/annex/transfer/ is used to record keys currently - being transferred, and other transfer bookkeeping info. -} gitAnnexTransferDir :: Git.Repo -> FilePath -gitAnnexTransferDir r = addTrailingPathSeparator $ gitAnnexDir r "transfer" +gitAnnexTransferDir r = fromRawFilePath $ + P.addTrailingPathSeparator $ gitAnnexDir r P. "transfer" {- .git/annex/journal/ is used to journal changes made to the git-annex - branch -} gitAnnexJournalDir :: Git.Repo -> FilePath -gitAnnexJournalDir r = addTrailingPathSeparator $ gitAnnexDir r "journal" +gitAnnexJournalDir r = fromRawFilePath $ + P.addTrailingPathSeparator $ gitAnnexDir r P. "journal" gitAnnexJournalDir' :: Git.Repo -> RawFilePath -gitAnnexJournalDir' r = P.addTrailingPathSeparator $ gitAnnexDir' r P. "journal" +gitAnnexJournalDir' r = P.addTrailingPathSeparator $ gitAnnexDir r P. "journal" {- Lock file for the journal. -} gitAnnexJournalLock :: Git.Repo -> FilePath -gitAnnexJournalLock r = gitAnnexDir r "journal.lck" +gitAnnexJournalLock r = fromRawFilePath $ gitAnnexDir r P. "journal.lck" {- Lock file for flushing a git queue that writes to the git index or - other git state that should only have one writer at a time. -} gitAnnexGitQueueLock :: Git.Repo -> FilePath -gitAnnexGitQueueLock r = gitAnnexDir r "gitqueue.lck" +gitAnnexGitQueueLock r = fromRawFilePath $ gitAnnexDir r P. "gitqueue.lck" {- Lock file for the pre-commit hook. -} gitAnnexPreCommitLock :: Git.Repo -> FilePath -gitAnnexPreCommitLock r = gitAnnexDir r "precommit.lck" +gitAnnexPreCommitLock r = fromRawFilePath $ gitAnnexDir r P. "precommit.lck" {- Lock file for direct mode merge. -} gitAnnexMergeLock :: Git.Repo -> FilePath -gitAnnexMergeLock r = gitAnnexDir r "merge.lck" +gitAnnexMergeLock r = fromRawFilePath $ gitAnnexDir r P. "merge.lck" {- .git/annex/index is used to stage changes to the git-annex branch -} gitAnnexIndex :: Git.Repo -> FilePath -gitAnnexIndex r = gitAnnexDir r "index" +gitAnnexIndex r = fromRawFilePath $ gitAnnexDir r P. "index" {- Holds the ref of the git-annex branch that the index was last updated to. - - The .lck in the name is a historical accident; this is not used as a - lock. -} gitAnnexIndexStatus :: Git.Repo -> FilePath -gitAnnexIndexStatus r = gitAnnexDir r "index.lck" +gitAnnexIndexStatus r = fromRawFilePath $ gitAnnexDir r P. "index.lck" {- The index file used to generate a filtered branch view._-} gitAnnexViewIndex :: Git.Repo -> FilePath -gitAnnexViewIndex r = gitAnnexDir r "viewindex" +gitAnnexViewIndex r = fromRawFilePath $ gitAnnexDir r P. "viewindex" {- File containing a log of recently accessed views. -} gitAnnexViewLog :: Git.Repo -> FilePath -gitAnnexViewLog r = gitAnnexDir r "viewlog" +gitAnnexViewLog r = fromRawFilePath $ gitAnnexDir r P. "viewlog" {- List of refs that have already been merged into the git-annex branch. -} gitAnnexMergedRefs :: Git.Repo -> FilePath -gitAnnexMergedRefs r = gitAnnexDir r "mergedrefs" +gitAnnexMergedRefs r = fromRawFilePath $ gitAnnexDir r P. "mergedrefs" {- List of refs that should not be merged into the git-annex branch. -} gitAnnexIgnoredRefs :: Git.Repo -> FilePath -gitAnnexIgnoredRefs r = gitAnnexDir r "ignoredrefs" +gitAnnexIgnoredRefs r = fromRawFilePath $ gitAnnexDir r P. "ignoredrefs" {- Pid file for daemon mode. -} gitAnnexPidFile :: Git.Repo -> FilePath -gitAnnexPidFile r = gitAnnexDir r "daemon.pid" +gitAnnexPidFile r = fromRawFilePath $ gitAnnexDir r P. "daemon.pid" {- Pid lock file for pidlock mode -} gitAnnexPidLockFile :: Git.Repo -> FilePath -gitAnnexPidLockFile r = gitAnnexDir r "pidlock" +gitAnnexPidLockFile r = fromRawFilePath $ gitAnnexDir r P. "pidlock" {- Status file for daemon mode. -} gitAnnexDaemonStatusFile :: Git.Repo -> FilePath -gitAnnexDaemonStatusFile r = gitAnnexDir r "daemon.status" +gitAnnexDaemonStatusFile r = fromRawFilePath $ + gitAnnexDir r P. "daemon.status" {- Log file for daemon mode. -} gitAnnexLogFile :: Git.Repo -> FilePath -gitAnnexLogFile r = gitAnnexDir r "daemon.log" +gitAnnexLogFile r = fromRawFilePath $ gitAnnexDir r P. "daemon.log" {- Log file for fuzz test. -} gitAnnexFuzzTestLogFile :: Git.Repo -> FilePath -gitAnnexFuzzTestLogFile r = gitAnnexDir r "fuzztest.log" +gitAnnexFuzzTestLogFile r = fromRawFilePath $ + gitAnnexDir r P. "fuzztest.log" {- Html shim file used to launch the webapp. -} gitAnnexHtmlShim :: Git.Repo -> FilePath -gitAnnexHtmlShim r = gitAnnexDir r "webapp.html" +gitAnnexHtmlShim r = fromRawFilePath $ gitAnnexDir r P. "webapp.html" {- File containing the url to the webapp. -} gitAnnexUrlFile :: Git.Repo -> FilePath -gitAnnexUrlFile r = gitAnnexDir r "url" +gitAnnexUrlFile r = fromRawFilePath $ gitAnnexDir r P. "url" {- Temporary file used to edit configuriation from the git-annex branch. -} gitAnnexTmpCfgFile :: Git.Repo -> FilePath -gitAnnexTmpCfgFile r = gitAnnexDir r "config.tmp" +gitAnnexTmpCfgFile r = fromRawFilePath $ gitAnnexDir r P. "config.tmp" {- .git/annex/ssh/ is used for ssh connection caching -} gitAnnexSshDir :: Git.Repo -> FilePath -gitAnnexSshDir r = addTrailingPathSeparator $ gitAnnexDir r "ssh" +gitAnnexSshDir r = fromRawFilePath $ + P.addTrailingPathSeparator $ gitAnnexDir r P. "ssh" {- .git/annex/remotes/ is used for remote-specific state. -} gitAnnexRemotesDir :: Git.Repo -> FilePath -gitAnnexRemotesDir r = addTrailingPathSeparator $ gitAnnexDir r "remotes" +gitAnnexRemotesDir r = fromRawFilePath $ + P.addTrailingPathSeparator $ gitAnnexDir r P. "remotes" {- This is the base directory name used by the assistant when making - repositories, by default. -} @@ -583,11 +597,8 @@ reSanitizeKeyName = preSanitizeKeyName' True - Changing what this function escapes and how is not a good idea, as it - can cause existing objects to get lost. -} -keyFile :: Key -> FilePath -keyFile = fromRawFilePath . keyFile' - -keyFile' :: Key -> RawFilePath -keyFile' k = +keyFile :: Key -> RawFilePath +keyFile k = let b = serializeKey' k in if S8.any (`elem` ['&', '%', ':', '/']) b then S8.concatMap esc b @@ -602,11 +613,8 @@ keyFile' k = {- Reverses keyFile, converting a filename fragment (ie, the basename of - the symlink target) into a key. -} -fileKey :: FilePath -> Maybe Key -fileKey = fileKey' . toRawFilePath - -fileKey' :: RawFilePath -> Maybe Key -fileKey' = deserializeKey' . S8.intercalate "/" . map go . S8.split '%' +fileKey :: RawFilePath -> Maybe Key +fileKey = deserializeKey' . S8.intercalate "/" . map go . S8.split '%' where go = S8.concat . unescafterfirst . S8.split '&' unescafterfirst [] = [] @@ -628,7 +636,7 @@ fileKey' = deserializeKey' . S8.intercalate "/" . map go . S8.split '%' keyPath :: Key -> Hasher -> RawFilePath keyPath key hasher = hasher key P. f P. f where - f = keyFile' key + f = keyFile key {- All possibile locations to store a key in a special remote - using different directory hashes. diff --git a/Annex/Perms.hs b/Annex/Perms.hs index d2b270dd40..a24e0362f0 100644 --- a/Annex/Perms.hs +++ b/Annex/Perms.hs @@ -70,7 +70,7 @@ annexFileMode = withShared $ return . go createAnnexDirectory :: FilePath -> Annex () createAnnexDirectory dir = walk dir [] =<< top where - top = parentDir <$> fromRepo gitAnnexDir + top = parentDir . fromRawFilePath <$> fromRepo gitAnnexDir walk d below stop | d `equalFilePath` stop = done | otherwise = ifM (liftIO $ doesDirectoryExist d) diff --git a/Annex/VariantFile.hs b/Annex/VariantFile.hs index 65f989ebae..781732368d 100644 --- a/Annex/VariantFile.hs +++ b/Annex/VariantFile.hs @@ -36,7 +36,7 @@ mkVariant file variant = takeDirectory file -} variantFile :: FilePath -> Key -> FilePath variantFile file key - | doubleconflict = mkVariant file (keyFile key) + | doubleconflict = mkVariant file (fromRawFilePath (keyFile key)) | otherwise = mkVariant file (shortHash $ serializeKey' key) where doubleconflict = variantMarker `isInfixOf` file diff --git a/Assistant/Repair.hs b/Assistant/Repair.hs index f8e7bedcec..a96921796c 100644 --- a/Assistant/Repair.hs +++ b/Assistant/Repair.hs @@ -130,7 +130,7 @@ repairStaleGitLocks r = do repairStaleLocks lockfiles return $ not $ null lockfiles where - findgitfiles = dirContentsRecursiveSkipping (== dropTrailingPathSeparator annexDir) True . fromRawFilePath . Git.localGitDir + findgitfiles = dirContentsRecursiveSkipping (== dropTrailingPathSeparator (fromRawFilePath annexDir)) True . fromRawFilePath . Git.localGitDir islock f | "gc.pid" `isInfixOf` f = False | ".lock" `isSuffixOf` f = True diff --git a/Command/AddUnused.hs b/Command/AddUnused.hs index 025b25e4d0..b14e85bde5 100644 --- a/Command/AddUnused.hs +++ b/Command/AddUnused.hs @@ -31,7 +31,7 @@ perform key = next $ do addLink file key Nothing return True where - file = "unused." ++ keyFile key + file = "unused." ++ fromRawFilePath (keyFile key) {- The content is not in the annex, but in another directory, and - it seems better to error out, rather than moving bad/tmp content into diff --git a/Command/Fsck.hs b/Command/Fsck.hs index 3010a6ce37..65c0112ea7 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -164,7 +164,7 @@ performRemote key afile backend numcopies remote = pid <- liftIO getPID t <- fromRepo gitAnnexTmpObjectDir createAnnexDirectory t - let tmp = t "fsck" ++ show pid ++ "." ++ keyFile key + let tmp = t "fsck" ++ show pid ++ "." ++ fromRawFilePath (keyFile key) let cleanup = liftIO $ catchIO (removeFile tmp) (const noop) cleanup cleanup `after` a tmp @@ -516,7 +516,7 @@ badContent key = do badContentRemote :: Remote -> FilePath -> Key -> Annex String badContentRemote remote localcopy key = do bad <- fromRepo gitAnnexBadDir - let destbad = bad keyFile key + let destbad = bad fromRawFilePath (keyFile key) movedbad <- ifM (inAnnex key <||> liftIO (doesFileExist destbad)) ( return False , do diff --git a/Command/Info.hs b/Command/Info.hs index 94292077f8..3448ee6ef2 100644 --- a/Command/Info.hs +++ b/Command/Info.hs @@ -454,7 +454,7 @@ disk_size :: Stat disk_size = simpleStat "available local disk space" $ calcfree <$> (lift $ annexDiskReserve <$> Annex.getGitConfig) - <*> (lift $ inRepo $ getDiskFree . gitAnnexDir) + <*> (lift $ inRepo $ getDiskFree . fromRawFilePath . gitAnnexDir) <*> mkSizer where calcfree reserve (Just have) sizer = unwords @@ -674,7 +674,7 @@ staleSize label dirspec = go =<< lift (dirKeys dirspec) keysizes keys = do dir <- lift $ fromRepo dirspec liftIO $ forM keys $ \k -> catchDefaultIO 0 $ - getFileSize (dir keyFile k) + getFileSize (dir fromRawFilePath (keyFile k)) aside :: String -> String aside s = " (" ++ s ++ ")" diff --git a/Command/Map.hs b/Command/Map.hs index de2a0c6dd6..c35ad6870d 100644 --- a/Command/Map.hs +++ b/Command/Map.hs @@ -46,7 +46,9 @@ start = startingNoMessage (ActionItemOther Nothing) $ do umap <- uuidDescMap trustmap <- trustMapLoad - file <- () <$> fromRepo gitAnnexDir <*> pure "map.dot" + file <- () + <$> fromRepo (fromRawFilePath . gitAnnexDir) + <*> pure "map.dot" liftIO $ writeFile file (drawMap rs trustmap umap) next $ diff --git a/Command/Uninit.hs b/Command/Uninit.hs index 29278a6c4e..ff9c4d3880 100644 --- a/Command/Uninit.hs +++ b/Command/Uninit.hs @@ -58,7 +58,7 @@ startCheckIncomplete file _ = giveup $ unlines finish :: Annex () finish = do - annexdir <- fromRepo gitAnnexDir + annexdir <- fromRawFilePath <$> fromRepo gitAnnexDir annexobjectdir <- fromRepo gitAnnexObjectDir leftovers <- removeUnannexed =<< listKeys InAnnex prepareRemoveAnnexDir annexdir diff --git a/Database/Keys.hs b/Database/Keys.hs index 48d51caf4e..afbe7191d5 100644 --- a/Database/Keys.hs +++ b/Database/Keys.hs @@ -43,6 +43,9 @@ import Git.Command import Git.Types import Git.Index +import qualified Data.ByteString as S +import qualified System.FilePath.ByteString as P + {- Runs an action that reads from the database. - - If the database doesn't already exist, it's not created; mempty is @@ -263,7 +266,7 @@ reconcileStaged qh = do -- pointer file. And a pointer file that is replaced with -- a non-pointer file will match this. , Param $ "-G^" ++ fromRawFilePath (toInternalGitPath $ - toRawFilePath (pathSeparator:objectDir)) + P.pathSeparator `S.cons` objectDir') -- Don't include files that were deleted, because this only -- wants to update information for files that are present -- in the index. diff --git a/Logs.hs b/Logs.hs index 18a045b452..5faec561ef 100644 --- a/Logs.hs +++ b/Logs.hs @@ -119,18 +119,18 @@ exportLog = "export.log" {- The pathname of the location log file for a given key. -} locationLogFile :: GitConfig -> Key -> RawFilePath locationLogFile config key = - branchHashDir config key P. keyFile' key <> ".log" + branchHashDir config key P. keyFile key <> ".log" {- The filename of the url log for a given key. -} urlLogFile :: GitConfig -> Key -> RawFilePath urlLogFile config key = - branchHashDir config key P. keyFile' key <> urlLogExt + branchHashDir config key P. keyFile key <> urlLogExt {- Old versions stored the urls elsewhere. -} oldurlLogs :: GitConfig -> Key -> [RawFilePath] oldurlLogs config key = [ "remote/web" P. hdir P. serializeKey' key <> ".log" - , "remote/web" P. hdir P. keyFile' key <> ".log" + , "remote/web" P. hdir P. keyFile key <> ".log" ] where hdir = branchHashDir config key @@ -145,7 +145,7 @@ isUrlLog file = urlLogExt `S.isSuffixOf` file {- The filename of the remote state log for a given key. -} remoteStateLogFile :: GitConfig -> Key -> RawFilePath remoteStateLogFile config key = - (branchHashDir config key P. keyFile' key) + (branchHashDir config key P. keyFile key) <> remoteStateLogExt remoteStateLogExt :: S.ByteString @@ -157,7 +157,7 @@ isRemoteStateLog path = remoteStateLogExt `S.isSuffixOf` path {- The filename of the chunk log for a given key. -} chunkLogFile :: GitConfig -> Key -> RawFilePath chunkLogFile config key = - (branchHashDir config key P. keyFile' key) + (branchHashDir config key P. keyFile key) <> chunkLogExt chunkLogExt :: S.ByteString @@ -169,7 +169,7 @@ isChunkLog path = chunkLogExt `S.isSuffixOf` path {- The filename of the metadata log for a given key. -} metaDataLogFile :: GitConfig -> Key -> RawFilePath metaDataLogFile config key = - (branchHashDir config key P. keyFile' key) + (branchHashDir config key P. keyFile key) <> metaDataLogExt metaDataLogExt :: S.ByteString @@ -181,7 +181,7 @@ isMetaDataLog path = metaDataLogExt `S.isSuffixOf` path {- The filename of the remote metadata log for a given key. -} remoteMetaDataLogFile :: GitConfig -> Key -> RawFilePath remoteMetaDataLogFile config key = - (branchHashDir config key P. keyFile' key) + (branchHashDir config key P. keyFile key) <> remoteMetaDataLogExt remoteMetaDataLogExt :: S.ByteString @@ -193,7 +193,7 @@ isRemoteMetaDataLog path = remoteMetaDataLogExt `S.isSuffixOf` path {- The filename of the remote content identifier log for a given key. -} remoteContentIdentifierLogFile :: GitConfig -> Key -> RawFilePath remoteContentIdentifierLogFile config key = - (branchHashDir config key P. keyFile' key) + (branchHashDir config key P. keyFile key) <> remoteContentIdentifierExt remoteContentIdentifierExt :: S.ByteString @@ -205,7 +205,7 @@ isRemoteContentIdentifierLog path = remoteContentIdentifierExt `S.isSuffixOf` pa {- From an extension and a log filename, get the key that it's a log for. -} extLogFileKey :: S.ByteString -> RawFilePath -> Maybe Key extLogFileKey expectedext path - | encodeBS' ext == expectedext = fileKey base + | encodeBS' ext == expectedext = fileKey (toRawFilePath base) | otherwise = Nothing where file = takeFileName (fromRawFilePath path) diff --git a/Logs/Transfer.hs b/Logs/Transfer.hs index 2dabe5cf34..ab9a8ca61b 100644 --- a/Logs/Transfer.hs +++ b/Logs/Transfer.hs @@ -195,12 +195,12 @@ recordFailedTransfer t info = do transferFile :: Transfer -> Git.Repo -> FilePath transferFile (Transfer direction u kd) r = transferDir direction r filter (/= '/') (fromUUID u) - keyFile (mkKey (const kd)) + fromRawFilePath (keyFile (mkKey (const kd))) {- The transfer information file to use to record a failed Transfer -} failedTransferFile :: Transfer -> Git.Repo -> FilePath failedTransferFile (Transfer direction u kd) r = failedTransferDir u direction r - keyFile (mkKey (const kd)) + fromRawFilePath (keyFile (mkKey (const kd))) {- The transfer lock file corresponding to a given transfer info file. -} transferLockFile :: FilePath -> FilePath @@ -215,7 +215,7 @@ parseTransferFile file [direction, u, key] -> Transfer <$> parseDirection direction <*> pure (toUUID u) - <*> fmap (fromKey id) (fileKey key) + <*> fmap (fromKey id) (fileKey (toRawFilePath key)) _ -> Nothing where bits = splitDirectories file diff --git a/Remote/BitTorrent.hs b/Remote/BitTorrent.hs index 09fa5ed744..0bbf4b24a7 100644 --- a/Remote/BitTorrent.hs +++ b/Remote/BitTorrent.hs @@ -195,7 +195,7 @@ downloadTorrentFile u = do createAnnexDirectory (parentDir torrent) if isTorrentMagnetUrl u then withOtherTmp $ \othertmp -> do - kf <- keyFile <$> torrentUrlKey u + kf <- fromRawFilePath . keyFile <$> torrentUrlKey u let metadir = othertmp "torrentmeta" kf createAnnexDirectory metadir showOutput @@ -239,7 +239,7 @@ downloadTorrentContent :: Key -> URLString -> FilePath -> Int -> MeterUpdate -> downloadTorrentContent k u dest filenum p = do torrent <- tmpTorrentFile u withOtherTmp $ \othertmp -> do - kf <- keyFile <$> torrentUrlKey u + kf <- fromRawFilePath . keyFile <$> torrentUrlKey u let downloaddir = othertmp "torrent" kf createAnnexDirectory downloaddir f <- wantedfile torrent diff --git a/Remote/Directory.hs b/Remote/Directory.hs index 933ccd23ce..3aa6185155 100644 --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -140,7 +140,7 @@ getLocation d k = do {- Directory where the file(s) for a key are stored. -} storeDir :: FilePath -> Key -> FilePath storeDir d k = addTrailingPathSeparator $ - d fromRawFilePath (hashDirLower def k) keyFile k + d fromRawFilePath (hashDirLower def k) fromRawFilePath (keyFile k) {- Check if there is enough free disk space in the remote's directory to - store the key. Note that the unencrypted key size is checked. -} @@ -164,12 +164,13 @@ store d chunkconfig k b p = liftIO $ do case chunkconfig of LegacyChunks chunksize -> Legacy.store chunksize finalizeStoreGeneric k b p tmpdir destdir _ -> do - let tmpf = tmpdir keyFile k + let tmpf = tmpdir kf meteredWriteFile p tmpf b finalizeStoreGeneric tmpdir destdir return True where - tmpdir = addTrailingPathSeparator $ d "tmp" keyFile k + tmpdir = addTrailingPathSeparator $ d "tmp" kf + kf = fromRawFilePath (keyFile k) destdir = storeDir d k {- Passed a temp directory that contains the files that should be placed diff --git a/Remote/Directory/LegacyChunked.hs b/Remote/Directory/LegacyChunked.hs index fb3626f489..d9d5a860ce 100644 --- a/Remote/Directory/LegacyChunked.hs +++ b/Remote/Directory/LegacyChunked.hs @@ -91,7 +91,7 @@ store chunksize finalizer k b p = storeHelper finalizer k $ \dests -> retrieve :: (FilePath -> Key -> [FilePath]) -> FilePath -> Preparer Retriever retrieve locations d basek a = withOtherTmp $ \tmpdir -> do showLongNote "This remote uses the deprecated chunksize setting. So this will be quite slow." - let tmp = tmpdir keyFile basek ++ ".directorylegacy.tmp" + let tmp = tmpdir fromRawFilePath (keyFile basek) ++ ".directorylegacy.tmp" a $ Just $ byteRetriever $ \k sink -> do liftIO $ void $ withStoredFiles d locations k $ \fs -> do forM_ fs $ diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs index c3a3f31348..9fa5916978 100644 --- a/Remote/GCrypt.hs +++ b/Remote/GCrypt.hs @@ -351,9 +351,9 @@ store' :: Git.Repo -> Remote -> Remote.Rsync.RsyncOpts -> Storer store' repo r rsyncopts | not $ Git.repoIsUrl repo = byteStorer $ \k b p -> guardUsable repo (return False) $ liftIO $ do - let tmpdir = Git.repoLocation repo "tmp" keyFile k + let tmpdir = Git.repoLocation repo "tmp" fromRawFilePath (keyFile k) void $ tryIO $ createDirectoryIfMissing True tmpdir - let tmpf = tmpdir keyFile k + let tmpf = tmpdir fromRawFilePath (keyFile k) meteredWriteFile p tmpf b let destdir = parentDir $ gCryptLocation repo k Remote.Directory.finalizeStoreGeneric tmpdir destdir diff --git a/Remote/Helper/Chunked/Legacy.hs b/Remote/Helper/Chunked/Legacy.hs index c804b23754..e7a7c5fc67 100644 --- a/Remote/Helper/Chunked/Legacy.hs +++ b/Remote/Helper/Chunked/Legacy.hs @@ -77,7 +77,7 @@ storeChunks key tmp dest storer recorder finalizer = either onerr return warningIO (show e) return False - basef = tmp ++ keyFile key + basef = tmp ++ fromRawFilePath (keyFile key) tmpdests = map (basef ++ ) chunkStream {- Given a list of destinations to use, chunks the data according to the diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs index f171b69e60..1847514002 100644 --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -226,7 +226,7 @@ remove o k = removeGeneric o includes [ parentDir dir , dir -- match content directory and anything in it - , dir keyFile k "***" + , dir fromRawFilePath (keyFile k) "***" ] {- An empty directory is rsynced to make it delete. Everything is excluded, diff --git a/Remote/Rsync/RsyncUrl.hs b/Remote/Rsync/RsyncUrl.hs index 2b0dbc1966..dc810dea4d 100644 --- a/Remote/Rsync/RsyncUrl.hs +++ b/Remote/Rsync/RsyncUrl.hs @@ -44,7 +44,7 @@ rsyncUrls :: RsyncOpts -> Key -> [RsyncUrl] rsyncUrls o k = map use dirHashes where use h = rsyncUrl o fromRawFilePath (hash h) rsyncEscape o (f f) - f = keyFile k + f = fromRawFilePath (keyFile k) #ifndef mingw32_HOST_OS hash h = h def k #else diff --git a/Remote/WebDAV/DavLocation.hs b/Remote/WebDAV/DavLocation.hs index 3893533a22..bd188a6de4 100644 --- a/Remote/WebDAV/DavLocation.hs +++ b/Remote/WebDAV/DavLocation.hs @@ -36,7 +36,7 @@ inLocation d = inDAVLocation ( d') {- The directory where files(s) for a key are stored. -} keyDir :: Key -> DavLocation -keyDir k = addTrailingPathSeparator $ hashdir keyFile k +keyDir k = addTrailingPathSeparator $ hashdir fromRawFilePath (keyFile k) where #ifndef mingw32_HOST_OS hashdir = fromRawFilePath $ hashDirLower def k @@ -45,7 +45,7 @@ keyDir k = addTrailingPathSeparator $ hashdir keyFile k #endif keyLocation :: Key -> DavLocation -keyLocation k = keyDir k ++ keyFile k +keyLocation k = keyDir k ++ fromRawFilePath (keyFile k) {- Paths containing # or ? cannot be represented in an url, so fails on - those. -} @@ -60,7 +60,7 @@ exportLocation l = {- Where we store temporary data for a key as it's being uploaded. -} keyTmpLocation :: Key -> DavLocation -keyTmpLocation = tmpLocation . keyFile +keyTmpLocation = tmpLocation . fromRawFilePath . keyFile tmpLocation :: FilePath -> DavLocation tmpLocation f = "git-annex-webdav-tmp-" ++ f diff --git a/Upgrade/V0.hs b/Upgrade/V0.hs index 00dce6d125..2b5b2d4eba 100644 --- a/Upgrade/V0.hs +++ b/Upgrade/V0.hs @@ -16,7 +16,7 @@ upgrade = do showAction "v0 to v1" -- do the reorganisation of the key files - olddir <- fromRepo gitAnnexDir + olddir <- fromRawFilePath <$> fromRepo gitAnnexDir keys <- getKeysPresent0 olddir forM_ keys $ \k -> moveAnnex k $ olddir keyFile0 k diff --git a/Upgrade/V1.hs b/Upgrade/V1.hs index e311044664..88a3494484 100644 --- a/Upgrade/V1.hs +++ b/Upgrade/V1.hs @@ -238,7 +238,7 @@ logFile2 = logFile' (hashDirLower def) logFile' :: (Key -> RawFilePath) -> Key -> Git.Repo -> String logFile' hasher key repo = - gitStateDir repo ++ fromRawFilePath (hasher key) ++ keyFile key ++ ".log" + gitStateDir repo ++ fromRawFilePath (hasher key) ++ fromRawFilePath (keyFile key) ++ ".log" stateDir :: FilePath stateDir = addTrailingPathSeparator ".git-annex" diff --git a/doc/todo/optimise_by_converting_Ref_to_ByteString.mdwn b/doc/todo/optimise_by_converting_Ref_to_ByteString.mdwn new file mode 100644 index 0000000000..11328a9f37 --- /dev/null +++ b/doc/todo/optimise_by_converting_Ref_to_ByteString.mdwn @@ -0,0 +1,3 @@ +Profiling of `git annex find --not --in web` suggests that converting Ref +to contain a ByteString, rather than a String, would eliminate a +fromRawFilePath that uses about 1% of runtime.