From a0168cd9a22f8722b38d003b7b0d6e97686db7ff Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 6 Dec 2019 15:37:12 -0400 Subject: [PATCH 01/23] 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 02/23] 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 03/23] 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 e07fbf936ac3c65a68349e44d4984e80da827f0f Mon Sep 17 00:00:00 2001 From: "https://christian.amsuess.com/chrysn" Date: Tue, 10 Dec 2019 10:27:58 +0000 Subject: [PATCH 04/23] Added a comment: Key character set --- ...omment_1_4ec126bffafc81fae04e183874ffce39._comment | 11 +++++++++++ 1 file changed, 11 insertions(+) create mode 100644 doc/internals/key_format/comment_1_4ec126bffafc81fae04e183874ffce39._comment diff --git a/doc/internals/key_format/comment_1_4ec126bffafc81fae04e183874ffce39._comment b/doc/internals/key_format/comment_1_4ec126bffafc81fae04e183874ffce39._comment new file mode 100644 index 0000000000..8a3e8f7bf1 --- /dev/null +++ b/doc/internals/key_format/comment_1_4ec126bffafc81fae04e183874ffce39._comment @@ -0,0 +1,11 @@ +[[!comment format=mdwn + username="https://christian.amsuess.com/chrysn" + nickname="chrysn" + avatar="http://christian.amsuess.com/avatar/c6c0d57d63ac88f3541522c4b21198c3c7169a665a2f2d733b4f78670322ffdc" + subject="Key character set" + date="2019-12-10T10:27:58Z" + content=""" +Are there limitations on the character set git-annex guarantees? + +It appears from experiments that git-annex only uses ASCII characters in there, given both a file 'test.extü' (in UTF-8 encoding) 'test.ext\xff' produced extension-free key names in the SHA256E hash – but it'd be good to have that confirmed. +"""]] From 0ff33261f2d104b0d373ee215d2a882162f90cbf Mon Sep 17 00:00:00 2001 From: yarikoptic Date: Tue, 10 Dec 2019 14:28:17 +0000 Subject: [PATCH 05/23] initial issue report on leaking error msgs --- ...r__44___ignores_--json-error-messages.mdwn | 56 +++++++++++++++++++ 1 file changed, 56 insertions(+) create mode 100644 doc/bugs/on_some_remotes_failing_to_detect_annex_spits_out_message_to_stderr_and_empty_lines_to_stderr__44___ignores_--json-error-messages.mdwn diff --git a/doc/bugs/on_some_remotes_failing_to_detect_annex_spits_out_message_to_stderr_and_empty_lines_to_stderr__44___ignores_--json-error-messages.mdwn b/doc/bugs/on_some_remotes_failing_to_detect_annex_spits_out_message_to_stderr_and_empty_lines_to_stderr__44___ignores_--json-error-messages.mdwn new file mode 100644 index 0000000000..4c4fca407a --- /dev/null +++ b/doc/bugs/on_some_remotes_failing_to_detect_annex_spits_out_message_to_stderr_and_empty_lines_to_stderr__44___ignores_--json-error-messages.mdwn @@ -0,0 +1,56 @@ +### Please describe the problem. + + +### What steps will reproduce the problem? + + +### What version of git-annex are you using? On what operating system? + + +### Please provide any additional information below. + +[[!format sh """ +lena:/tmp +$> git clone http://kumo.ovgu.de/~mih/myHP/bd2/4e4aa-7aea-11e6-9d5d-002590f97d84/ +Cloning into '4e4aa-7aea-11e6-9d5d-002590f97d84'... + +$> cd 4e4aa-7aea-11e6-9d5d-002590f97d84 + +$> git annex init +init (merging origin/git-annex into git-annex...) +(recording state in git...) +(scanning for unlocked files...) + + Failed to get annex.uuid configuration of repository origin + + Instead, got: "core.repositoryformatversion\n0\NULcore.filemode\ntrue\NULcore.bare\ntrue\NUL" + + This is unexpected; please check the network transport! +(Auto enabling special remote datalad-archives...) +(Auto enabling special remote inm7-storage...) + + Cannot run git-annex-remote-ria -- It is not installed in PATH (/usr/lib/git-annex.linux/bin:/usr/lib/git-core:/home/yoh/picts/mris/heudiconv-master/venvs/dev3/bin:/home/yoh/gocode/bin:/home/yoh/gocode/bin:/home/yoh/bin:/home/yoh/.local/bin:/usr/local/bin:/usr/bin:/bin:/usr/local/games:/usr/games:/sbin:/usr/sbin:/usr/local/sbin:/usr/lib/git-annex.linux/extra) +ok +(recording state in git...) + +"""]] + +so two issues in above: +- not clear why it dumps git config if fetched instead of just announcing that remote has no git-annex and set to ignore +- empty lines between all the messages go to stdout: + +[[!format sh """ +$> git annex init 2>/dev/null +init (scanning for unlocked files...) + + + +(Auto enabling special remote inm7-storage...) + +ok +"""]] + +PS ignore "ignores --json-error-messages" part of the subject -- was detected in 7.20190819+git2-g908476a9b-1~ndall+1 during `get` but upgrade to 7.20191114+git43-ge29663773-1~ndall+1 resolved it + +[[!meta author=yoh]] +[[!tag projects/datalad]] From 3c4053e455c83bc15227d87da34f3129b888616e Mon Sep 17 00:00:00 2001 From: "michael.clifford.com@7ca464bc0ba25fd5f2922deb8f531668727a66fb" Date: Tue, 10 Dec 2019 21:01:53 +0000 Subject: [PATCH 06/23] Added a comment: android special remote via mtp supported? --- ..._c504fe0c08bc820ec033172b164d3ccc._comment | 31 +++++++++++++++++++ 1 file changed, 31 insertions(+) create mode 100644 doc/tips/android_sync_with_adb/comment_1_c504fe0c08bc820ec033172b164d3ccc._comment diff --git a/doc/tips/android_sync_with_adb/comment_1_c504fe0c08bc820ec033172b164d3ccc._comment b/doc/tips/android_sync_with_adb/comment_1_c504fe0c08bc820ec033172b164d3ccc._comment new file mode 100644 index 0000000000..87c7fb7787 --- /dev/null +++ b/doc/tips/android_sync_with_adb/comment_1_c504fe0c08bc820ec033172b164d3ccc._comment @@ -0,0 +1,31 @@ +[[!comment format=mdwn + username="michael.clifford.com@7ca464bc0ba25fd5f2922deb8f531668727a66fb" + nickname="michael.clifford.com" + avatar="http://cdn.libravatar.org/avatar/248593885d551a3912e488c4bc9d311c" + subject="android special remote via mtp supported?" + date="2019-12-10T21:01:52Z" + content=""" +I've tried to use this special remote with my android Pixel 3a phone. It connects via mtp. +In Debian, this mounts to the /run folder. +Specifically in my case: /run/user/1000/gvfs/mtp:host=Google_Pixel_3a_94MBY0DHLL/Internal shared storage/DCIM + +I've tried as follows but I keep getting below error. + + +git annex initremote android type=adb androiddirectory=/run/user/1000/gvfs/mtp\:host\=Google_Pixel_3a_94MBY0DHLL/Internal\ shared\ storage/DCIM encryption=none exporttree=yes importtree=yes +initremote android +git-annex: adb: createProcess: runInteractiveProcess: exec: does not exist (No such file or directory) +failed +git-annex: initremote: 1 failed + +I've attempted to surround the androiddirectory is both single and double quotes, or substituting it with a symbolic link, but can't get past this. + +Thanks +M + + + + + + +"""]] From 80b0c9b514a2846cd3017b92af9cb0df4204781b Mon Sep 17 00:00:00 2001 From: "michael.clifford.com@7ca464bc0ba25fd5f2922deb8f531668727a66fb" Date: Tue, 10 Dec 2019 21:02:23 +0000 Subject: [PATCH 07/23] removed --- ..._c504fe0c08bc820ec033172b164d3ccc._comment | 31 ------------------- 1 file changed, 31 deletions(-) delete mode 100644 doc/tips/android_sync_with_adb/comment_1_c504fe0c08bc820ec033172b164d3ccc._comment diff --git a/doc/tips/android_sync_with_adb/comment_1_c504fe0c08bc820ec033172b164d3ccc._comment b/doc/tips/android_sync_with_adb/comment_1_c504fe0c08bc820ec033172b164d3ccc._comment deleted file mode 100644 index 87c7fb7787..0000000000 --- a/doc/tips/android_sync_with_adb/comment_1_c504fe0c08bc820ec033172b164d3ccc._comment +++ /dev/null @@ -1,31 +0,0 @@ -[[!comment format=mdwn - username="michael.clifford.com@7ca464bc0ba25fd5f2922deb8f531668727a66fb" - nickname="michael.clifford.com" - avatar="http://cdn.libravatar.org/avatar/248593885d551a3912e488c4bc9d311c" - subject="android special remote via mtp supported?" - date="2019-12-10T21:01:52Z" - content=""" -I've tried to use this special remote with my android Pixel 3a phone. It connects via mtp. -In Debian, this mounts to the /run folder. -Specifically in my case: /run/user/1000/gvfs/mtp:host=Google_Pixel_3a_94MBY0DHLL/Internal shared storage/DCIM - -I've tried as follows but I keep getting below error. - - -git annex initremote android type=adb androiddirectory=/run/user/1000/gvfs/mtp\:host\=Google_Pixel_3a_94MBY0DHLL/Internal\ shared\ storage/DCIM encryption=none exporttree=yes importtree=yes -initremote android -git-annex: adb: createProcess: runInteractiveProcess: exec: does not exist (No such file or directory) -failed -git-annex: initremote: 1 failed - -I've attempted to surround the androiddirectory is both single and double quotes, or substituting it with a symbolic link, but can't get past this. - -Thanks -M - - - - - - -"""]] From df7bf60998222e6725414768f43e5eb5d117ebb7 Mon Sep 17 00:00:00 2001 From: MichaelC Date: Tue, 10 Dec 2019 21:23:31 +0000 Subject: [PATCH 08/23] Added a comment: Does android adb special remote support MTP? --- ..._305dbaac1c9c526c4b467314960e3bcd._comment | 27 +++++++++++++++++++ 1 file changed, 27 insertions(+) create mode 100644 doc/tips/android_sync_with_adb/comment_1_305dbaac1c9c526c4b467314960e3bcd._comment diff --git a/doc/tips/android_sync_with_adb/comment_1_305dbaac1c9c526c4b467314960e3bcd._comment b/doc/tips/android_sync_with_adb/comment_1_305dbaac1c9c526c4b467314960e3bcd._comment new file mode 100644 index 0000000000..8542376aa3 --- /dev/null +++ b/doc/tips/android_sync_with_adb/comment_1_305dbaac1c9c526c4b467314960e3bcd._comment @@ -0,0 +1,27 @@ +[[!comment format=mdwn + username="MichaelC" + avatar="http://cdn.libravatar.org/avatar/248593885d551a3912e488c4bc9d311c" + subject="Does android adb special remote support MTP?" + date="2019-12-10T21:23:31Z" + content=""" +I'm attempting to init this special remote with my Pixel 3a android phone (which connect via MTP) but keep hitting the following error. + +In Debian, this will mount to /run , specifically in my case + +/run/user/1000/gvfs/mtp\\:host\=Google_Pixel_3a_94MBY/Internal\ shared\ storage/DCIM + +git annex initremote android type=adb androiddirectory=/run/user/1000/gvfs/mtp\\:host\=Google_Pixel_3a_94MBY/Internal\ shared\ storage/DCIM encryption=none exporttree=yes importtree=yes +initremote android +git-annex: adb: createProcess: runInteractiveProcess: exec: does not exist (No such file or directory) +failed +git-annex: initremote: 1 failed + +I've tried enclosing the androiddirectory in single/double quotes (based on the hope that the colon before host was the issue) +I've also attempted to substitute a symbolic link to the directory instead - but no luck. + +(*) I can cd into this directroy via xterm and browse etc. + +Thanks, +M + +"""]] From 0c4bb02877ddb6f69ad57630390d81d65fdcb2b5 Mon Sep 17 00:00:00 2001 From: yarikoptic Date: Tue, 10 Dec 2019 22:01:13 +0000 Subject: [PATCH 09/23] Added a comment --- ...mment_2_fa9e2c0a83bad2e0c2da3016b9bf2100._comment | 12 ++++++++++++ 1 file changed, 12 insertions(+) create mode 100644 doc/todo/OPT__58_____34__bundle__34___get_+_check___40__of_checksum__41___in_a_single_operation/comment_2_fa9e2c0a83bad2e0c2da3016b9bf2100._comment diff --git a/doc/todo/OPT__58_____34__bundle__34___get_+_check___40__of_checksum__41___in_a_single_operation/comment_2_fa9e2c0a83bad2e0c2da3016b9bf2100._comment b/doc/todo/OPT__58_____34__bundle__34___get_+_check___40__of_checksum__41___in_a_single_operation/comment_2_fa9e2c0a83bad2e0c2da3016b9bf2100._comment new file mode 100644 index 0000000000..ca032f7a00 --- /dev/null +++ b/doc/todo/OPT__58_____34__bundle__34___get_+_check___40__of_checksum__41___in_a_single_operation/comment_2_fa9e2c0a83bad2e0c2da3016b9bf2100._comment @@ -0,0 +1,12 @@ +[[!comment format=mdwn + username="yarikoptic" + avatar="http://cdn.libravatar.org/avatar/f11e9c84cb18d26a1748c33b48c924b4" + subject="comment 2" + date="2019-12-10T22:01:12Z" + content=""" +> An external remote could also do its own checksum checking and then set `remote..annex-verify=false` + +that is an interesting idea, thanks! Not sure if that makes it easy for mass consumption though since it is a feature of a external remote, not sure why it should be in the config. Ideally it should be a property of a remote. + +Joey, what do you think in regard of built-in remotes? +"""]] From 8b07ab553f0d1ee92152c97a0b340fec2cf3ae13 Mon Sep 17 00:00:00 2001 From: Ilya_Shlyakhter Date: Wed, 11 Dec 2019 18:13:48 +0000 Subject: [PATCH 10/23] Added a comment: annex-verify --- .../comment_3_529c38fc63540b32c51ae75529e9005e._comment | 8 ++++++++ 1 file changed, 8 insertions(+) create mode 100644 doc/todo/OPT__58_____34__bundle__34___get_+_check___40__of_checksum__41___in_a_single_operation/comment_3_529c38fc63540b32c51ae75529e9005e._comment diff --git a/doc/todo/OPT__58_____34__bundle__34___get_+_check___40__of_checksum__41___in_a_single_operation/comment_3_529c38fc63540b32c51ae75529e9005e._comment b/doc/todo/OPT__58_____34__bundle__34___get_+_check___40__of_checksum__41___in_a_single_operation/comment_3_529c38fc63540b32c51ae75529e9005e._comment new file mode 100644 index 0000000000..d2a79d3cf3 --- /dev/null +++ b/doc/todo/OPT__58_____34__bundle__34___get_+_check___40__of_checksum__41___in_a_single_operation/comment_3_529c38fc63540b32c51ae75529e9005e._comment @@ -0,0 +1,8 @@ +[[!comment format=mdwn + username="Ilya_Shlyakhter" + avatar="http://cdn.libravatar.org/avatar/1647044369aa7747829c38b9dcc84df0" + subject="annex-verify" + date="2019-12-11T18:13:48Z" + content=""" +\"it is a feature of a external remote, not sure why it should be in the config\" -- because the user might not trust an external remote's implementation of this feature. Besides bugs, there might be [[security exploits|security/CVE-2018-10857_and_CVE-2018-10859]] if external remotes could single-handedly disable verification. +"""]] From c19211774f509f2b0334073b599295538871a00f Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 11 Dec 2019 14:12:22 -0400 Subject: [PATCH 11/23] 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 458d04e729beadd118ce691d55d9fd80a59414a2 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 11 Dec 2019 15:27:38 -0400 Subject: [PATCH 12/23] devblog --- ...ay_613__end-to-end_ByteString_milestone.mdwn | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) create mode 100644 doc/devblog/day_613__end-to-end_ByteString_milestone.mdwn diff --git a/doc/devblog/day_613__end-to-end_ByteString_milestone.mdwn b/doc/devblog/day_613__end-to-end_ByteString_milestone.mdwn new file mode 100644 index 0000000000..1b774c019b --- /dev/null +++ b/doc/devblog/day_613__end-to-end_ByteString_milestone.mdwn @@ -0,0 +1,17 @@ +The `bs` branch has reached a milestone: `git-annex find` and `git-annex +get` (when all files are present) process ByteStrings end-to-end with +no String conversion. That sped it up by around 30% on top of the previous +optimisations. + +To get here, I spent a couple of days creating the +[filepath-bytestring](https://joeyh.name/blog/entry/announcing_the_filepath-bytestring_haskell_library/) +library, which git-annex will depend on. Lots more git-annex internals +were switched to ByteString, especially everything having to do with +statting files. + +Other commands, like `git-annex whereis`, still do some String +conversions. Optimisation never ends. + +But the bs branch is ready to merge as-is, and the diff is 10 thousand lines, +so not a branch I want to maintain for long. Planning to merge it after +the next release. From cee0d738fc93e12e58f61f32d248862bd969f6f7 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 11 Dec 2019 17:08:08 -0400 Subject: [PATCH 13/23] 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 14/23] 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 15/23] 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 16/23] 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 3a14bc8220bbc9a728a258db10fa94048b9ba1c0 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 12 Dec 2019 22:06:42 -0500 Subject: [PATCH 17/23] bug report --- ...om_ssh_when_not_present_displays_misleading | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) create mode 100644 doc/bugs/move_from_ssh_when_not_present_displays_misleading diff --git a/doc/bugs/move_from_ssh_when_not_present_displays_misleading b/doc/bugs/move_from_ssh_when_not_present_displays_misleading new file mode 100644 index 0000000000..9d2afa2a58 --- /dev/null +++ b/doc/bugs/move_from_ssh_when_not_present_displays_misleading @@ -0,0 +1,18 @@ +When a file is not present on a ssh remote, a move of that file fails +like this: + + move foo (from r...) + verification of content failed + failed + move bar (from r...) + Lost connection (fd:24: hGetChar: illegal operation (handle is closed)) + failed + +Both files were not present, so two different failures, and neither message +bears on the real reason why the move failed. + +(Despite the connection having closed, it then was able to move a third file +that was still present.) + +IIRC there was a clear message displayed before git-annex-shell p2pstdio +got implemented. --[[Joey]] From 3d38ec9585b5332a95f171388d5ea068954509e3 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 18 Dec 2019 11:29:34 -0400 Subject: [PATCH 18/23] 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 19/23] 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 20/23] 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 21/23] 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 22/23] 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 23/23] 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