diff --git a/Config/Files.hs b/Config/Files.hs index 801c626845..84abdc866d 100644 --- a/Config/Files.hs +++ b/Config/Files.hs @@ -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 diff --git a/Config/Files/AutoStart.hs b/Config/Files/AutoStart.hs index 1b49c81e20..7307e46d5c 100644 --- a/Config/Files/AutoStart.hs +++ b/Config/Files/AutoStart.hs @@ -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 diff --git a/Git.hs b/Git.hs index 9626cf58e5..74207c2589 100644 --- a/Git.hs +++ b/Git.hs @@ -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 diff --git a/Git/CheckAttr.hs b/Git/CheckAttr.hs index f93c9075cf..5c3248ff9d 100644 --- a/Git/CheckAttr.hs +++ b/Git/CheckAttr.hs @@ -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 diff --git a/Git/Command.hs b/Git/Command.hs index 894f6ae689..ec4db40d53 100644 --- a/Git/Command.hs +++ b/Git/Command.hs @@ -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. -} diff --git a/Git/Env.hs b/Git/Env.hs index fb0377f85d..6bf773f9d0 100644 --- a/Git/Env.hs +++ b/Git/Env.hs @@ -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'') diff --git a/Git/FilePath.hs b/Git/FilePath.hs index d562262ae1..b184264ab0 100644 --- a/Git/FilePath.hs +++ b/Git/FilePath.hs @@ -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) diff --git a/Git/HashObject.hs b/Git/HashObject.hs index 0d3d9eaa28..2eefc52734 100644 --- a/Git/HashObject.hs +++ b/Git/HashObject.hs @@ -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. - diff --git a/Git/LockFile.hs b/Git/LockFile.hs index fa92df046e..70d8e5bb54 100644 --- a/Git/LockFile.hs +++ b/Git/LockFile.hs @@ -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) diff --git a/Git/LsFiles.hs b/Git/LsFiles.hs index 08c98b7fda..9057a7bb5b 100644 --- a/Git/LsFiles.hs +++ b/Git/LsFiles.hs @@ -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~ 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:[]) = diff --git a/Git/Objects.hs b/Git/Objects.hs index b66b0b5e19..6c4a87b909 100644 --- a/Git/Objects.hs +++ b/Git/Objects.hs @@ -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) diff --git a/Git/Quote.hs b/Git/Quote.hs index 2ca442ecb6..a8d67ab4d5 100644 --- a/Git/Quote.hs +++ b/Git/Quote.hs @@ -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 diff --git a/Utility/CopyFile.hs b/Utility/CopyFile.hs index 207153d1b6..49a7388fef 100644 --- a/Utility/CopyFile.hs +++ b/Utility/CopyFile.hs @@ -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 diff --git a/Utility/Directory.hs b/Utility/Directory.hs index 3c4855ea55..92ec88b00f 100644 --- a/Utility/Directory.hs +++ b/Utility/Directory.hs @@ -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] diff --git a/Utility/Directory/Create.hs b/Utility/Directory/Create.hs index d97ee026e0..9acc0146ac 100644 --- a/Utility/Directory/Create.hs +++ b/Utility/Directory/Create.hs @@ -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 diff --git a/Utility/LinuxMkLibs.hs b/Utility/LinuxMkLibs.hs index ec482a1465..ac329f4df0 100644 --- a/Utility/LinuxMkLibs.hs +++ b/Utility/LinuxMkLibs.hs @@ -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