mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

more RawFilePath conversion

Browse source 
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
Download patch file Download diff file Expand all files Collapse all files

1
Config/Files.hs
View file

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

10
Config/Files/AutoStart.hs
View file

@ -12,8 +12,7 @@ module Config.Files.AutoStart where
import Common import Common
import Config.Files import Config.Files
import Utility.Tmp import Utility.Tmp
import Utility.FreeDesktop import Utility.Path.AbsRel
import Utility.Directory.AbsRel
{- Returns anything listed in the autostart file (which may not exist). -} {- Returns anything listed in the autostart file (which may not exist). -}
readAutoStartFile :: IO [FilePath] readAutoStartFile :: IO [FilePath]
@ -31,7 +30,8 @@ modifyAutoStartFile func = do
let dirs' = nubBy equalFilePath $ func dirs let dirs' = nubBy equalFilePath $ func dirs
when (dirs' /= dirs) $ do when (dirs' /= dirs) $ do
f <- autoStartFile f <- autoStartFile
createDirectoryIfMissing True (parentDir f) createDirectoryIfMissing True $
fromRawFilePath (parentDir (toRawFilePath f))
viaTmp writeFile f $ unlines dirs' viaTmp writeFile f $ unlines dirs'
{- Adds a directory to the autostart file. If the directory is already {- Adds a directory to the autostart file. If the directory is already
@ -39,12 +39,12 @@ modifyAutoStartFile func = do
- when opening the webapp. -} - when opening the webapp. -}
addAutoStartFile :: FilePath -> IO () addAutoStartFile :: FilePath -> IO ()
addAutoStartFile path = do addAutoStartFile path = do
path' <- absPath path path' <- fromRawFilePath <$> absPath (toRawFilePath path)
modifyAutoStartFile $ (:) path' modifyAutoStartFile $ (:) path'
{- Removes a directory from the autostart file. -} {- Removes a directory from the autostart file. -}
removeAutoStartFile :: FilePath -> IO () removeAutoStartFile :: FilePath -> IO ()
removeAutoStartFile path = do removeAutoStartFile path = do
path' <- absPath path path' <- fromRawFilePath <$> absPath (toRawFilePath path)
modifyAutoStartFile $ modifyAutoStartFile $
filter (not . equalFilePath path') 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 - This is written to be completely independant of git-annex and should be
- suitable for other uses. - 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. - Licensed under the GNU AGPL version 3 or higher.
-} -}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
module Git ( module Git (
@ -37,6 +38,7 @@ module Git (
relPath, relPath,
) where ) where
import qualified Data.ByteString as B
import Network.URI (uriPath, uriScheme, unEscapeString) import Network.URI (uriPath, uriScheme, unEscapeString)
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
import System.Posix.Files import System.Posix.Files
@ -44,6 +46,7 @@ import System.Posix.Files
import Common import Common
import Git.Types import Git.Types
import Utility.Path.AbsRel
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
import Utility.FileMode import Utility.FileMode
#endif #endif
@ -159,13 +162,13 @@ relPath = adjustPath torel
where where
torel p = do torel p = do
p' <- relPathCwdToFile p 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. -} {- 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 adjustPath f r@(Repo { location = l@(Local { gitdir = d, worktree = w }) }) = do
d' <- f' d d' <- f d
w' <- maybe (pure Nothing) (Just <$$> f') w w' <- maybe (pure Nothing) (Just <$$> f) w
return $ r return $ r
{ location = l { location = l
{ gitdir = d' { gitdir = d'
@ -173,8 +176,7 @@ adjustPath f r@(Repo { location = l@(Local { gitdir = d, worktree = w }) }) = do
} }
} }
where where
f' v = toRawFilePath <$> f (fromRawFilePath v)
adjustPath f r@(Repo { location = LocalUnknown d }) = do adjustPath f r@(Repo { location = LocalUnknown d }) = do
d' <- toRawFilePath <$> f (fromRawFilePath d) d' <- f d
return $ r { location = LocalUnknown d' } return $ r { location = LocalUnknown d' }
adjustPath _ r = pure r adjustPath _ r = pure r

14
Git/CheckAttr.hs
View file

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

7
Git/Config.hs
View file

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

56
Git/Construct.hs
View file

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

3
Git/CurrentRepo.hs
View file

@ -1,6 +1,6 @@
{- The current git repository. {- 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. - Licensed under the GNU AGPL version 3 or higher.
-} -}
@ -13,6 +13,7 @@ import Git.Construct
import qualified Git.Config import qualified Git.Config
import Utility.Env import Utility.Env
import Utility.Env.Set import Utility.Env.Set
import Utility.Path.AbsRel
{- Gets the current git repository. {- Gets the current git repository.
- -

9
Git/DiffTree.hs
View file

@ -17,6 +17,7 @@ module Git.DiffTree (
commitDiff, commitDiff,
) where ) where
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import qualified Data.Attoparsec.ByteString.Lazy as A import qualified Data.Attoparsec.ByteString.Lazy as A
import qualified Data.Attoparsec.ByteString.Char8 as A8 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 {- Checks if the DiffTreeItem modifies a file with a given name
- or under a directory by that name. -} - or under a directory by that name. -}
isDiffOf :: DiffTreeItem -> TopFilePath -> Bool isDiffOf :: DiffTreeItem -> TopFilePath -> Bool
isDiffOf diff f = case fromRawFilePath (getTopFilePath f) of isDiffOf diff f =
"" -> True -- top of repo contains all let f' = getTopFilePath f
d -> d `dirContains` fromRawFilePath (getTopFilePath (file diff)) in if B.null f'
then True -- top of repo contains all
else f' `dirContains` getTopFilePath (file diff)
{- Diffs two tree Refs. -} {- Diffs two tree Refs. -}
diffTree :: Ref -> Ref -> Repo -> IO ([DiffTreeItem], IO Bool) diffTree :: Ref -> Ref -> Repo -> IO ([DiffTreeItem], IO Bool)

4
Git/FilePath.hs
View file

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

7
Git/HashObject.hs
View file

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

3
Git/Index.hs
View file

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

10
Git/LsFiles.hs
View file

@ -37,12 +37,14 @@ import Git.Sha
import Utility.InodeCache import Utility.InodeCache
import Utility.TimeStamp import Utility.TimeStamp
import Utility.Attoparsec import Utility.Attoparsec
import Utility.Path.AbsRel
import System.Posix.Types import System.Posix.Types
import qualified Data.Map as M import qualified Data.Map as M
import qualified Data.ByteString as S import qualified Data.ByteString as S
import qualified Data.Attoparsec.ByteString as A import qualified Data.Attoparsec.ByteString as A
import qualified Data.Attoparsec.ByteString.Char8 as A8 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. {- 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' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
typeChanged' ps l repo = guardSafeForLsFiles repo $ do 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; -- git diff returns filenames relative to the top of the git repo;
-- convert to filenames relative to the cwd, like git ls-files. -- convert to filenames relative to the cwd, like git ls-files.
top <- absPath (fromRawFilePath (repoPath repo)) top <- absPath (repoPath repo)
currdir <- getCurrentDirectory currdir <- toRawFilePath <$> getCurrentDirectory
return (map (\f -> toRawFilePath (relPathDirToFileAbs currdir $ top </> decodeBL' f)) fs, cleanup) return (map (\f -> relPathDirToFileAbs currdir $ top P.</> f) fs, cleanup)
where where
prefix = prefix =
[ Param "diff" [ Param "diff"

17
Git/Repair.hs
View file

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

16
Utility/LinuxMkLibs.hs
View file

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

8
Utility/LockFile/PidLock.hs
View file

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