From b8bd2e45e3553a6c6a43e5b92b2dbe71256b3df3 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 28 Oct 2020 16:24:14 -0400 Subject: [PATCH] more RawFilePath conversion Notable wins in Annex.Locations which was sometimes doing 6 conversions in a single function call. This commit was sponsored by Denis Dzyubenko on Patreon. --- Annex/Fixup.hs | 24 ++++++++++++------------ Annex/Locations.hs | 22 +++++++++------------- Git/CurrentRepo.hs | 28 ++++++++++++++++++---------- 3 files changed, 39 insertions(+), 35 deletions(-) diff --git a/Annex/Fixup.hs b/Annex/Fixup.hs index 35e0c5497c..d8f892a989 100644 --- a/Annex/Fixup.hs +++ b/Annex/Fixup.hs @@ -13,6 +13,7 @@ import Git.Types import Git.Config import Types.GitConfig import Utility.Path +import Utility.Path.AbsRel import Utility.SafeCommand import Utility.Directory import Utility.Exception @@ -22,15 +23,13 @@ import qualified Utility.RawFilePath as R import Utility.PartialPrelude import System.IO -import System.FilePath -import System.PosixCompat.Files import Data.List 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 System.FilePath.ByteString import Control.Applicative import Prelude @@ -54,7 +53,7 @@ disableWildcardExpansion r = r fixupDirect :: Repo -> Repo fixupDirect r@(Repo { location = l@(Local { gitdir = d, worktree = Nothing }) }) = do r - { location = l { worktree = Just (toRawFilePath (parentDir (fromRawFilePath d))) } + { location = l { worktree = Just (parentDir d) } , gitGlobalOpts = gitGlobalOpts r ++ [ Param "-c" , Param $ fromConfigKey coreBare ++ "=" ++ boolConfig False @@ -109,13 +108,13 @@ fixupUnusualRepos r@(Repo { location = l@(Local { worktree = Just w, gitdir = d , return r ) where - dotgit = w P. ".git" + dotgit = w ".git" dotgit' = fromRawFilePath dotgit replacedotgit = whenM (doesFileExist dotgit') $ do linktarget <- relPathDirToFile w d nukeFile dotgit' - R.createSymbolicLink linktarget dotgit' + R.createSymbolicLink linktarget dotgit unsetcoreworktree = maybe (error "unset core.worktree failed") (\_ -> return ()) @@ -125,13 +124,14 @@ 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 (fromRawFilePath (d P. "commondir"))) >>= \case + catchDefaultIO Nothing (headMaybe . lines <$> readFile (fromRawFilePath (d "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") + let linktarget = toRawFilePath gd "annex" + R.createSymbolicLink linktarget + (dotgit "annex") Nothing -> return () -- Repo adjusted, so that symlinks to objects that get checked @@ -144,7 +144,7 @@ fixupUnusualRepos r _ = return r needsSubmoduleFixup :: Repo -> Bool needsSubmoduleFixup (Repo { location = (Local { worktree = Just _, gitdir = d }) }) = - (".git" P. "modules") `S.isInfixOf` d + (".git" "modules") `S.isInfixOf` d needsSubmoduleFixup _ = False needsGitLinkFixup :: Repo -> IO Bool @@ -152,6 +152,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 P. ".git" == d = return False - | otherwise = doesFileExist (fromRawFilePath (wt P. ".git")) + | wt ".git" == d = return False + | otherwise = doesFileExist (fromRawFilePath (wt ".git")) needsGitLinkFixup _ = return False diff --git a/Annex/Locations.hs b/Annex/Locations.hs index dfdce58d72..6a23fc203a 100644 --- a/Annex/Locations.hs +++ b/Annex/Locations.hs @@ -1,6 +1,6 @@ {- git-annex file locations - - - Copyright 2010-2019 Joey Hess + - Copyright 2010-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -108,6 +108,7 @@ import qualified Git.Types as Git import Git.FilePath import Annex.DirHashes import Annex.Fixup +import Utility.Path.AbsRel import qualified Utility.RawFilePath as R {- Conventions: @@ -199,32 +200,27 @@ gitAnnexLocation' key r config crippled symlinkssupported checker gitdir check [] = error "internal" {- Calculates a symlink target to link a file to an annexed object. -} -gitAnnexLink :: FilePath -> Key -> Git.Repo -> GitConfig -> IO FilePath +gitAnnexLink :: RawFilePath -> Key -> Git.Repo -> GitConfig -> IO RawFilePath gitAnnexLink file key r config = do - currdir <- getCurrentDirectory + currdir <- R.getCurrentDirectory let absfile = absNormPathUnix currdir file let gitdir = getgitdir currdir loc <- gitAnnexLocation' key r config False False (\_ -> return True) gitdir - fromRawFilePath . toInternalGitPath . toRawFilePath - <$> relPathDirToFile (parentDir absfile) (fromRawFilePath loc) + toInternalGitPath <$> relPathDirToFile (parentDir absfile) 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 = - toRawFilePath $ - absNormPathUnix currdir $ fromRawFilePath $ - Git.repoPath r P. ".git" + absNormPathUnix currdir (Git.repoPath r P. ".git") | otherwise = Git.localGitDir r - absNormPathUnix d p = fromRawFilePath $ toInternalGitPath $ toRawFilePath $ - absPathFrom - (fromRawFilePath $ toInternalGitPath $ toRawFilePath d) - (fromRawFilePath $ toInternalGitPath $ toRawFilePath p) + absNormPathUnix d p = toInternalGitPath $ + absPathFrom (toInternalGitPath d) (toInternalGitPath p) {- Calculates a symlink target as would be used in a typical git - repository, with .git in the top of the work tree. -} -gitAnnexLinkCanonical :: FilePath -> Key -> Git.Repo -> GitConfig -> IO FilePath +gitAnnexLinkCanonical :: RawFilePath -> Key -> Git.Repo -> GitConfig -> IO RawFilePath gitAnnexLinkCanonical file key r config = gitAnnexLink file key r' config' where r' = case r of diff --git a/Git/CurrentRepo.hs b/Git/CurrentRepo.hs index d99900bddb..1909d334c4 100644 --- a/Git/CurrentRepo.hs +++ b/Git/CurrentRepo.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Git.CurrentRepo where import Common @@ -14,6 +16,10 @@ import qualified Git.Config import Utility.Env import Utility.Env.Set import Utility.Path.AbsRel +import qualified Utility.RawFilePath as R + +import qualified Data.ByteString as B +import qualified System.FilePath.ByteString as P {- Gets the current git repository. - @@ -38,14 +44,14 @@ get = do gd <- getpathenv "GIT_DIR" r <- configure gd =<< fromCwd prefix <- getpathenv "GIT_PREFIX" - wt <- maybe (fromRawFilePath <$> worktree (location r)) Just + wt <- maybe (worktree (location r)) Just <$> getpathenvprefix "GIT_WORK_TREE" prefix case wt of Nothing -> return r Just d -> do - curr <- getCurrentDirectory + curr <- R.getCurrentDirectory unless (d `dirContains` curr) $ - setCurrentDirectory d + setCurrentDirectory (fromRawFilePath d) return $ addworktree wt r where getpathenv s = do @@ -53,24 +59,25 @@ get = do case v of Just d -> do unsetEnv s - return (Just d) + return (Just (toRawFilePath d)) Nothing -> return Nothing - getpathenvprefix s (Just prefix) | not (null prefix) = + getpathenvprefix s (Just prefix) | not (B.null prefix) = getpathenv s >>= \case Nothing -> return Nothing Just d | d == "." -> return (Just d) - | otherwise -> Just <$> absPath (prefix d) + | otherwise -> Just + <$> absPath (prefix P. d) getpathenvprefix s _ = getpathenv s configure Nothing (Just r) = Git.Config.read r configure (Just d) _ = do - absd <- absPath (fromRawFilePath d) - curr <- getCurrentDirectory + absd <- absPath d + curr <- R.getCurrentDirectory loc <- adjustGitDirFile $ Local { gitdir = absd - , worktree = Just (toRawFilePath curr) + , worktree = Just curr } r <- Git.Config.read $ newFrom loc return $ if Git.Config.isBare r @@ -80,6 +87,7 @@ get = do addworktree w r = changelocation r $ Local { gitdir = gitdir (location r) - , worktree = fmap toRawFilePath w + , worktree = w } + changelocation r l = r { location = l }