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

more OsPath conversion

Browse source 
About 1/10th done with this I think.
This commit is contained in:
Joey Hess 2025-01-24 13:40:09 -04:00
parent 8021d22955
commit c412c59ecd
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
16 changed files with 152 additions and 142 deletions
Download patch file Download diff file Expand all files Collapse all files

2
Config/Files.hs
View file

@ -16,7 +16,7 @@ import Utility.Exception
{- ~/.config/git-annex/file -}
userConfigFile :: OsPath -> IO OsPath
userConfigFile file = do
dir <- toOsPath <$> userConfigDir
dir <- userConfigDir
return $ dir </> literalOsPath "git-annex" </> file
autoStartFile :: IO OsPath

3
Config/Files/AutoStart.hs
View file

@ -30,8 +30,7 @@ modifyAutoStartFile func = do
when (dirs' /= dirs) $ do
f <- autoStartFile
createDirectoryIfMissing True (parentDir f)
viaTmp (writeFile . fromRawFilePath . fromOsPath)
(toOsPath f)
viaTmp (writeFile . fromRawFilePath . fromOsPath) f
(unlines (map fromOsPath dirs'))
{- Adds a directory to the autostart file. If the directory is already

33
Git.hs
View file

@ -47,6 +47,7 @@ import qualified System.FilePath.ByteString as P
import Common
import Git.Types
import qualified Utility.OsString as OS
#ifndef mingw32_HOST_OS
import Utility.FileMode
#endif
@ -56,32 +57,32 @@ repoDescribe :: Repo -> String
repoDescribe Repo { remoteName = Just name } = name
repoDescribe Repo { location = Url url } = show url
repoDescribe Repo { location = UnparseableUrl url } = url
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 = Local { worktree = Just dir } } = fromOsPath dir
repoDescribe Repo { location = Local { gitdir = dir } } = fromOsPath dir
repoDescribe Repo { location = LocalUnknown dir } = fromOsPath 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 = UnparseableUrl url } = url
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 = Local { worktree = Just dir } } = fromOsPath dir
repoLocation Repo { location = Local { gitdir = dir } } = fromOsPath dir
repoLocation Repo { location = LocalUnknown dir } = fromOsPath dir
repoLocation Repo { location = Unknown } = giveup "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 -> RawFilePath
repoPath Repo { location = Url u } = toRawFilePath $ unEscapeString $ uriPath u
repoPath :: Repo -> OsPath
repoPath Repo { location = Url u } = toOsPath $ 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 } = giveup "unknown repoPath"
repoPath Repo { location = UnparseableUrl _u } = giveup "unknown repoPath"
repoWorkTree :: Repo -> Maybe RawFilePath
repoWorkTree :: Repo -> Maybe OsPath
repoWorkTree Repo { location = Local { worktree = Just d } } = Just d
repoWorkTree _ = Nothing
@ -137,13 +138,13 @@ assertLocal repo action
| otherwise = action
{- Path to a repository's gitattributes file. -}
attributes :: Repo -> RawFilePath
attributes :: Repo -> OsPath
attributes repo
| repoIsLocalBare repo = attributesLocal repo
| otherwise = repoPath repo P.</> ".gitattributes"
| otherwise = repoPath repo </> literalOsPath ".gitattributes"
attributesLocal :: Repo -> RawFilePath
attributesLocal repo = localGitDir repo P.</> "info" P.</> "attributes"
attributesLocal :: Repo -> OsPath
attributesLocal repo = localGitDir repo </> literalOsPath "info" </> literalOsPath "attributes"
{- Path to a given hook script in a repository, only if the hook exists
- and is executable. -}
@ -166,10 +167,12 @@ relPath = adjustPath torel
where
torel p = do
p' <- relPathCwdToFile p
return $ if B.null p' then "." else p'
return $ if OS.null p'
then literalOsPath "."
else p'
{- Adjusts the path to a local Repo using the provided function. -}
adjustPath :: (RawFilePath -> IO RawFilePath) -> Repo -> IO Repo
adjustPath :: (OsPath -> IO OsPath) -> 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

13
Git/CheckAttr.hs
View file

@ -11,12 +11,11 @@ import Common
import Git
import Git.Command
import qualified Utility.CoProcess as CoProcess
import qualified Utility.RawFilePath as R
import System.IO.Error
import qualified Data.ByteString as B
type CheckAttrHandle = (CoProcess.CoProcessHandle, [Attr], RawFilePath)
type CheckAttrHandle = (CoProcess.CoProcessHandle, [Attr], OsPath)
type Attr = String
@ -24,7 +23,7 @@ type Attr = String
- and returns a handle. -}
checkAttrStart :: [Attr] -> Repo -> IO CheckAttrHandle
checkAttrStart attrs repo = do
currdir <- R.getCurrentDirectory
currdir <- getCurrentDirectory
h <- gitCoProcessStart True params repo
return (h, attrs, currdir)
where
@ -38,14 +37,14 @@ checkAttrStart attrs repo = do
checkAttrStop :: CheckAttrHandle -> IO ()
checkAttrStop (h, _, _) = CoProcess.stop h
checkAttr :: CheckAttrHandle -> Attr -> RawFilePath -> IO String
checkAttr :: CheckAttrHandle -> Attr -> OsPath -> IO String
checkAttr h want file = checkAttrs h [want] file >>= return . \case
(v:_) -> v
[] -> ""
{- Gets attributes of a file. When an attribute is not specified,
- returns "" for it. -}
checkAttrs :: CheckAttrHandle -> [Attr] -> RawFilePath -> IO [String]
checkAttrs :: CheckAttrHandle -> [Attr] -> OsPath -> IO [String]
checkAttrs (h, attrs, currdir) want file = do
l <- CoProcess.query h send (receive "")
return (getvals l want)
@ -54,9 +53,9 @@ checkAttrs (h, attrs, currdir) want file = do
getvals l (x:xs) = case map snd $ filter (\(attr, _) -> attr == x) l of
["unspecified"] -> "" : getvals l xs
[v] -> v : getvals l xs
_ -> giveup $ "unable to determine " ++ x ++ " attribute of " ++ fromRawFilePath file
_ -> giveup $ "unable to determine " ++ x ++ " attribute of " ++ fromOsPath file
send to = B.hPutStr to $ file' `B.snoc` 0
send to = B.hPutStr to $ (fromOsPath file') `B.snoc` 0
receive c from = do
s <- hGetSomeString from 1024
if null s

4
Git/Command.hs
View file

@ -24,10 +24,10 @@ gitCommandLine params r@(Repo { location = l@(Local { } ) }) =
where
setdir
| gitEnvOverridesGitDir r = []
| otherwise = [Param $ "--git-dir=" ++ fromRawFilePath (gitdir l)]
| otherwise = [Param $ "--git-dir=" ++ fromOsPath (gitdir l)]
settree = case worktree l of
Nothing -> []
Just t -> [Param $ "--work-tree=" ++ fromRawFilePath t]
Just t -> [Param $ "--work-tree=" ++ fromOsPath t]
gitCommandLine _ repo = assertLocal repo $ error "internal"
{- Runs git in the specified repo. -}

4
Git/Env.hs
View file

@ -30,9 +30,9 @@ 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" (fromRawFilePath (localGitDir g))
g' <- addGitEnv g "GIT_DIR" (fromOsPath (localGitDir g))
g'' <- maybe (pure g')
(addGitEnv g' "GIT_WORK_TREE" . fromRawFilePath)
(addGitEnv g' "GIT_WORK_TREE" . fromOsPath)
(repoWorkTree g)
return $ fromMaybe [] (gitEnv g'')

2
Git/FilePath.hs
View file

@ -89,5 +89,5 @@ fromInternalGitPath = toOsPath . encodeBS . replace "/" "\\" . decodeBS . fromOs
{- isAbsolute on Windows does not think "/foo" or "\foo" is absolute,
- so try posix paths.
-}
absoluteGitPath :: RawFilePath -> Bool
absoluteGitPath :: OsPath -> Bool
absoluteGitPath p = isAbsolute p || isAbsolute (toInternalGitPath p)

20
Git/HashObject.hs
View file

@ -15,14 +15,14 @@ import Git
import Git.Sha
import Git.Command
import Git.Types
import qualified Utility.CoProcess as CoProcess
import Utility.Tmp
import qualified Utility.CoProcess as CoProcess
import qualified Utility.OsString as OS
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
import Data.ByteString.Builder
import Data.Char
data HashObjectHandle = HashObjectHandle CoProcess.CoProcessHandle Repo [CommandParam]
@ -41,7 +41,7 @@ hashObjectStop :: HashObjectHandle -> IO ()
hashObjectStop (HashObjectHandle h _ _) = CoProcess.stop h
{- Injects a file into git, returning the Sha of the object. -}
hashFile :: HashObjectHandle -> RawFilePath -> IO Sha
hashFile :: HashObjectHandle -> OsPath -> IO Sha
hashFile hdl@(HashObjectHandle h _ _) file = do
-- git hash-object chdirs to the top of the repository on
-- start, so if the filename is relative, it will
@ -49,24 +49,24 @@ hashFile hdl@(HashObjectHandle h _ _) file = do
-- So, make the filename absolute, which will work now
-- and also if git's behavior later changes.
file' <- absPath file
if newline `S.elem` file' || carriagereturn `S.elem` file
if newline `OS.elem` file' || carriagereturn `OS.elem` file
then hashFile' hdl file
else CoProcess.query h (send file') receive
else CoProcess.query h (send (fromOsPath file')) receive
where
send file' to = S8.hPutStrLn to file'
receive from = getSha "hash-object" $ S8.hGetLine from
newline = fromIntegral (ord '\n')
newline = unsafeFromChar '\n'
-- git strips carriage return from the end of a line, out of some
-- misplaced desire to support windows, so also use the newline
-- fallback for those.
carriagereturn = fromIntegral (ord '\r')
carriagereturn = unsafeFromChar '\r'
{- Runs git hash-object once per call, rather than using a running
- one, so is slower. But, is able to handle newlines in the filepath,
- which --stdin-paths cannot. -}
hashFile' :: HashObjectHandle -> RawFilePath -> IO Sha
hashFile' :: HashObjectHandle -> OsPath -> IO Sha
hashFile' (HashObjectHandle _ repo ps) file = getSha "hash-object" $
pipeReadStrict (ps ++ [File (fromRawFilePath file)]) repo
pipeReadStrict (ps ++ [File (fromOsPath file)]) repo
class HashableBlob t where
hashableBlobToHandle :: Handle -> t -> IO ()
@ -86,7 +86,7 @@ hashBlob :: HashableBlob b => HashObjectHandle -> b -> IO Sha
hashBlob h b = withTmpFile (literalOsPath "hash") $ \tmp tmph -> do
hashableBlobToHandle tmph b
hClose tmph
hashFile h (fromOsPath tmp)
hashFile h tmp
{- Injects some content into git, returning its Sha.
-

14
Git/LockFile.hs
View file

@ -21,9 +21,9 @@ import System.Win32.File
#endif
#ifndef mingw32_HOST_OS
data LockHandle = LockHandle FilePath Fd
data LockHandle = LockHandle OsPath Fd
#else
data LockHandle = LockHandle FilePath HANDLE
data LockHandle = LockHandle OsPath HANDLE
#endif
{- Uses the same exclusive locking that git does.
@ -33,14 +33,14 @@ data LockHandle = LockHandle FilePath HANDLE
- a dangling lock can be left if a process is terminated at the wrong
- time.
-}
openLock :: FilePath -> IO LockHandle
openLock :: OsPath -> IO LockHandle
openLock lck = openLock' lck `catchNonAsync` lckerr
where
lckerr e = do
-- Same error message displayed by git.
whenM (doesFileExist lck) $
hPutStrLn stderr $ unlines
[ "fatal: Unable to create '" ++ lck ++ "': " ++ show e
[ "fatal: Unable to create '" ++ fromOsPath lck ++ "': " ++ show e
, ""
, "If no other git process is currently running, this probably means a"
, "git process crashed in this repository earlier. Make sure no other git"
@ -48,11 +48,11 @@ openLock lck = openLock' lck `catchNonAsync` lckerr
]
throwM e
openLock' :: FilePath -> IO LockHandle
openLock' :: OsPath -> IO LockHandle
openLock' lck = do
#ifndef mingw32_HOST_OS
-- On unix, git simply uses O_EXCL
h <- openFdWithMode (toRawFilePath lck) ReadWrite (Just 0O666)
h <- openFdWithMode (fromOsPath lck) ReadWrite (Just 0O666)
(defaultFileFlags { exclusive = True })
setFdOption h CloseOnExec True
#else
@ -65,7 +65,7 @@ openLock' lck = do
-- So, all that's needed is a way to open the file, that fails
-- if the file already exists. Using CreateFile with CREATE_NEW
-- accomplishes that.
h <- createFile lck gENERIC_WRITE fILE_SHARE_NONE Nothing
h <- createFile (fromOsPath lck) gENERIC_WRITE fILE_SHARE_NONE Nothing
cREATE_NEW fILE_ATTRIBUTE_NORMAL Nothing
#endif
return (LockHandle lck h)

82
Git/LsFiles.hs
View file

@ -39,14 +39,13 @@ import Git.Sha
import Utility.InodeCache
import Utility.TimeStamp
import Utility.Attoparsec
import qualified Utility.RawFilePath as R
import qualified Utility.OsString as OS
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.
-
@ -78,20 +77,22 @@ opParam ErrorUnmatch = Param "--error-unmatch"
{- Lists files that are checked into git's index at the specified paths.
- With no paths, all files are listed.
-}
inRepo :: [Options] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
inRepo :: [Options] -> [OsPath] -> Repo -> IO ([OsPath], IO Bool)
inRepo = inRepo' [Param "--cached"]
inRepo' :: [CommandParam] -> [Options] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
inRepo' ps os l repo = guardSafeForLsFiles repo $ pipeNullSplit' params repo
inRepo' :: [CommandParam] -> [Options] -> [OsPath] -> Repo -> IO ([OsPath], IO Bool)
inRepo' ps os l repo = guardSafeForLsFiles repo $ do
(fs, cleanup) <- pipeNullSplit' params repo
return (map toOsPath fs, cleanup)
where
params =
Param "ls-files" :
Param "-z" :
map opParam os ++ ps ++
(Param "--" : map (File . fromRawFilePath) l)
(Param "--" : map (File . fromOsPath) l)
{- Lists the same files inRepo does, but with sha and mode. -}
inRepoDetails :: [Options] -> [RawFilePath] -> Repo -> IO ([(RawFilePath, Sha, FileMode)], IO Bool)
inRepoDetails :: [Options] -> [OsPath] -> Repo -> IO ([(OsPath, Sha, FileMode)], IO Bool)
inRepoDetails = stagedDetails' parser . map opParam
where
parser s = case parseStagedDetails s of
@ -102,17 +103,17 @@ inRepoDetails = stagedDetails' parser . map opParam
{- Files that are checked into the index or have been committed to a
- branch. -}
inRepoOrBranch :: Branch -> [Options] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
inRepoOrBranch :: Branch -> [Options] -> [OsPath] -> Repo -> IO ([OsPath], IO Bool)
inRepoOrBranch b = inRepo'
[ Param "--cached"
, Param ("--with-tree=" ++ fromRef b)
]
{- Scans for files at the specified locations that are not checked into git. -}
notInRepo :: [Options] -> Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
notInRepo :: [Options] -> Bool -> [OsPath] -> Repo -> IO ([OsPath], IO Bool)
notInRepo = notInRepo' []
notInRepo' :: [CommandParam] -> [Options] -> Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
notInRepo' :: [CommandParam] -> [Options] -> Bool -> [OsPath] -> Repo -> IO ([OsPath], IO Bool)
notInRepo' ps os include_ignored =
inRepo' (Param "--others" : ps ++ exclude) os
where
@ -122,41 +123,42 @@ notInRepo' ps os include_ignored =
{- Scans for files at the specified locations that are not checked into
- git. Empty directories are included in the result. -}
notInRepoIncludingEmptyDirectories :: [Options] -> Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
notInRepoIncludingEmptyDirectories :: [Options] -> Bool -> [OsPath] -> Repo -> IO ([OsPath], IO Bool)
notInRepoIncludingEmptyDirectories = notInRepo' [Param "--directory"]
{- Finds all files in the specified locations, whether checked into git or
- not. -}
allFiles :: [Options] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
allFiles :: [Options] -> [OsPath] -> Repo -> IO ([OsPath], IO Bool)
allFiles = inRepo' [Param "--cached", Param "--others"]
{- Returns a list of files in the specified locations that have been
- deleted. -}
deleted :: [Options] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
deleted :: [Options] -> [OsPath] -> Repo -> IO ([OsPath], IO Bool)
deleted = inRepo' [Param "--deleted"]
{- Returns a list of files in the specified locations that have been
- modified. -}
modified :: [Options] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
modified :: [Options] -> [OsPath] -> Repo -> IO ([OsPath], IO Bool)
modified = inRepo' [Param "--modified"]
{- Returns a list of all files that are staged for commit. -}
staged :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
staged :: [OsPath] -> Repo -> IO ([OsPath], IO Bool)
staged = staged' []
{- Returns a list of the files, staged for commit, that are being added,
- moved, or changed (but not deleted), from the specified locations. -}
stagedNotDeleted :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
stagedNotDeleted :: [OsPath] -> Repo -> IO ([OsPath], IO Bool)
stagedNotDeleted = staged' [Param "--diff-filter=ACMRT"]
staged' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
staged' ps l repo = guardSafeForLsFiles repo $
pipeNullSplit' (prefix ++ ps ++ suffix) repo
staged' :: [CommandParam] -> [OsPath] -> Repo -> IO ([OsPath], IO Bool)
staged' ps l repo = guardSafeForLsFiles repo $ do
(fs, cleanup) <- pipeNullSplit' (prefix ++ ps ++ suffix) repo
return (map toOsPath fs, cleanup)
where
prefix = [Param "diff", Param "--cached", Param "--name-only", Param "-z"]
suffix = Param "--" : map (File . fromRawFilePath) l
suffix = Param "--" : map (File . fromOsPath) l
type StagedDetails = (RawFilePath, Sha, FileMode, StageNum)
type StagedDetails = (OsPath, Sha, FileMode, StageNum)
type StageNum = Int
@ -174,16 +176,16 @@ mergeConflictHeadStageNum = 2
- Note that, during a conflict, a file will appear in the list
- more than once with different stage numbers.
-}
stagedDetails :: [RawFilePath] -> Repo -> IO ([StagedDetails], IO Bool)
stagedDetails :: [OsPath] -> Repo -> IO ([StagedDetails], IO Bool)
stagedDetails = stagedDetails' parseStagedDetails []
stagedDetails' :: (S.ByteString -> Maybe t) -> [CommandParam] -> [RawFilePath] -> Repo -> IO ([t], IO Bool)
stagedDetails' :: (S.ByteString -> Maybe t) -> [CommandParam] -> [OsPath] -> Repo -> IO ([t], IO Bool)
stagedDetails' parser ps l repo = guardSafeForLsFiles repo $ do
(ls, cleanup) <- pipeNullSplit' params repo
return (mapMaybe parser ls, cleanup)
where
params = Param "ls-files" : Param "--stage" : Param "-z" : ps ++
Param "--" : map (File . fromRawFilePath) l
Param "--" : map (File . fromOsPath) l
parseStagedDetails :: S.ByteString -> Maybe StagedDetails
parseStagedDetails = eitherToMaybe . A.parseOnly parser
@ -196,28 +198,28 @@ parseStagedDetails = eitherToMaybe . A.parseOnly parser
stagenum <- A8.decimal
void $ A8.char '\t'
file <- A.takeByteString
return (file, sha, mode, stagenum)
return (toOsPath file, sha, mode, stagenum)
nextword = A8.takeTill (== ' ')
{- Returns a list of the files in the specified locations that are staged
- for commit, and whose type has changed. -}
typeChangedStaged :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
typeChangedStaged :: [OsPath] -> Repo -> IO ([OsPath], IO Bool)
typeChangedStaged = typeChanged' [Param "--cached"]
{- Returns a list of the files in the specified locations whose type has
- changed. Files only staged for commit will not be included. -}
typeChanged :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
typeChanged :: [OsPath] -> Repo -> IO ([OsPath], IO Bool)
typeChanged = typeChanged' []
typeChanged' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
typeChanged' :: [CommandParam] -> [OsPath] -> Repo -> IO ([OsPath], IO Bool)
typeChanged' ps l repo = guardSafeForLsFiles 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)
currdir <- R.getCurrentDirectory
return (map (\f -> relPathDirToFileAbs currdir $ top P.</> f) fs, cleanup)
currdir <- getCurrentDirectory
return (map (\f -> relPathDirToFileAbs currdir $ top </> toOsPath f) fs, cleanup)
where
prefix =
[ Param "diff"
@ -225,7 +227,7 @@ typeChanged' ps l repo = guardSafeForLsFiles repo $ do
, Param "--diff-filter=T"
, Param "-z"
]
suffix = Param "--" : (if null l then [File "."] else map (File . fromRawFilePath) l)
suffix = Param "--" : (if null l then [File "."] else map (File . fromOsPath) l)
{- A item in conflict has two possible values.
- Either can be Nothing, when that side deleted the file. -}
@ -235,10 +237,10 @@ data Conflicting v = Conflicting
} deriving (Show)
data Unmerged = Unmerged
{ unmergedFile :: RawFilePath
{ unmergedFile :: OsPath
, unmergedTreeItemType :: Conflicting TreeItemType
, unmergedSha :: Conflicting Sha
, unmergedSiblingFile :: Maybe RawFilePath
, unmergedSiblingFile :: Maybe OsPath
-- ^ Normally this is Nothing, because a
-- merge conflict is represented as a single file with two
-- stages. However, git resolvers sometimes choose to stage
@ -257,7 +259,7 @@ data Unmerged = Unmerged
- 3 = them
- If line 2 or 3 is omitted, that side removed the file.
-}
unmerged :: [RawFilePath] -> Repo -> IO ([Unmerged], IO Bool)
unmerged :: [OsPath] -> Repo -> IO ([Unmerged], IO Bool)
unmerged l repo = guardSafeForLsFiles repo $ do
(fs, cleanup) <- pipeNullSplit params repo
return (reduceUnmerged [] $ catMaybes $ map (parseUnmerged . decodeBL) fs, cleanup)
@ -267,11 +269,11 @@ unmerged l repo = guardSafeForLsFiles repo $ do
Param "--unmerged" :
Param "-z" :
Param "--" :
map (File . fromRawFilePath) l
map (File . fromOsPath) l
data InternalUnmerged = InternalUnmerged
{ isus :: Bool
, ifile :: RawFilePath
, ifile :: OsPath
, itreeitemtype :: Maybe TreeItemType
, isha :: Maybe Sha
} deriving (Show)
@ -287,7 +289,7 @@ parseUnmerged s
else do
treeitemtype <- readTreeItemType (encodeBS rawtreeitemtype)
sha <- extractSha (encodeBS rawsha)
return $ InternalUnmerged (stage == 2) (toRawFilePath file)
return $ InternalUnmerged (stage == 2) (toOsPath file)
(Just treeitemtype) (Just sha)
_ -> Nothing
where
@ -321,7 +323,7 @@ reduceUnmerged c (i:is) = reduceUnmerged (new:c) rest
-- foo~<ref> are unmerged sibling files of foo
-- Some versions or resolvers of git stage the sibling files,
-- other versions or resolvers do not.
issibfile x y = (ifile x <> "~") `S.isPrefixOf` ifile y
issibfile x y = (ifile x <> literalOsPath "~") `OS.isPrefixOf` ifile y
&& isus x || isus y
&& not (isus x && isus y)
@ -330,7 +332,7 @@ reduceUnmerged c (i:is) = reduceUnmerged (new:c) rest
- Note that this uses a --debug option whose output could change at some
- point in the future. If the output is not as expected, will use Nothing.
-}
inodeCaches :: [RawFilePath] -> Repo -> IO ([(FilePath, Maybe InodeCache)], IO Bool)
inodeCaches :: [OsPath] -> Repo -> IO ([(FilePath, Maybe InodeCache)], IO Bool)
inodeCaches locs repo = guardSafeForLsFiles repo $ do
(ls, cleanup) <- pipeNullSplit params repo
return (parse Nothing (map decodeBL ls), cleanup)
@ -341,7 +343,7 @@ inodeCaches locs repo = guardSafeForLsFiles repo $ do
Param "-z" :
Param "--debug" :
Param "--" :
map (File . fromRawFilePath) locs
map (File . fromOsPath) locs
parse Nothing (f:ls) = parse (Just f) ls
parse (Just f) (s:[]) =

16
Git/Objects.hs
View file

@ -12,6 +12,7 @@ module Git.Objects where
import Common
import Git
import Git.Sha
import qualified Utility.OsString as OS
import qualified Data.ByteString as B
import qualified System.FilePath.ByteString as P
@ -31,10 +32,19 @@ listPackFiles r = filter (".pack" `B.isSuffixOf`)
listLooseObjectShas :: Repo -> IO [Sha]
listLooseObjectShas r = catchDefaultIO [] $
mapMaybe (extractSha . encodeBS . concat . reverse . take 2 . reverse . splitDirectories . decodeBS)
<$> emptyWhenDoesNotExist (dirContentsRecursiveSkipping (== "pack") True (objectsDir r))
mapMaybe conv <$> emptyWhenDoesNotExist
(dirContentsRecursiveSkipping (== "pack") True (objectsDir r))
where
conv :: OsPath -> Maybe Sha
conv = extractSha
. fromOsPath
. OS.concat
. reverse
. take 2
. reverse
. splitDirectories
looseObjectFile :: Repo -> Sha -> RawFilePath
looseObjectFile :: Repo -> Sha -> OsPath
looseObjectFile r sha = objectsDir r P.</> prefix P.</> rest
where
(prefix, rest) = B.splitAt 2 (fromRef' sha)

6
Git/Quote.hs
View file

@ -77,11 +77,11 @@ instance Quoteable RawFilePath where
data StringContainingQuotedPath
= UnquotedString String
| UnquotedByteString S.ByteString
| QuotedPath RawFilePath
| QuotedPath OsPath
| StringContainingQuotedPath :+: StringContainingQuotedPath
deriving (Show, Eq)
quotedPaths :: [RawFilePath] -> StringContainingQuotedPath
quotedPaths :: [OsPath] -> StringContainingQuotedPath
quotedPaths [] = mempty
quotedPaths (p:ps) = QuotedPath p <> if null ps
then mempty
@ -117,6 +117,6 @@ instance Monoid StringContainingQuotedPath where
-- limits what's tested to ascii, so avoids running into it.
prop_quote_unquote_roundtrip :: TestableFilePath -> Bool
prop_quote_unquote_roundtrip ts =
s == fromRawFilePath (unquote (quoteAlways (toRawFilePath s)))
s == fromOsPath (unquote (quoteAlways (toOsPath s)))
where
s = fromTestableFilePath ts

4
Utility/CopyFile.hs
View file

@ -48,7 +48,7 @@ copyFileExternal :: CopyMetaData -> FilePath -> FilePath -> IO Bool
copyFileExternal meta src dest = do
-- Delete any existing dest file because an unwritable file
-- would prevent cp from working.
void $ tryIO $ removeFile dest
void $ tryIO $ removeFile (toOsPath dest)
boolSystem "cp" $ params ++ [File src, File dest]
where
params
@ -76,7 +76,7 @@ copyCoW meta src dest
-- When CoW is not supported, cp creates the destination
-- file but leaves it empty.
unless ok $
void $ tryIO $ removeFile dest
void $ tryIO $ removeFile $ toOsPath dest
return ok
| otherwise = return False
where

38
Utility/Directory.hs
View file

@ -30,18 +30,14 @@ import Utility.Exception
import Utility.Monad
import qualified Utility.RawFilePath as R
dirCruft :: R.RawFilePath -> Bool
dirCruft "." = True
dirCruft ".." = True
dirCruft _ = False
dirCruft :: [OsPath]
dirCruft = [literalOsPath ".", literalOsPath ".."]
{- Lists the contents of a directory.
- Unlike getDirectoryContents, paths are not relative to the directory. -}
dirContents :: RawFilePath -> IO [RawFilePath]
dirContents d =
map (\p -> d P.</> fromOsPath p)
. filter (not . dirCruft . fromOsPath)
<$> getDirectoryContents (toOsPath d)
dirContents :: OsPath -> IO [OsPath]
dirContents d = map (d </>) . filter (`notElem` dirCruft)
<$> getDirectoryContents d
{- Gets files in a directory, and then its subdirectories, recursively,
- and lazily.
@ -53,13 +49,13 @@ dirContents d =
- be accessed (the use of unsafeInterleaveIO would make it difficult to
- trap such exceptions).
-}
dirContentsRecursive :: RawFilePath -> IO [RawFilePath]
dirContentsRecursive :: OsPath -> IO [OsPath]
dirContentsRecursive = dirContentsRecursiveSkipping (const False) True
{- Skips directories whose basenames match the skipdir. -}
dirContentsRecursiveSkipping :: (RawFilePath -> Bool) -> Bool -> RawFilePath -> IO [RawFilePath]
dirContentsRecursiveSkipping :: (OsPath -> Bool) -> Bool -> OsPath -> IO [OsPath]
dirContentsRecursiveSkipping skipdir followsubdirsymlinks topdir
| skipdir (P.takeFileName topdir) = return []
| skipdir (takeFileName topdir) = return []
| otherwise = do
-- Get the contents of the top directory outside of
-- unsafeInterleaveIO, which allows throwing exceptions if
@ -71,26 +67,26 @@ dirContentsRecursiveSkipping skipdir followsubdirsymlinks topdir
where
go [] = return []
go (dir:dirs)
| skipdir (P.takeFileName dir) = go dirs
| skipdir (takeFileName dir) = go dirs
| otherwise = unsafeInterleaveIO $ do
(files, dirs') <- collect [] []
=<< catchDefaultIO [] (dirContents dir)
files' <- go (dirs' ++ dirs)
return (files ++ files')
collect :: [RawFilePath] -> [RawFilePath] -> [RawFilePath] -> IO ([RawFilePath], [RawFilePath])
collect :: [OsPath] -> [OsPath] -> [OsPath] -> IO ([OsPath], [OsPath])
collect files dirs' [] = return (reverse files, reverse dirs')
collect files dirs' (entry:entries)
| dirCruft entry = collect files dirs' entries
| entry `elem` dirCruft = collect files dirs' entries
| otherwise = do
let skip = collect (entry:files) dirs' entries
let recurse = collect files (entry:dirs') entries
ms <- catchMaybeIO $ R.getSymbolicLinkStatus entry
ms <- catchMaybeIO $ R.getSymbolicLinkStatus (fromOsPath entry)
case ms of
(Just s)
| isDirectory s -> recurse
| isSymbolicLink s && followsubdirsymlinks ->
ifM (doesDirectoryExist (toOsPath entry))
ifM (doesDirectoryExist entry)
( recurse
, skip
)
@ -105,22 +101,22 @@ dirContentsRecursiveSkipping skipdir followsubdirsymlinks topdir
- be accessed (the use of unsafeInterleaveIO would make it difficult to
- trap such exceptions).
-}
dirTreeRecursiveSkipping :: (RawFilePath -> Bool) -> RawFilePath -> IO [RawFilePath]
dirTreeRecursiveSkipping :: (OsPath -> Bool) -> OsPath -> IO [OsPath]
dirTreeRecursiveSkipping skipdir topdir
| skipdir (P.takeFileName topdir) = return []
| skipdir (takeFileName topdir) = return []
| otherwise = do
subdirs <- filterM isdir =<< dirContents topdir
go [] subdirs
where
go c [] = return c
go c (dir:dirs)
| skipdir (P.takeFileName dir) = go c dirs
| skipdir (takeFileName dir) = go c dirs
| otherwise = unsafeInterleaveIO $ do
subdirs <- go []
=<< filterM isdir
=<< catchDefaultIO [] (dirContents dir)
go (subdirs++dir:c) dirs
isdir p = isDirectory <$> R.getSymbolicLinkStatus p
isdir p = isDirectory <$> R.getSymbolicLinkStatus (fromOsPath p)
{- When the action fails due to the directory not existing, returns []. -}
emptyWhenDoesNotExist :: IO [a] -> IO [a]

28
Utility/Directory/Create.hs
View file

@ -20,13 +20,13 @@ import Control.Monad.IO.Class
import Control.Monad.IfElse
import System.IO.Error
import Data.Maybe
import qualified System.FilePath.ByteString as P
import Prelude
import Utility.SystemDirectory
import Utility.Path.AbsRel
import Utility.Exception
import Utility.FileSystemEncoding
import Utility.OsPath
import qualified Utility.RawFilePath as R
import Utility.PartialPrelude
@ -51,39 +51,39 @@ import Utility.PartialPrelude
- Note that, the second FilePath, if relative, is relative to the current
- working directory.
-}
createDirectoryUnder :: [RawFilePath] -> RawFilePath -> IO ()
createDirectoryUnder :: [OsPath] -> OsPath -> IO ()
createDirectoryUnder topdirs dir =
createDirectoryUnder' topdirs dir R.createDirectory
createDirectoryUnder' topdirs dir createDirectory
createDirectoryUnder'
:: (MonadIO m, MonadCatch m)
=> [RawFilePath]
-> RawFilePath
-> (RawFilePath -> m ())
=> [OsPath]
-> OsPath
-> (OsPath -> m ())
-> m ()
createDirectoryUnder' topdirs dir0 mkdir = do
relps <- liftIO $ forM topdirs $ \topdir -> relPathDirToFile topdir dir0
let relparts = map P.splitDirectories relps
let relparts = map splitDirectories relps
-- Catch cases where dir0 is not beneath a topdir.
-- If the relative path between them starts with "..",
-- it's not. And on Windows, if they are on different drives,
-- the path will not be relative.
let notbeneath = \(_topdir, (relp, dirs)) ->
headMaybe dirs /= Just ".." && not (P.isAbsolute relp)
headMaybe dirs /= Just ".." && not (isAbsolute relp)
case filter notbeneath $ zip topdirs (zip relps relparts) of
((topdir, (_relp, dirs)):_)
-- If dir0 is the same as the topdir, don't try to
-- create it, but make sure it does exist.
| null dirs ->
liftIO $ unlessM (doesDirectoryExist (fromRawFilePath topdir)) $
liftIO $ unlessM (doesDirectoryExist topdir) $
ioError $ customerror doesNotExistErrorType $
"createDirectoryUnder: " ++ fromRawFilePath topdir ++ " does not exist"
"createDirectoryUnder: " ++ fromOsPath topdir ++ " does not exist"
| otherwise -> createdirs $
map (topdir P.</>) (reverse (scanl1 (P.</>) dirs))
map (topdir </>) (reverse (scanl1 (</>) dirs))
_ -> liftIO $ ioError $ customerror userErrorType
("createDirectoryUnder: not located in " ++ unwords (map fromRawFilePath topdirs))
("createDirectoryUnder: not located in " ++ unwords (map fromOsPath topdirs))
where
customerror t s = mkIOError t s Nothing (Just (fromRawFilePath dir0))
customerror t s = mkIOError t s Nothing (Just (fromOsPath dir0))
createdirs [] = pure ()
createdirs (dir:[]) = createdir dir (liftIO . ioError)
@ -100,6 +100,6 @@ createDirectoryUnder' topdirs dir0 mkdir = do
Left e
| isDoesNotExistError e -> notexisthandler e
| isAlreadyExistsError e || isPermissionError e ->
liftIO $ unlessM (doesDirectoryExist (fromRawFilePath dir)) $
liftIO $ unlessM (doesDirectoryExist dir) $
ioError e
| otherwise -> liftIO $ ioError e

25
Utility/LinuxMkLibs.hs
View file

@ -27,10 +27,11 @@ import Utility.Split
import Utility.FileSystemEncoding
import Utility.Env
import Utility.Exception
import Utility.OsPath
import Utility.RawFilePath
import Data.Maybe
import System.FilePath
import System.Posix.Files
import System.Posix.Files (isSymbolicLink)
import Data.Char
import Control.Monad.IfElse
import Control.Applicative
@ -39,7 +40,7 @@ import Prelude
{- Installs a library. If the library is a symlink to another file,
- install the file it links to, and update the symlink to be relative. -}
installLib :: (FilePath -> FilePath -> IO ()) -> FilePath -> FilePath -> IO (Maybe FilePath)
installLib installfile top lib = ifM (doesFileExist lib)
installLib installfile top lib = ifM (doesFileExist (toOsPath lib))
( do
installfile top lib
checksymlink lib
@ -50,17 +51,17 @@ installLib installfile top lib = ifM (doesFileExist lib)
checksymlink f = whenM (isSymbolicLink <$> getSymbolicLinkStatus (inTop top f)) $ do
l <- readSymbolicLink (inTop top f)
let absl = absPathFrom
(parentDir (toRawFilePath f))
(toRawFilePath l)
target <- relPathDirToFile (toRawFilePath (takeDirectory f)) absl
installfile top (fromRawFilePath absl)
removeWhenExistsWith removeLink (top ++ f)
createSymbolicLink (fromRawFilePath target) (inTop top f)
checksymlink (fromRawFilePath absl)
(parentDir (toOsPath f))
(toOsPath l)
target <- relPathDirToFile (takeDirectory (toOsPath f)) absl
installfile top (fromOsPath absl)
removeWhenExistsWith removeLink (toRawFilePath (top ++ f))
createSymbolicLink (fromOsPath target) (inTop top f)
checksymlink (fromOsPath absl)
-- Note that f is not relative, so cannot use </>
inTop :: FilePath -> FilePath -> FilePath
inTop top f = top ++ f
inTop :: FilePath -> FilePath -> RawFilePath
inTop top f = toRawFilePath $ top ++ f
{- Parse ldd output, getting all the libraries that the input files
- link to. Note that some of the libraries may not exist