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:
parent
d6e94a6b2e
commit
08cbaee1f8
15 changed files with 105 additions and 76 deletions
|
@ -10,7 +10,6 @@
|
|||
module Config.Files where
|
||||
|
||||
import Common
|
||||
import Utility.Tmp
|
||||
import Utility.FreeDesktop
|
||||
|
||||
{- ~/.config/git-annex/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
16
Git.hs
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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' }
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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.
|
||||
-
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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 -}
|
||||
|
|
|
@ -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.
|
||||
-
|
||||
|
|
|
@ -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.
|
||||
-
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue