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 -} {- ~/.config/git-annex/file -}
userConfigFile :: OsPath -> IO OsPath userConfigFile :: OsPath -> IO OsPath
userConfigFile file = do userConfigFile file = do
dir <- toOsPath <$> userConfigDir dir <- userConfigDir
return $ dir </> literalOsPath "git-annex" </> file return $ dir </> literalOsPath "git-annex" </> file
autoStartFile :: IO OsPath autoStartFile :: IO OsPath

3
Config/Files/AutoStart.hs
View file

@ -30,8 +30,7 @@ modifyAutoStartFile func = do
when (dirs' /= dirs) $ do when (dirs' /= dirs) $ do
f <- autoStartFile f <- autoStartFile
createDirectoryIfMissing True (parentDir f) createDirectoryIfMissing True (parentDir f)
viaTmp (writeFile . fromRawFilePath . fromOsPath) viaTmp (writeFile . fromRawFilePath . fromOsPath) f
(toOsPath f)
(unlines (map fromOsPath dirs')) (unlines (map fromOsPath 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

33
Git.hs
View file

@ -47,6 +47,7 @@ import qualified System.FilePath.ByteString as P
import Common import Common
import Git.Types import Git.Types
import qualified Utility.OsString as OS
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
import Utility.FileMode import Utility.FileMode
#endif #endif
@ -56,32 +57,32 @@ repoDescribe :: Repo -> String
repoDescribe Repo { remoteName = Just name } = name repoDescribe Repo { remoteName = Just name } = name
repoDescribe Repo { location = Url url } = show url repoDescribe Repo { location = Url url } = show url
repoDescribe Repo { location = UnparseableUrl url } = url repoDescribe Repo { location = UnparseableUrl url } = url
repoDescribe Repo { location = Local { worktree = Just dir } } = fromRawFilePath dir repoDescribe Repo { location = Local { worktree = Just dir } } = fromOsPath dir
repoDescribe Repo { location = Local { gitdir = dir } } = fromRawFilePath dir repoDescribe Repo { location = Local { gitdir = dir } } = fromOsPath dir
repoDescribe Repo { location = LocalUnknown dir } = fromRawFilePath dir repoDescribe Repo { location = LocalUnknown dir } = fromOsPath dir
repoDescribe Repo { location = Unknown } = "UNKNOWN" repoDescribe Repo { location = Unknown } = "UNKNOWN"
{- Location of the repo, either as a path or url. -} {- Location of the repo, either as a path or url. -}
repoLocation :: Repo -> String repoLocation :: Repo -> String
repoLocation Repo { location = Url url } = show url repoLocation Repo { location = Url url } = show url
repoLocation Repo { location = UnparseableUrl url } = url repoLocation Repo { location = UnparseableUrl url } = url
repoLocation Repo { location = Local { worktree = Just dir } } = fromRawFilePath dir repoLocation Repo { location = Local { worktree = Just dir } } = fromOsPath dir
repoLocation Repo { location = Local { gitdir = dir } } = fromRawFilePath dir repoLocation Repo { location = Local { gitdir = dir } } = fromOsPath dir
repoLocation Repo { location = LocalUnknown dir } = fromRawFilePath dir repoLocation Repo { location = LocalUnknown dir } = fromOsPath dir
repoLocation Repo { location = Unknown } = giveup "unknown repoLocation" repoLocation Repo { location = Unknown } = giveup "unknown repoLocation"
{- Path to a repository. For non-bare, this is the worktree, for bare, {- 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 - it's the gitdir, and for URL repositories, is the path on the remote
- host. -} - host. -}
repoPath :: Repo -> RawFilePath repoPath :: Repo -> OsPath
repoPath Repo { location = Url u } = toRawFilePath $ unEscapeString $ uriPath u repoPath Repo { location = Url u } = toOsPath $ unEscapeString $ uriPath u
repoPath Repo { location = Local { worktree = Just d } } = d repoPath Repo { location = Local { worktree = Just d } } = d
repoPath Repo { location = Local { gitdir = d } } = d repoPath Repo { location = Local { gitdir = d } } = d
repoPath Repo { location = LocalUnknown dir } = dir repoPath Repo { location = LocalUnknown dir } = dir
repoPath Repo { location = Unknown } = giveup "unknown repoPath" repoPath Repo { location = Unknown } = giveup "unknown repoPath"
repoPath Repo { location = UnparseableUrl _u } = 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 Repo { location = Local { worktree = Just d } } = Just d
repoWorkTree _ = Nothing repoWorkTree _ = Nothing
@ -137,13 +138,13 @@ assertLocal repo action
| otherwise = action | otherwise = action
{- Path to a repository's gitattributes file. -} {- Path to a repository's gitattributes file. -}
attributes :: Repo -> RawFilePath attributes :: Repo -> OsPath
attributes repo attributes repo
| repoIsLocalBare repo = attributesLocal repo | repoIsLocalBare repo = attributesLocal repo
| otherwise = repoPath repo P.</> ".gitattributes" | otherwise = repoPath repo </> literalOsPath ".gitattributes"
attributesLocal :: Repo -> RawFilePath attributesLocal :: Repo -> OsPath
attributesLocal repo = localGitDir repo P.</> "info" P.</> "attributes" attributesLocal repo = localGitDir repo </> literalOsPath "info" </> literalOsPath "attributes"
{- Path to a given hook script in a repository, only if the hook exists {- Path to a given hook script in a repository, only if the hook exists
- and is executable. -} - and is executable. -}
@ -166,10 +167,12 @@ relPath = adjustPath torel
where where
torel p = do torel p = do
p' <- relPathCwdToFile p 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. -} {- 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 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

13
Git/CheckAttr.hs
View file

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

4
Git/Command.hs
View file

@ -24,10 +24,10 @@ gitCommandLine params r@(Repo { location = l@(Local { } ) }) =
where where
setdir setdir
| gitEnvOverridesGitDir r = [] | gitEnvOverridesGitDir r = []
| otherwise = [Param $ "--git-dir=" ++ fromRawFilePath (gitdir l)] | otherwise = [Param $ "--git-dir=" ++ fromOsPath (gitdir l)]
settree = case worktree l of settree = case worktree l of
Nothing -> [] Nothing -> []
Just t -> [Param $ "--work-tree=" ++ fromRawFilePath t] Just t -> [Param $ "--work-tree=" ++ fromOsPath t]
gitCommandLine _ repo = assertLocal repo $ error "internal" gitCommandLine _ repo = assertLocal repo $ error "internal"
{- Runs git in the specified repo. -} {- 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. -} - and a copy of the rest of the system environment. -}
propGitEnv :: Repo -> IO [(String, String)] propGitEnv :: Repo -> IO [(String, String)]
propGitEnv g = do propGitEnv g = do
g' <- addGitEnv g "GIT_DIR" (fromRawFilePath (localGitDir g)) g' <- addGitEnv g "GIT_DIR" (fromOsPath (localGitDir g))
g'' <- maybe (pure g') g'' <- maybe (pure g')
(addGitEnv g' "GIT_WORK_TREE" . fromRawFilePath) (addGitEnv g' "GIT_WORK_TREE" . fromOsPath)
(repoWorkTree g) (repoWorkTree g)
return $ fromMaybe [] (gitEnv 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, {- isAbsolute on Windows does not think "/foo" or "\foo" is absolute,
- so try posix paths. - so try posix paths.
-} -}
absoluteGitPath :: RawFilePath -> Bool absoluteGitPath :: OsPath -> Bool
absoluteGitPath p = isAbsolute p || isAbsolute (toInternalGitPath p) absoluteGitPath p = isAbsolute p || isAbsolute (toInternalGitPath p)

20
Git/HashObject.hs
View file

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

14
Git/LockFile.hs
View file

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

82
Git/LsFiles.hs
View file

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

16
Git/Objects.hs
View file

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

6
Git/Quote.hs
View file

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

4
Utility/CopyFile.hs
View file

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

38
Utility/Directory.hs
View file

@ -30,18 +30,14 @@ import Utility.Exception
import Utility.Monad import Utility.Monad
import qualified Utility.RawFilePath as R import qualified Utility.RawFilePath as R
dirCruft :: R.RawFilePath -> Bool dirCruft :: [OsPath]
dirCruft "." = True dirCruft = [literalOsPath ".", literalOsPath ".."]
dirCruft ".." = True
dirCruft _ = False
{- Lists the contents of a directory. {- Lists the contents of a directory.
- Unlike getDirectoryContents, paths are not relative to the directory. -} - Unlike getDirectoryContents, paths are not relative to the directory. -}
dirContents :: RawFilePath -> IO [RawFilePath] dirContents :: OsPath -> IO [OsPath]
dirContents d = dirContents d = map (d </>) . filter (`notElem` dirCruft)
map (\p -> d P.</> fromOsPath p) <$> getDirectoryContents d
. filter (not . dirCruft . fromOsPath)
<$> getDirectoryContents (toOsPath d)
{- Gets files in a directory, and then its subdirectories, recursively, {- Gets files in a directory, and then its subdirectories, recursively,
- and lazily. - and lazily.
@ -53,13 +49,13 @@ dirContents d =
- be accessed (the use of unsafeInterleaveIO would make it difficult to - be accessed (the use of unsafeInterleaveIO would make it difficult to
- trap such exceptions). - trap such exceptions).
-} -}
dirContentsRecursive :: RawFilePath -> IO [RawFilePath] dirContentsRecursive :: OsPath -> IO [OsPath]
dirContentsRecursive = dirContentsRecursiveSkipping (const False) True dirContentsRecursive = dirContentsRecursiveSkipping (const False) True
{- Skips directories whose basenames match the skipdir. -} {- 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 dirContentsRecursiveSkipping skipdir followsubdirsymlinks topdir
| skipdir (P.takeFileName topdir) = return [] | skipdir (takeFileName topdir) = return []
| otherwise = do | otherwise = do
-- Get the contents of the top directory outside of -- Get the contents of the top directory outside of
-- unsafeInterleaveIO, which allows throwing exceptions if -- unsafeInterleaveIO, which allows throwing exceptions if
@ -71,26 +67,26 @@ dirContentsRecursiveSkipping skipdir followsubdirsymlinks topdir
where where
go [] = return [] go [] = return []
go (dir:dirs) go (dir:dirs)
| skipdir (P.takeFileName dir) = go dirs | skipdir (takeFileName dir) = go dirs
| otherwise = unsafeInterleaveIO $ do | otherwise = unsafeInterleaveIO $ do
(files, dirs') <- collect [] [] (files, dirs') <- collect [] []
=<< catchDefaultIO [] (dirContents dir) =<< catchDefaultIO [] (dirContents dir)
files' <- go (dirs' ++ dirs) files' <- go (dirs' ++ dirs)
return (files ++ files') 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' [] = return (reverse files, reverse dirs')
collect files dirs' (entry:entries) collect files dirs' (entry:entries)
| dirCruft entry = collect files dirs' entries | entry `elem` dirCruft = collect files dirs' entries
| otherwise = do | otherwise = do
let skip = collect (entry:files) dirs' entries let skip = collect (entry:files) dirs' entries
let recurse = collect files (entry:dirs') entries let recurse = collect files (entry:dirs') entries
ms <- catchMaybeIO $ R.getSymbolicLinkStatus entry ms <- catchMaybeIO $ R.getSymbolicLinkStatus (fromOsPath entry)
case ms of case ms of
(Just s) (Just s)
| isDirectory s -> recurse | isDirectory s -> recurse
| isSymbolicLink s && followsubdirsymlinks -> | isSymbolicLink s && followsubdirsymlinks ->
ifM (doesDirectoryExist (toOsPath entry)) ifM (doesDirectoryExist entry)
( recurse ( recurse
, skip , skip
) )
@ -105,22 +101,22 @@ dirContentsRecursiveSkipping skipdir followsubdirsymlinks topdir
- be accessed (the use of unsafeInterleaveIO would make it difficult to - be accessed (the use of unsafeInterleaveIO would make it difficult to
- trap such exceptions). - trap such exceptions).
-} -}
dirTreeRecursiveSkipping :: (RawFilePath -> Bool) -> RawFilePath -> IO [RawFilePath] dirTreeRecursiveSkipping :: (OsPath -> Bool) -> OsPath -> IO [OsPath]
dirTreeRecursiveSkipping skipdir topdir dirTreeRecursiveSkipping skipdir topdir
| skipdir (P.takeFileName topdir) = return [] | skipdir (takeFileName topdir) = return []
| otherwise = do | otherwise = do
subdirs <- filterM isdir =<< dirContents topdir subdirs <- filterM isdir =<< dirContents topdir
go [] subdirs go [] subdirs
where where
go c [] = return c go c [] = return c
go c (dir:dirs) go c (dir:dirs)
| skipdir (P.takeFileName dir) = go c dirs | skipdir (takeFileName dir) = go c dirs
| otherwise = unsafeInterleaveIO $ do | otherwise = unsafeInterleaveIO $ do
subdirs <- go [] subdirs <- go []
=<< filterM isdir =<< filterM isdir
=<< catchDefaultIO [] (dirContents dir) =<< catchDefaultIO [] (dirContents dir)
go (subdirs++dir:c) dirs 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 []. -} {- When the action fails due to the directory not existing, returns []. -}
emptyWhenDoesNotExist :: IO [a] -> IO [a] 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 Control.Monad.IfElse
import System.IO.Error import System.IO.Error
import Data.Maybe import Data.Maybe
import qualified System.FilePath.ByteString as P
import Prelude import Prelude
import Utility.SystemDirectory import Utility.SystemDirectory
import Utility.Path.AbsRel import Utility.Path.AbsRel
import Utility.Exception import Utility.Exception
import Utility.FileSystemEncoding import Utility.FileSystemEncoding
import Utility.OsPath
import qualified Utility.RawFilePath as R import qualified Utility.RawFilePath as R
import Utility.PartialPrelude import Utility.PartialPrelude
@ -51,39 +51,39 @@ import Utility.PartialPrelude
- Note that, the second FilePath, if relative, is relative to the current - Note that, the second FilePath, if relative, is relative to the current
- working directory. - working directory.
-} -}
createDirectoryUnder :: [RawFilePath] -> RawFilePath -> IO () createDirectoryUnder :: [OsPath] -> OsPath -> IO ()
createDirectoryUnder topdirs dir = createDirectoryUnder topdirs dir =
createDirectoryUnder' topdirs dir R.createDirectory createDirectoryUnder' topdirs dir createDirectory
createDirectoryUnder' createDirectoryUnder'
:: (MonadIO m, MonadCatch m) :: (MonadIO m, MonadCatch m)
=> [RawFilePath] => [OsPath]
-> RawFilePath -> OsPath
-> (RawFilePath -> m ()) -> (OsPath -> m ())
-> m () -> m ()
createDirectoryUnder' topdirs dir0 mkdir = do createDirectoryUnder' topdirs dir0 mkdir = do
relps <- liftIO $ forM topdirs $ \topdir -> relPathDirToFile topdir dir0 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. -- Catch cases where dir0 is not beneath a topdir.
-- If the relative path between them starts with "..", -- If the relative path between them starts with "..",
-- it's not. And on Windows, if they are on different drives, -- it's not. And on Windows, if they are on different drives,
-- the path will not be relative. -- the path will not be relative.
let notbeneath = \(_topdir, (relp, dirs)) -> 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 case filter notbeneath $ zip topdirs (zip relps relparts) of
((topdir, (_relp, dirs)):_) ((topdir, (_relp, dirs)):_)
-- If dir0 is the same as the topdir, don't try to -- If dir0 is the same as the topdir, don't try to
-- create it, but make sure it does exist. -- create it, but make sure it does exist.
| null dirs -> | null dirs ->
liftIO $ unlessM (doesDirectoryExist (fromRawFilePath topdir)) $ liftIO $ unlessM (doesDirectoryExist topdir) $
ioError $ customerror doesNotExistErrorType $ ioError $ customerror doesNotExistErrorType $
"createDirectoryUnder: " ++ fromRawFilePath topdir ++ " does not exist" "createDirectoryUnder: " ++ fromOsPath topdir ++ " does not exist"
| otherwise -> createdirs $ | otherwise -> createdirs $
map (topdir P.</>) (reverse (scanl1 (P.</>) dirs)) map (topdir </>) (reverse (scanl1 (</>) dirs))
_ -> liftIO $ ioError $ customerror userErrorType _ -> liftIO $ ioError $ customerror userErrorType
("createDirectoryUnder: not located in " ++ unwords (map fromRawFilePath topdirs)) ("createDirectoryUnder: not located in " ++ unwords (map fromOsPath topdirs))
where where
customerror t s = mkIOError t s Nothing (Just (fromRawFilePath dir0)) customerror t s = mkIOError t s Nothing (Just (fromOsPath dir0))
createdirs [] = pure () createdirs [] = pure ()
createdirs (dir:[]) = createdir dir (liftIO . ioError) createdirs (dir:[]) = createdir dir (liftIO . ioError)
@ -100,6 +100,6 @@ createDirectoryUnder' topdirs dir0 mkdir = do
Left e Left e
| isDoesNotExistError e -> notexisthandler e | isDoesNotExistError e -> notexisthandler e
| isAlreadyExistsError e || isPermissionError e -> | isAlreadyExistsError e || isPermissionError e ->
liftIO $ unlessM (doesDirectoryExist (fromRawFilePath dir)) $ liftIO $ unlessM (doesDirectoryExist dir) $
ioError e ioError e
| otherwise -> liftIO $ ioError e | otherwise -> liftIO $ ioError e

25
Utility/LinuxMkLibs.hs
View file

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