more RawFilePath conversion

Most of Git/ builds now.

Notable win is toTopFilePath no longer double converts

This commit was sponsored by Boyd Stephen Smith Jr. on Patreon.
This commit is contained in:
Joey Hess 2020-10-28 15:40:50 -04:00
parent d6e94a6b2e
commit 08cbaee1f8
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
15 changed files with 105 additions and 76 deletions

View file

@ -10,7 +10,6 @@
module Config.Files where
import Common
import Utility.Tmp
import Utility.FreeDesktop
{- ~/.config/git-annex/file -}

View file

@ -12,8 +12,7 @@ module Config.Files.AutoStart where
import Common
import Config.Files
import Utility.Tmp
import Utility.FreeDesktop
import Utility.Directory.AbsRel
import Utility.Path.AbsRel
{- Returns anything listed in the autostart file (which may not exist). -}
readAutoStartFile :: IO [FilePath]
@ -31,7 +30,8 @@ modifyAutoStartFile func = do
let dirs' = nubBy equalFilePath $ func dirs
when (dirs' /= dirs) $ do
f <- autoStartFile
createDirectoryIfMissing True (parentDir f)
createDirectoryIfMissing True $
fromRawFilePath (parentDir (toRawFilePath f))
viaTmp writeFile f $ unlines dirs'
{- Adds a directory to the autostart file. If the directory is already
@ -39,12 +39,12 @@ modifyAutoStartFile func = do
- when opening the webapp. -}
addAutoStartFile :: FilePath -> IO ()
addAutoStartFile path = do
path' <- absPath path
path' <- fromRawFilePath <$> absPath (toRawFilePath path)
modifyAutoStartFile $ (:) path'
{- Removes a directory from the autostart file. -}
removeAutoStartFile :: FilePath -> IO ()
removeAutoStartFile path = do
path' <- absPath path
path' <- fromRawFilePath <$> absPath (toRawFilePath path)
modifyAutoStartFile $
filter (not . equalFilePath path')

16
Git.hs
View file

@ -3,11 +3,12 @@
- This is written to be completely independant of git-annex and should be
- suitable for other uses.
-
- Copyright 2010-2012 Joey Hess <id@joeyh.name>
- Copyright 2010-2020 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module Git (
@ -37,6 +38,7 @@ module Git (
relPath,
) where
import qualified Data.ByteString as B
import Network.URI (uriPath, uriScheme, unEscapeString)
#ifndef mingw32_HOST_OS
import System.Posix.Files
@ -44,6 +46,7 @@ import System.Posix.Files
import Common
import Git.Types
import Utility.Path.AbsRel
#ifndef mingw32_HOST_OS
import Utility.FileMode
#endif
@ -159,13 +162,13 @@ relPath = adjustPath torel
where
torel p = do
p' <- relPathCwdToFile p
return $ if null p' then "." else p'
return $ if B.null p' then "." else p'
{- Adusts the path to a local Repo using the provided function. -}
adjustPath :: (FilePath -> IO FilePath) -> Repo -> IO Repo
adjustPath :: (RawFilePath -> IO RawFilePath) -> 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'
@ -173,8 +176,7 @@ adjustPath f r@(Repo { location = l@(Local { gitdir = d, worktree = w }) }) = do
}
}
where
f' v = toRawFilePath <$> f (fromRawFilePath v)
adjustPath f r@(Repo { location = LocalUnknown d }) = do
d' <- toRawFilePath <$> f (fromRawFilePath d)
d' <- f d
return $ r { location = LocalUnknown d' }
adjustPath _ r = pure r

View file

@ -1,6 +1,6 @@
{- git check-attr interface
-
- Copyright 2010-2012 Joey Hess <id@joeyh.name>
- Copyright 2010-2020 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
@ -10,11 +10,13 @@ module Git.CheckAttr where
import Common
import Git
import Git.Command
import Utility.Path.AbsRel
import qualified Utility.CoProcess as CoProcess
import System.IO.Error
import qualified Data.ByteString as B
type CheckAttrHandle = (CoProcess.CoProcessHandle, [Attr], String)
type CheckAttrHandle = (CoProcess.CoProcessHandle, [Attr], RawFilePath)
type Attr = String
@ -22,7 +24,7 @@ type Attr = String
- values and returns a handle. -}
checkAttrStart :: [Attr] -> Repo -> IO CheckAttrHandle
checkAttrStart attrs repo = do
currdir <- getCurrentDirectory
currdir <- toRawFilePath <$> getCurrentDirectory
h <- gitCoProcessStart True params repo
return (h, attrs, currdir)
where
@ -38,16 +40,16 @@ checkAttrStop (h, _, _) = CoProcess.stop h
{- Gets an attribute of a file. When the attribute is not specified,
- returns "" -}
checkAttr :: CheckAttrHandle -> Attr -> FilePath -> IO String
checkAttr :: CheckAttrHandle -> Attr -> RawFilePath -> IO String
checkAttr (h, attrs, currdir) want file = do
pairs <- CoProcess.query h send (receive "")
let vals = map snd $ filter (\(attr, _) -> attr == want) pairs
case vals of
["unspecified"] -> return ""
[v] -> return v
_ -> error $ "unable to determine " ++ want ++ " attribute of " ++ file
_ -> error $ "unable to determine " ++ want ++ " attribute of " ++ fromRawFilePath file
where
send to = hPutStr to $ file' ++ "\0"
send to = B.hPutStr to $ file' `B.snoc` 0
receive c from = do
s <- hGetSomeString from 1024
if null s

View file

@ -23,6 +23,7 @@ import qualified Git.Command
import qualified Git.Construct
import Utility.UserInfo
import Utility.ThreadScheduler
import Utility.Path.AbsRel
{- Returns a single git config setting, or a fallback value if not set. -}
get :: ConfigKey -> ConfigValue -> Repo -> ConfigValue
@ -141,9 +142,9 @@ updateLocation' r l = do
Nothing -> return l
Just (ConfigValue d) -> do
{- core.worktree is relative to the gitdir -}
top <- absPath $ fromRawFilePath (gitdir l)
let p = absPathFrom top (fromRawFilePath d)
return $ l { worktree = Just (toRawFilePath p) }
top <- absPath (gitdir l)
let p = absPathFrom top d
return $ l { worktree = Just p }
Just NoConfigValue -> return l
return $ r { location = l' }

View file

@ -5,6 +5,7 @@
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module Git.Construct (
@ -37,6 +38,10 @@ import Git.Remote
import Git.FilePath
import qualified Git.Url as Url
import Utility.UserInfo
import Utility.Path.AbsRel
import qualified Data.ByteString as B
import qualified System.FilePath.ByteString as P
{- Finds the git repository used for the cwd, which may be in a parent
- directory. -}
@ -46,40 +51,40 @@ fromCwd = getCurrentDirectory >>= seekUp
seekUp dir = do
r <- checkForRepo dir
case r of
Nothing -> case upFrom dir of
Nothing -> case upFrom (toRawFilePath dir) of
Nothing -> return Nothing
Just d -> seekUp d
Just d -> seekUp (fromRawFilePath d)
Just loc -> pure $ Just $ newFrom loc
{- Local Repo constructor, accepts a relative or absolute path. -}
fromPath :: FilePath -> IO Repo
fromPath :: RawFilePath -> IO Repo
fromPath dir = fromAbsPath =<< absPath dir
{- Local Repo constructor, requires an absolute path to the repo be
- specified. -}
fromAbsPath :: FilePath -> IO Repo
fromAbsPath :: RawFilePath -> IO Repo
fromAbsPath dir
| absoluteGitPath (encodeBS dir) = hunt
| absoluteGitPath dir = hunt
| otherwise =
error $ "internal error, " ++ dir ++ " is not absolute"
error $ "internal error, " ++ show dir ++ " is not absolute"
where
ret = pure . newFrom . LocalUnknown . toRawFilePath
canondir = dropTrailingPathSeparator dir
ret = pure . newFrom . LocalUnknown
canondir = P.dropTrailingPathSeparator dir
{- When dir == "foo/.git", git looks for "foo/.git/.git",
- and failing that, uses "foo" as the repository. -}
hunt
| (pathSeparator:".git") `isSuffixOf` canondir =
ifM (doesDirectoryExist $ dir </> ".git")
| (P.pathSeparator `B.cons` ".git") `B.isSuffixOf` canondir =
ifM (doesDirectoryExist $ fromRawFilePath dir </> ".git")
( ret dir
, ret (takeDirectory canondir)
, ret (P.takeDirectory canondir)
)
| otherwise = ifM (doesDirectoryExist dir)
| otherwise = ifM (doesDirectoryExist (fromRawFilePath dir))
( checkGitDirFile dir >>= maybe (ret dir) (pure . newFrom)
-- git falls back to dir.git when dir doesn't
-- exist, as long as dir didn't end with a
-- path separator
, if dir == canondir
then ret (dir ++ ".git")
then ret (dir <> ".git")
else ret dir
)
@ -95,7 +100,8 @@ fromUrl url
fromUrlStrict :: String -> IO Repo
fromUrlStrict url
| "file://" `isPrefixOf` url = fromAbsPath $ unEscapeString $ uriPath u
| "file://" `isPrefixOf` url = fromAbsPath $ toRawFilePath $
unEscapeString $ uriPath u
| otherwise = pure $ newFrom $ Url u
where
u = fromMaybe bad $ parseURI url
@ -155,7 +161,7 @@ fromRemoteLocation s repo = gen $ parseRemoteLocation s repo
fromRemotePath :: FilePath -> Repo -> IO Repo
fromRemotePath dir repo = do
dir' <- expandTilde dir
fromPath $ fromRawFilePath (repoPath repo) </> dir'
fromPath $ repoPath repo P.</> toRawFilePath dir'
{- Git remotes can have a directory that is specified relative
- to the user's home directory, or that contains tilde expansions.
@ -199,7 +205,7 @@ expandTilde = expandt True
checkForRepo :: FilePath -> IO (Maybe RepoLocation)
checkForRepo dir =
check isRepo $
check (checkGitDirFile dir) $
check (checkGitDirFile (toRawFilePath dir)) $
check isBareRepo $
return Nothing
where
@ -221,10 +227,10 @@ checkForRepo dir =
gitSignature file = doesFileExist $ dir </> file
-- Check for a .git file.
checkGitDirFile :: FilePath -> IO (Maybe RepoLocation)
checkGitDirFile :: RawFilePath -> IO (Maybe RepoLocation)
checkGitDirFile dir = adjustGitDirFile' $ Local
{ gitdir = toRawFilePath (dir </> ".git")
, worktree = Just (toRawFilePath dir)
{ gitdir = dir P.</> ".git"
, worktree = Just dir
}
-- git-submodule, git-worktree, and --separate-git-dir
@ -236,14 +242,16 @@ adjustGitDirFile loc = fromMaybe loc <$> adjustGitDirFile' loc
adjustGitDirFile' :: RepoLocation -> IO (Maybe RepoLocation)
adjustGitDirFile' loc = do
let gd = fromRawFilePath (gitdir loc)
c <- firstLine <$> catchDefaultIO "" (readFile gd)
let gd = gitdir loc
c <- firstLine <$> catchDefaultIO "" (readFile (fromRawFilePath gd))
if gitdirprefix `isPrefixOf` c
then do
top <- takeDirectory <$> absPath gd
top <- fromRawFilePath . P.takeDirectory <$> absPath gd
return $ Just $ loc
{ gitdir = toRawFilePath $ absPathFrom top $
drop (length gitdirprefix) c
{ gitdir = absPathFrom
(toRawFilePath top)
(toRawFilePath
(drop (length gitdirprefix) c))
}
else return Nothing
where

View file

@ -1,6 +1,6 @@
{- The current git repository.
-
- Copyright 2012 Joey Hess <id@joeyh.name>
- Copyright 2012-2020 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
@ -13,6 +13,7 @@ import Git.Construct
import qualified Git.Config
import Utility.Env
import Utility.Env.Set
import Utility.Path.AbsRel
{- Gets the current git repository.
-

View file

@ -17,6 +17,7 @@ module Git.DiffTree (
commitDiff,
) where
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import qualified Data.Attoparsec.ByteString.Lazy as A
import qualified Data.Attoparsec.ByteString.Char8 as A8
@ -34,9 +35,11 @@ import Utility.Attoparsec
{- 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 fromRawFilePath (getTopFilePath f) of
"" -> True -- top of repo contains all
d -> d `dirContains` fromRawFilePath (getTopFilePath (file diff))
isDiffOf diff f =
let f' = getTopFilePath f
in if B.null f'
then True -- top of repo contains all
else f' `dirContains` getTopFilePath (file diff)
{- Diffs two tree Refs. -}
diffTree :: Ref -> Ref -> Repo -> IO ([DiffTreeItem], IO Bool)

View file

@ -30,6 +30,7 @@ module Git.FilePath (
import Common
import Git
import Utility.Path.AbsRel
import qualified System.FilePath.ByteString as P
import qualified System.FilePath.Posix.ByteString
@ -58,8 +59,7 @@ fromTopFilePath p repo = P.combine (repoPath repo) (getTopFilePath p)
{- The input FilePath can be absolute, or relative to the CWD. -}
toTopFilePath :: RawFilePath -> Git.Repo -> IO TopFilePath
toTopFilePath file repo = TopFilePath . toRawFilePath
<$> relPathDirToFile (fromRawFilePath (repoPath repo)) (fromRawFilePath file)
toTopFilePath file repo = TopFilePath <$> relPathDirToFile (repoPath repo) file
{- The input RawFilePath must already be relative to the top of the git
- repository -}

View file

@ -16,6 +16,7 @@ import Git.Command
import Git.Types
import qualified Utility.CoProcess as CoProcess
import Utility.Tmp
import Utility.Path.AbsRel
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
@ -36,10 +37,10 @@ hashObjectStop :: HashObjectHandle -> IO ()
hashObjectStop = CoProcess.stop
{- Injects a file into git, returning the Sha of the object. -}
hashFile :: HashObjectHandle -> FilePath -> IO Sha
hashFile :: HashObjectHandle -> RawFilePath -> IO Sha
hashFile h file = CoProcess.query h send receive
where
send to = hPutStrLn to =<< absPath file
send to = S8.hPutStrLn to =<< absPath file
receive from = getSha "hash-object" $ S8.hGetLine from
class HashableBlob t where
@ -60,7 +61,7 @@ hashBlob :: HashableBlob b => HashObjectHandle -> b -> IO Sha
hashBlob h b = withTmpFile "hash" $ \tmp tmph -> do
hashableBlobToHandle tmph b
hClose tmph
hashFile h tmp
hashFile h (toRawFilePath tmp)
{- Injects some content into git, returning its Sha.
-

View file

@ -11,6 +11,7 @@ import Common
import Git
import Utility.Env
import Utility.Env.Set
import Utility.Path.AbsRel
indexEnv :: String
indexEnv = "GIT_INDEX_FILE"
@ -27,7 +28,7 @@ indexEnv = "GIT_INDEX_FILE"
- So, an absolute path is the only safe option for this to return.
-}
indexEnvVal :: FilePath -> IO String
indexEnvVal = absPath
indexEnvVal p = fromRawFilePath <$> absPath (toRawFilePath p)
{- Forces git to use the specified index file.
-

View file

@ -37,12 +37,14 @@ import Git.Sha
import Utility.InodeCache
import Utility.TimeStamp
import Utility.Attoparsec
import Utility.Path.AbsRel
import System.Posix.Types
import qualified Data.Map as M
import qualified Data.ByteString as S
import qualified Data.Attoparsec.ByteString as A
import qualified Data.Attoparsec.ByteString.Char8 as A8
import qualified System.FilePath.ByteString as P
{- It's only safe to use git ls-files on the current repo, not on a remote.
-
@ -208,12 +210,12 @@ typeChanged = typeChanged' []
typeChanged' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
typeChanged' ps l repo = guardSafeForLsFiles repo $ do
(fs, cleanup) <- pipeNullSplit (prefix ++ ps ++ suffix) repo
(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 (fromRawFilePath (repoPath repo))
currdir <- getCurrentDirectory
return (map (\f -> toRawFilePath (relPathDirToFileAbs currdir $ top </> decodeBL' f)) fs, cleanup)
top <- absPath (repoPath repo)
currdir <- toRawFilePath <$> getCurrentDirectory
return (map (\f -> relPathDirToFileAbs currdir $ top P.</> f) fs, cleanup)
where
prefix =
[ Param "diff"

View file

@ -35,12 +35,14 @@ import qualified Git.Ref as Ref
import qualified Git.RefLog as RefLog
import qualified Git.UpdateIndex as UpdateIndex
import qualified Git.Branch as Branch
import Utility.Directory.Create
import Utility.Tmp.Dir
import Utility.Rsync
import Utility.FileMode
import qualified Data.Set as S
import qualified Data.ByteString.Lazy as L
import qualified System.FilePath.ByteString as P
{- Given a set of bad objects found by git fsck, which may not
- be complete, finds and removes all corrupt objects. -}
@ -99,7 +101,7 @@ retrieveMissingObjects missing referencerepo r
| otherwise = withTmpDir "tmprepo" $ \tmpdir -> do
unlessM (boolSystem "git" [Param "init", File tmpdir]) $
error $ "failed to create temp repository in " ++ tmpdir
tmpr <- Config.read =<< Construct.fromAbsPath tmpdir
tmpr <- Config.read =<< Construct.fromAbsPath (toRawFilePath tmpdir)
rs <- Construct.fromRemotes r
stillmissing <- pullremotes tmpr rs fetchrefstags missing
if S.null (knownMissing stillmissing)
@ -246,11 +248,14 @@ explodePackedRefsFile r = do
nukeFile f
where
makeref (sha, ref) = do
let gitd = fromRawFilePath (localGitDir r)
let dest = gitd </> fromRef ref
createDirectoryUnder gitd (parentDir dest)
unlessM (doesFileExist dest) $
writeFile dest (fromRef sha)
let gitd = localGitDir r
let dest = gitd P.</> fromRef' ref
let dest' = fromRawFilePath dest
createDirectoryUnder
(fromRawFilePath gitd)
(fromRawFilePath (parentDir dest))
unlessM (doesFileExist dest') $
writeFile dest' (fromRef sha)
packedRefsFile :: Repo -> FilePath
packedRefsFile r = fromRawFilePath (localGitDir r) </> "packed-refs"

View file

@ -18,7 +18,9 @@ import Utility.Directory
import Utility.Process
import Utility.Monad
import Utility.Path
import Utility.Path.AbsRel
import Utility.Split
import Utility.FileSystemEncoding
import Data.Maybe
import System.FilePath
@ -35,18 +37,20 @@ installLib installfile top lib = ifM (doesFileExist lib)
( do
installfile top lib
checksymlink lib
return $ Just $ parentDir lib
return $ Just $ fromRawFilePath $ parentDir $ toRawFilePath lib
, return Nothing
)
where
checksymlink f = whenM (isSymbolicLink <$> getSymbolicLinkStatus (inTop top f)) $ do
l <- readSymbolicLink (inTop top f)
let absl = absPathFrom (parentDir f) l
target <- relPathDirToFile (takeDirectory f) absl
installfile top absl
let absl = absPathFrom
(parentDir (toRawFilePath f))
(toRawFilePath l)
target <- relPathDirToFile (toRawFilePath (takeDirectory f)) absl
installfile top (fromRawFilePath absl)
nukeFile (top ++ f)
createSymbolicLink target (inTop top f)
checksymlink absl
createSymbolicLink (fromRawFilePath target) (inTop top f)
checksymlink (fromRawFilePath absl)
-- Note that f is not relative, so cannot use </>
inTop :: FilePath -> FilePath -> FilePath

View file

@ -23,7 +23,7 @@ import Utility.Exception
import Utility.Applicative
import Utility.Directory
import Utility.Monad
import Utility.Path
import Utility.Path.AbsRel
import Utility.FileMode
import Utility.LockFile.LockStatus
import Utility.ThreadScheduler
@ -108,7 +108,7 @@ dropSideLock (Just (f, h)) = do
-- locks. /tmp is used as a fallback.
sideLockFile :: LockFile -> IO LockFile
sideLockFile lockfile = do
f <- absPath lockfile
f <- fromRawFilePath <$> absPath (toRawFilePath lockfile)
let base = intercalate "_" (splitDirectories (makeRelative "/" f))
let shortbase = reverse $ take 32 $ reverse base
let md5sum = if base == shortbase
@ -131,7 +131,7 @@ sideLockFile lockfile = do
-- "PIDLOCK_lockfile" environment variable, does not block either.
tryLock :: LockFile -> IO (Maybe LockHandle)
tryLock lockfile = do
abslockfile <- absPath lockfile
abslockfile <- fromRawFilePath <$> absPath (toRawFilePath lockfile)
lockenv <- pidLockEnv abslockfile
getEnv lockenv >>= \case
Nothing -> trySideLock lockfile (go abslockfile)
@ -299,7 +299,7 @@ checkSaneLock _ ParentLocked = return True
-- not see unsetLockEnv.
pidLockEnv :: FilePath -> IO String
pidLockEnv lockfile = do
abslockfile <- absPath lockfile
abslockfile <- fromRawFilePath <$> absPath (toRawFilePath lockfile)
return $ "PIDLOCK_" ++ filter legalInEnvVar abslockfile
pidLockEnvValue :: String