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

more OsPath conversion

Browse source 
Sponsored-by: Eve
This commit is contained in:
Joey Hess 2025-01-24 14:49:10 -04:00
parent dd01406018
commit aa0f3f31da
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
23 changed files with 155 additions and 166 deletions
Download patch file Download diff file Expand all files Collapse all files

5
Assistant/Install/Menu.hs
View file

@ -12,11 +12,6 @@ module Assistant.Install.Menu where
import Common import Common
import Utility.FreeDesktop import Utility.FreeDesktop
import Utility.FileSystemEncoding
import Utility.Path
import System.IO
import Utility.SystemDirectory
installMenu :: String -> OsPath -> OsPath -> OsPath -> IO () installMenu :: String -> OsPath -> OsPath -> OsPath -> IO ()
#ifdef darwin_HOST_OS #ifdef darwin_HOST_OS

1
Config/Files.hs
View file

@ -11,7 +11,6 @@ module Config.Files where
import Common import Common
import Utility.FreeDesktop import Utility.FreeDesktop
import Utility.Exception
{- ~/.config/git-annex/file -} {- ~/.config/git-annex/file -}
userConfigFile :: OsPath -> IO OsPath userConfigFile :: OsPath -> IO OsPath

4
Git/CatFile.hs
View file

@ -99,11 +99,11 @@ catFileMetaDataStop :: CatFileMetaDataHandle -> IO ()
catFileMetaDataStop = CoProcess.stop . checkFileProcess catFileMetaDataStop = CoProcess.stop . checkFileProcess
{- Reads a file from a specified branch. -} {- Reads a file from a specified branch. -}
catFile :: CatFileHandle -> Branch -> RawFilePath -> IO L.ByteString catFile :: CatFileHandle -> Branch -> OsPath -> IO L.ByteString
catFile h branch file = catObject h $ catFile h branch file = catObject h $
Git.Ref.branchFileRef branch file Git.Ref.branchFileRef branch file
catFileDetails :: CatFileHandle -> Branch -> RawFilePath -> IO (Maybe (L.ByteString, Sha, ObjectType)) catFileDetails :: CatFileHandle -> Branch -> OsPath -> IO (Maybe (L.ByteString, Sha, ObjectType))
catFileDetails h branch file = catObjectDetails h $ catFileDetails h branch file = catObjectDetails h $
Git.Ref.branchFileRef branch file Git.Ref.branchFileRef branch file

7
Git/Config.hs
View file

@ -14,7 +14,6 @@ import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Char8 as S8
import qualified Data.List.NonEmpty as NE import qualified Data.List.NonEmpty as NE
import Data.Char import Data.Char
import qualified System.FilePath.ByteString as P
import Control.Concurrent.Async import Control.Concurrent.Async
import Common import Common
@ -76,7 +75,7 @@ read' repo = go repo
params = addparams ++ explicitrepoparams params = addparams ++ explicitrepoparams
++ ["config", "--null", "--list"] ++ ["config", "--null", "--list"]
p = (proc "git" params) p = (proc "git" params)
{ cwd = Just (fromRawFilePath d) { cwd = Just (fromOsPath d)
, env = gitEnv repo , env = gitEnv repo
, std_out = CreatePipe , std_out = CreatePipe
} }
@ -184,7 +183,7 @@ updateLocation' r l@(Local {}) = do
Just (ConfigValue d) -> do Just (ConfigValue d) -> do
{- core.worktree is relative to the gitdir -} {- core.worktree is relative to the gitdir -}
top <- absPath (gitdir l) top <- absPath (gitdir l)
let p = absPathFrom top d let p = absPathFrom top (toOsPath d)
return $ l { worktree = Just p } return $ l { worktree = Just p }
Just NoConfigValue -> return l Just NoConfigValue -> return l
return $ r { location = l' } return $ r { location = l' }
@ -337,7 +336,7 @@ checkRepoConfigInaccessible r
-- Cannot use gitCommandLine here because specifying --git-dir -- Cannot use gitCommandLine here because specifying --git-dir
-- will bypass the git security check. -- will bypass the git security check.
let p = (proc "git" ["config", "--local", "--list"]) let p = (proc "git" ["config", "--local", "--list"])
{ cwd = Just (fromRawFilePath (repoPath r)) { cwd = Just (fromOsPath (repoPath r))
, env = gitEnv r , env = gitEnv r
} }
(out, ok) <- processTranscript' p Nothing (out, ok) <- processTranscript' p Nothing

39
Git/Construct.hs
View file

@ -41,14 +41,12 @@ import qualified Git.Url as Url
import Utility.UserInfo import Utility.UserInfo
import Utility.Url.Parse import Utility.Url.Parse
import qualified Utility.RawFilePath as R import qualified Utility.RawFilePath as R
import qualified Utility.OsString as OS
import qualified Data.ByteString as B
import qualified System.FilePath.ByteString as P
{- Finds the git repository used for the cwd, which may be in a parent {- Finds the git repository used for the cwd, which may be in a parent
- directory. -} - directory. -}
fromCwd :: IO (Maybe Repo) fromCwd :: IO (Maybe Repo)
fromCwd = R.getCurrentDirectory >>= seekUp fromCwd = R.getCurrentDirectory >>= seekUp . toOsPath
where where
seekUp dir = do seekUp dir = do
r <- checkForRepo dir r <- checkForRepo dir
@ -59,31 +57,32 @@ fromCwd = R.getCurrentDirectory >>= seekUp
Just loc -> pure $ Just $ newFrom loc Just loc -> pure $ Just $ newFrom loc
{- Local Repo constructor, accepts a relative or absolute path. -} {- Local Repo constructor, accepts a relative or absolute path. -}
fromPath :: RawFilePath -> IO Repo fromPath :: OsPath -> IO Repo
fromPath dir fromPath dir
-- When dir == "foo/.git", git looks for "foo/.git/.git", -- When dir == "foo/.git", git looks for "foo/.git/.git",
-- and failing that, uses "foo" as the repository. -- and failing that, uses "foo" as the repository.
| (P.pathSeparator `B.cons` ".git") `B.isSuffixOf` canondir = | (pathSeparator `OS.cons` dotgit) `OS.isSuffixOf` canondir =
ifM (doesDirectoryExist $ fromOsPath dir </> ".git") ifM (doesDirectoryExist $ dir </> dotgit)
( ret dir ( ret dir
, ret (P.takeDirectory canondir) , ret (takeDirectory canondir)
) )
| otherwise = ifM (doesDirectoryExist (fromOsPath dir)) | otherwise = ifM (doesDirectoryExist dir)
( checkGitDirFile dir >>= maybe (ret dir) (pure . newFrom) ( checkGitDirFile dir >>= maybe (ret dir) (pure . newFrom)
-- git falls back to dir.git when dir doesn't -- git falls back to dir.git when dir doesn't
-- exist, as long as dir didn't end with a -- exist, as long as dir didn't end with a
-- path separator -- path separator
, if dir == canondir , if dir == canondir
then ret (dir <> ".git") then ret (dir <> dotgit)
else ret dir else ret dir
) )
where where
dotgit = literalOsPath ".git"
ret = pure . newFrom . LocalUnknown ret = pure . newFrom . LocalUnknown
canondir = P.dropTrailingPathSeparator dir canondir = dropTrailingPathSeparator dir
{- Local Repo constructor, requires an absolute path to the repo be {- Local Repo constructor, requires an absolute path to the repo be
- specified. -} - specified. -}
fromAbsPath :: RawFilePath -> IO Repo fromAbsPath :: OsPath -> IO Repo
fromAbsPath dir fromAbsPath dir
| absoluteGitPath dir = fromPath dir | absoluteGitPath dir = fromPath dir
| otherwise = | otherwise =
@ -107,7 +106,7 @@ fromUrl url
fromUrl' :: String -> IO Repo fromUrl' :: String -> IO Repo
fromUrl' url fromUrl' url
| "file://" `isPrefixOf` url = case parseURIPortable url of | "file://" `isPrefixOf` url = case parseURIPortable url of
Just u -> fromAbsPath $ toRawFilePath $ unEscapeString $ uriPath u Just u -> fromAbsPath $ toOsPath $ unEscapeString $ uriPath u
Nothing -> pure $ newFrom $ UnparseableUrl url Nothing -> pure $ newFrom $ UnparseableUrl url
| otherwise = case parseURIPortable url of | otherwise = case parseURIPortable url of
Just u -> pure $ newFrom $ Url u Just u -> pure $ newFrom $ Url u
@ -129,7 +128,7 @@ localToUrl reference r
[ s [ s
, "//" , "//"
, auth , auth
, fromRawFilePath (repoPath r) , fromOsPath (repoPath r)
] ]
in r { location = Url $ fromJust $ parseURIPortable absurl } in r { location = Url $ fromJust $ parseURIPortable absurl }
_ -> r _ -> r
@ -176,7 +175,7 @@ fromRemoteLocation s knownurl repo = gen $ parseRemoteLocation s knownurl repo
fromRemotePath :: FilePath -> Repo -> IO Repo fromRemotePath :: FilePath -> Repo -> IO Repo
fromRemotePath dir repo = do fromRemotePath dir repo = do
dir' <- expandTilde dir dir' <- expandTilde dir
fromPath $ repoPath repo P.</> dir' fromPath $ repoPath repo </> dir'
{- Git remotes can have a directory that is specified relative {- Git remotes can have a directory that is specified relative
- to the user's home directory, or that contains tilde expansions. - to the user's home directory, or that contains tilde expansions.
@ -263,15 +262,13 @@ adjustGitDirFile loc = fromMaybe loc <$> adjustGitDirFile' loc
adjustGitDirFile' :: RepoLocation -> IO (Maybe RepoLocation) adjustGitDirFile' :: RepoLocation -> IO (Maybe RepoLocation)
adjustGitDirFile' loc@(Local {}) = do adjustGitDirFile' loc@(Local {}) = do
let gd = gitdir loc let gd = gitdir loc
c <- firstLine <$> catchDefaultIO "" (readFile (fromRawFilePath gd)) c <- firstLine <$> catchDefaultIO "" (readFile (fromOsPath gd))
if gitdirprefix `isPrefixOf` c if gitdirprefix `isPrefixOf` c
then do then do
top <- fromRawFilePath . P.takeDirectory <$> absPath gd top <- takeDirectory <$> absPath gd
return $ Just $ loc return $ Just $ loc
{ gitdir = absPathFrom { gitdir = absPathFrom top $
(toRawFilePath top) toOsPath $ drop (length gitdirprefix) c
(toRawFilePath
(drop (length gitdirprefix) c))
} }
else return Nothing else return Nothing
where where

14
Git/CurrentRepo.hs
View file

@ -16,10 +16,8 @@ import Git.Construct
import qualified Git.Config import qualified Git.Config
import Utility.Env import Utility.Env
import Utility.Env.Set import Utility.Env.Set
import qualified Utility.RawFilePath as R
import qualified Data.ByteString as B import qualified Data.ByteString as B
import qualified System.FilePath.ByteString as P
{- Gets the current git repository. {- Gets the current git repository.
- -
@ -42,14 +40,14 @@ import qualified System.FilePath.ByteString as P
get :: IO Repo get :: IO Repo
get = do get = do
gd <- getpathenv "GIT_DIR" gd <- getpathenv "GIT_DIR"
r <- configure gd =<< fromCwd r <- configure (fmap toOsPath gd) =<< fromCwd
prefix <- getpathenv "GIT_PREFIX" prefix <- getpathenv "GIT_PREFIX"
wt <- maybe (worktree (location r)) Just wt <- maybe (worktree (location r)) Just
<$> getpathenvprefix "GIT_WORK_TREE" prefix <$> getpathenvprefix "GIT_WORK_TREE" prefix
case wt of case wt of
Nothing -> relPath r Nothing -> relPath r
Just d -> do Just d -> do
curr <- R.getCurrentDirectory curr <- getCurrentDirectory
unless (d `dirContains` curr) $ unless (d `dirContains` curr) $
setCurrentDirectory d setCurrentDirectory d
relPath $ addworktree wt r relPath $ addworktree wt r
@ -66,15 +64,15 @@ get = do
getpathenv s >>= \case getpathenv s >>= \case
Nothing -> return Nothing Nothing -> return Nothing
Just d Just d
| d == "." -> return (Just d) | d == "." -> return (Just (toOsPath d))
| otherwise -> Just | otherwise -> Just
<$> absPath (prefix P.</> d) <$> absPath (toOsPath prefix </> toOsPath d)
getpathenvprefix s _ = getpathenv s getpathenvprefix s _ = fmap toOsPath <$> getpathenv s
configure Nothing (Just r) = Git.Config.read r configure Nothing (Just r) = Git.Config.read r
configure (Just d) _ = do configure (Just d) _ = do
absd <- absPath d absd <- absPath d
curr <- R.getCurrentDirectory curr <- getCurrentDirectory
loc <- adjustGitDirFile $ Local loc <- adjustGitDirFile $ Local
{ gitdir = absd { gitdir = absd
, worktree = Just curr , worktree = Just curr

6
Git/DiffTree.hs
View file

@ -18,7 +18,6 @@ module Git.DiffTree (
parseDiffRaw, parseDiffRaw,
) where ) where
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import qualified Data.Attoparsec.ByteString.Lazy as A import qualified Data.Attoparsec.ByteString.Lazy as A
import qualified Data.Attoparsec.ByteString.Char8 as A8 import qualified Data.Attoparsec.ByteString.Char8 as A8
@ -31,6 +30,7 @@ import Git.FilePath
import Git.DiffTreeItem import Git.DiffTreeItem
import qualified Git.Quote import qualified Git.Quote
import qualified Git.Ref import qualified Git.Ref
import qualified Utility.OsString as OS
import Utility.Attoparsec import Utility.Attoparsec
{- Checks if the DiffTreeItem modifies a file with a given name {- Checks if the DiffTreeItem modifies a file with a given name
@ -38,7 +38,7 @@ import Utility.Attoparsec
isDiffOf :: DiffTreeItem -> TopFilePath -> Bool isDiffOf :: DiffTreeItem -> TopFilePath -> Bool
isDiffOf diff f = isDiffOf diff f =
let f' = getTopFilePath f let f' = getTopFilePath f
in if B.null f' in if OS.null f'
then True -- top of repo contains all then True -- top of repo contains all
else f' `dirContains` getTopFilePath (file diff) else f' `dirContains` getTopFilePath (file diff)
@ -133,6 +133,6 @@ parserDiffRaw f = DiffTreeItem
<*> (maybe (fail "bad dstsha") return . extractSha =<< nextword) <*> (maybe (fail "bad dstsha") return . extractSha =<< nextword)
<* A8.char ' ' <* A8.char ' '
<*> A.takeByteString <*> A.takeByteString
<*> pure (asTopFilePath $ fromInternalGitPath $ Git.Quote.unquote f) <*> pure (asTopFilePath $ fromInternalGitPath $ toOsPath $ Git.Quote.unquote f)
where where
nextword = A8.takeTill (== ' ') nextword = A8.takeTill (== ' ')

20
Git/Hook.hs
View file

@ -21,10 +21,8 @@ import qualified Utility.RawFilePath as R
import System.PosixCompat.Files (fileMode) import System.PosixCompat.Files (fileMode)
#endif #endif
import qualified System.FilePath.ByteString as P
data Hook = Hook data Hook = Hook
{ hookName :: RawFilePath { hookName :: OsPath
, hookScript :: String , hookScript :: String
, hookOldScripts :: [String] , hookOldScripts :: [String]
} }
@ -33,8 +31,8 @@ data Hook = Hook
instance Eq Hook where instance Eq Hook where
a == b = hookName a == hookName b a == b = hookName a == hookName b
hookFile :: Hook -> Repo -> RawFilePath hookFile :: Hook -> Repo -> OsPath
hookFile h r = localGitDir r P.</> "hooks" P.</> hookName h hookFile h r = localGitDir r </> literalOsPath "hooks" </> hookName h
{- Writes a hook. Returns False if the hook already exists with a different {- Writes a hook. Returns False if the hook already exists with a different
- content. Upgrades old scripts. - content. Upgrades old scripts.
@ -65,8 +63,8 @@ hookWrite h r = ifM (doesFileExist f)
-- Hook scripts on Windows could use CRLF endings, but -- Hook scripts on Windows could use CRLF endings, but
-- they typically use unix newlines, which does work there -- they typically use unix newlines, which does work there
-- and makes the repository more portable. -- and makes the repository more portable.
viaTmp F.writeFile' (toOsPath f) (encodeBS (hookScript h)) viaTmp F.writeFile' f (encodeBS (hookScript h))
void $ tryIO $ modifyFileMode f (addModes executeModes) void $ tryIO $ modifyFileMode (fromOsPath f) (addModes executeModes)
return True return True
{- Removes a hook. Returns False if the hook contained something else, and {- Removes a hook. Returns False if the hook contained something else, and
@ -91,7 +89,7 @@ expectedContent h r = do
-- and so a hook file that has CRLF will be treated the same as one -- and so a hook file that has CRLF will be treated the same as one
-- that has LF. That is intentional, since users may have a reason -- that has LF. That is intentional, since users may have a reason
-- to prefer one or the other. -- to prefer one or the other.
content <- readFile $ fromRawFilePath $ hookFile h r content <- readFile $ fromOsPath $ hookFile h r
return $ if content == hookScript h return $ if content == hookScript h
then ExpectedContent then ExpectedContent
else if any (content ==) (hookOldScripts h) else if any (content ==) (hookOldScripts h)
@ -103,13 +101,13 @@ hookExists h r = do
let f = hookFile h r let f = hookFile h r
catchBoolIO $ catchBoolIO $
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
isExecutable . fileMode <$> R.getFileStatus f isExecutable . fileMode <$> R.getFileStatus (fromOsPath f)
#else #else
doesFileExist (fromRawFilePath f) doesFileExist f
#endif #endif
runHook :: (FilePath -> [CommandParam] -> IO a) -> Hook -> [CommandParam] -> Repo -> IO a runHook :: (FilePath -> [CommandParam] -> IO a) -> Hook -> [CommandParam] -> Repo -> IO a
runHook runner h ps r = do runHook runner h ps r = do
let f = fromRawFilePath $ hookFile h r let f = fromOsPath $ hookFile h r
(c, cps) <- findShellCommand f (c, cps) <- findShellCommand f
runner c (cps ++ ps) runner c (cps ++ ps)

20
Git/Index.hs
View file

@ -14,8 +14,6 @@ import Git
import Utility.Env import Utility.Env
import Utility.Env.Set import Utility.Env.Set
import qualified System.FilePath.ByteString as P
indexEnv :: String indexEnv :: String
indexEnv = "GIT_INDEX_FILE" indexEnv = "GIT_INDEX_FILE"
@ -30,8 +28,8 @@ indexEnv = "GIT_INDEX_FILE"
- -
- So, an absolute path is the only safe option for this to return. - So, an absolute path is the only safe option for this to return.
-} -}
indexEnvVal :: RawFilePath -> IO String indexEnvVal :: OsPath -> IO String
indexEnvVal p = fromRawFilePath <$> absPath p indexEnvVal p = fromOsPath <$> absPath p
{- Forces git to use the specified index file. {- Forces git to use the specified index file.
- -
@ -40,7 +38,7 @@ indexEnvVal p = fromRawFilePath <$> absPath p
- -
- Warning: Not thread safe. - Warning: Not thread safe.
-} -}
override :: RawFilePath -> Repo -> IO (IO ()) override :: OsPath -> Repo -> IO (IO ())
override index _r = do override index _r = do
res <- getEnv var res <- getEnv var
val <- indexEnvVal index val <- indexEnvVal index
@ -52,13 +50,13 @@ override index _r = do
reset _ = unsetEnv var reset _ = unsetEnv var
{- The normal index file. Does not check GIT_INDEX_FILE. -} {- The normal index file. Does not check GIT_INDEX_FILE. -}
indexFile :: Repo -> RawFilePath indexFile :: Repo -> OsPath
indexFile r = localGitDir r P.</> "index" indexFile r = localGitDir r </> literalOsPath "index"
{- The index file git will currently use, checking GIT_INDEX_FILE. -} {- The index file git will currently use, checking GIT_INDEX_FILE. -}
currentIndexFile :: Repo -> IO RawFilePath currentIndexFile :: Repo -> IO OsPath
currentIndexFile r = maybe (indexFile r) toRawFilePath <$> getEnv indexEnv currentIndexFile r = maybe (indexFile r) toOsPath <$> getEnv indexEnv
{- Git locks the index by creating this file. -} {- Git locks the index by creating this file. -}
indexFileLock :: RawFilePath -> RawFilePath indexFileLock :: OsPath -> OsPath
indexFileLock f = f <> ".lock" indexFileLock f = f <> literalOsPath ".lock"

7
Git/LsTree.hs
View file

@ -137,7 +137,8 @@ parserLsTree long = case long of
-- sha -- sha
<*> (Ref <$> A8.takeTill A8.isSpace) <*> (Ref <$> A8.takeTill A8.isSpace)
fileparser = asTopFilePath . Git.Quote.unquote <$> A.takeByteString fileparser = asTopFilePath . toOsPath . Git.Quote.unquote
<$> A.takeByteString
sizeparser = fmap Just A8.decimal sizeparser = fmap Just A8.decimal
@ -152,4 +153,6 @@ formatLsTree ti = S.intercalate (S.singleton (fromIntegral (ord ' ')))
[ encodeBS (showOct (mode ti) "") [ encodeBS (showOct (mode ti) "")
, typeobj ti , typeobj ti
, fromRef' (sha ti) , fromRef' (sha ti)
] <> (S.cons (fromIntegral (ord '\t')) (getTopFilePath (file ti))) ]
<> (S.cons (fromIntegral (ord '\t'))
(fromOsPath (getTopFilePath (file ti))))

27
Git/Objects.hs
View file

@ -15,25 +15,23 @@ import Git.Sha
import qualified Utility.OsString as OS 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 objectsDir :: Repo -> OsPath
objectsDir r = localGitDir r </> literalOsPath "objects"
objectsDir :: Repo -> RawFilePath packDir :: Repo -> OsPath
objectsDir r = localGitDir r P.</> "objects" packDir r = objectsDir r </> literalOsPath "pack"
packDir :: Repo -> RawFilePath packIdxFile :: OsPath -> OsPath
packDir r = objectsDir r P.</> "pack" packIdxFile = flip replaceExtension (literalOsPath "idx")
packIdxFile :: RawFilePath -> RawFilePath listPackFiles :: Repo -> IO [OsPath]
packIdxFile = flip P.replaceExtension "idx" listPackFiles r = filter (literalOsPath ".pack" `OS.isSuffixOf`)
listPackFiles :: Repo -> IO [RawFilePath]
listPackFiles r = filter (".pack" `B.isSuffixOf`)
<$> catchDefaultIO [] (dirContents $ packDir r) <$> catchDefaultIO [] (dirContents $ packDir r)
listLooseObjectShas :: Repo -> IO [Sha] listLooseObjectShas :: Repo -> IO [Sha]
listLooseObjectShas r = catchDefaultIO [] $ listLooseObjectShas r = catchDefaultIO [] $
mapMaybe conv <$> emptyWhenDoesNotExist mapMaybe conv <$> emptyWhenDoesNotExist
(dirContentsRecursiveSkipping (== "pack") True (objectsDir r)) (dirContentsRecursiveSkipping ispackdir True (objectsDir r))
where where
conv :: OsPath -> Maybe Sha conv :: OsPath -> Maybe Sha
conv = extractSha conv = extractSha
@ -43,17 +41,18 @@ listLooseObjectShas r = catchDefaultIO [] $
. take 2 . take 2
. reverse . reverse
. splitDirectories . splitDirectories
ispackdir f = f == literalOsPath "pack"
looseObjectFile :: Repo -> Sha -> OsPath looseObjectFile :: Repo -> Sha -> OsPath
looseObjectFile r sha = objectsDir r P.</> prefix P.</> rest looseObjectFile r sha = objectsDir r </> toOsPath prefix </> toOsPath rest
where where
(prefix, rest) = B.splitAt 2 (fromRef' sha) (prefix, rest) = B.splitAt 2 (fromRef' sha)
listAlternates :: Repo -> IO [FilePath] listAlternates :: Repo -> IO [FilePath]
listAlternates r = catchDefaultIO [] $ listAlternates r = catchDefaultIO [] $
lines <$> readFile (fromRawFilePath alternatesfile) lines <$> readFile (fromOsPath alternatesfile)
where where
alternatesfile = objectsDir r P.</> "info" P.</> "alternates" alternatesfile = objectsDir r </> literalOsPath "info" </> literalOsPath "alternates"
{- A repository recently cloned with --shared will have one or more {- A repository recently cloned with --shared will have one or more
- alternates listed, and contain no loose objects or packs. -} - alternates listed, and contain no loose objects or packs. -}

6
Git/Quote.hs
View file

@ -90,12 +90,12 @@ quotedPaths (p:ps) = QuotedPath p <> if null ps
instance Quoteable StringContainingQuotedPath where instance Quoteable StringContainingQuotedPath where
quote _ (UnquotedString s) = safeOutput (encodeBS s) quote _ (UnquotedString s) = safeOutput (encodeBS s)
quote _ (UnquotedByteString s) = safeOutput s quote _ (UnquotedByteString s) = safeOutput s
quote qp (QuotedPath p) = quote qp p quote qp (QuotedPath p) = quote qp (fromOsPath p :: RawFilePath)
quote qp (a :+: b) = quote qp a <> quote qp b quote qp (a :+: b) = quote qp a <> quote qp b
noquote (UnquotedString s) = encodeBS s noquote (UnquotedString s) = encodeBS s
noquote (UnquotedByteString s) = s noquote (UnquotedByteString s) = s
noquote (QuotedPath p) = p noquote (QuotedPath p) = fromOsPath p
noquote (a :+: b) = noquote a <> noquote b noquote (a :+: b) = noquote a <> noquote b
instance IsString StringContainingQuotedPath where instance IsString StringContainingQuotedPath where
@ -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 == fromOsPath (unquote (quoteAlways (toOsPath s))) s == fromRawFilePath (unquote (quoteAlways (toRawFilePath s)))
where where
s = fromTestableFilePath ts s = fromTestableFilePath ts

18
Git/Ref.hs
View file

@ -20,17 +20,16 @@ import qualified Utility.FileIO as F
import Data.Char (chr, ord) import Data.Char (chr, ord)
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 System.FilePath.ByteString as P
headRef :: Ref headRef :: Ref
headRef = Ref "HEAD" headRef = Ref "HEAD"
headFile :: Repo -> RawFilePath headFile :: Repo -> OsPath
headFile r = localGitDir r P.</> "HEAD" headFile r = localGitDir r </> literalOsPath "HEAD"
setHeadRef :: Ref -> Repo -> IO () setHeadRef :: Ref -> Repo -> IO ()
setHeadRef ref r = setHeadRef ref r =
F.writeFile' (toOsPath (headFile r)) ("ref: " <> fromRef' ref) F.writeFile' (headFile r) ("ref: " <> fromRef' ref)
{- Converts a fully qualified git ref into a user-visible string. -} {- Converts a fully qualified git ref into a user-visible string. -}
describe :: Ref -> String describe :: Ref -> String
@ -70,7 +69,7 @@ branchRef = underBase "refs/heads"
- -
- If the input file is located outside the repository, returns Nothing. - If the input file is located outside the repository, returns Nothing.
-} -}
fileRef :: RawFilePath -> Repo -> IO (Maybe Ref) fileRef :: OsPath -> Repo -> IO (Maybe Ref)
fileRef f repo = do fileRef f repo = do
-- The filename could be absolute, or contain eg "../repo/file", -- The filename could be absolute, or contain eg "../repo/file",
-- neither of which work in a ref, so convert it to a minimal -- neither of which work in a ref, so convert it to a minimal
@ -80,12 +79,13 @@ fileRef f repo = do
-- Prefixing the file with ./ makes this work even when in a -- Prefixing the file with ./ makes this work even when in a
-- subdirectory of a repo. Eg, ./foo in directory bar refers -- subdirectory of a repo. Eg, ./foo in directory bar refers
-- to bar/foo, not to foo in the top of the repository. -- to bar/foo, not to foo in the top of the repository.
then Just $ Ref $ ":./" <> toInternalGitPath f' then Just $ Ref $ ":./" <> fromOsPath (toInternalGitPath f')
else Nothing else Nothing
{- A Ref that can be used to refer to a file in a particular branch. -} {- A Ref that can be used to refer to a file in a particular branch. -}
branchFileRef :: Branch -> RawFilePath -> Ref branchFileRef :: Branch -> OsPath -> Ref
branchFileRef branch f = Ref $ fromRef' branch <> ":" <> toInternalGitPath f branchFileRef branch f = Ref $ fromOsPath $
toOsPath (fromRef' branch) <> literalOsPath ":" <> toInternalGitPath f
{- Converts a Ref to refer to the content of the Ref on a given date. -} {- Converts a Ref to refer to the content of the Ref on a given date. -}
dateRef :: Ref -> RefDate -> Ref dateRef :: Ref -> RefDate -> Ref
@ -96,7 +96,7 @@ dateRef r (RefDate d) = Ref $ fromRef' r <> "@" <> encodeBS d
- -
- If the file path is located outside the repository, returns Nothing. - If the file path is located outside the repository, returns Nothing.
-} -}
fileFromRef :: Ref -> RawFilePath -> Repo -> IO (Maybe Ref) fileFromRef :: Ref -> OsPath -> Repo -> IO (Maybe Ref)
fileFromRef r f repo = fileRef f repo >>= return . \case fileFromRef r f repo = fileRef f repo >>= return . \case
Just (Ref fr) -> Just (Ref (fromRef' r <> fr)) Just (Ref fr) -> Just (Ref (fromRef' r <> fr))
Nothing -> Nothing Nothing -> Nothing

62
Git/Repair.hs
View file

@ -80,8 +80,8 @@ explodePacks :: Repo -> IO Bool
explodePacks r = go =<< listPackFiles r explodePacks r = go =<< listPackFiles r
where where
go [] = return False go [] = return False
go packs = withTmpDir (toOsPath "packs") $ \tmpdir -> do go packs = withTmpDir (literalOsPath "packs") $ \tmpdir -> do
r' <- addGitEnv r "GIT_OBJECT_DIRECTORY" tmpdir r' <- addGitEnv r "GIT_OBJECT_DIRECTORY" (fromOsPath tmpdir)
putStrLn "Unpacking all pack files." putStrLn "Unpacking all pack files."
forM_ packs $ \packfile -> do forM_ packs $ \packfile -> do
-- Just in case permissions are messed up. -- Just in case permissions are messed up.
@ -90,14 +90,11 @@ explodePacks r = go =<< listPackFiles r
void $ tryIO $ void $ tryIO $
pipeWrite [Param "unpack-objects", Param "-r"] r' $ \h -> pipeWrite [Param "unpack-objects", Param "-r"] r' $ \h ->
L.hPut h =<< F.readFile (toOsPath packfile) L.hPut h =<< F.readFile (toOsPath packfile)
objs <- emptyWhenDoesNotExist (dirContentsRecursive (toRawFilePath tmpdir)) objs <- emptyWhenDoesNotExist (dirContentsRecursive tmpdir)
forM_ objs $ \objfile -> do forM_ objs $ \objfile -> do
f <- relPathDirToFile f <- relPathDirToFile tmpdir objfile
(toRawFilePath tmpdir)
objfile
let dest = objectsDir r P.</> f let dest = objectsDir r P.</> f
createDirectoryIfMissing True createDirectoryIfMissing True (parentDir dest)
(fromRawFilePath (parentDir dest))
moveFile objfile dest moveFile objfile dest
forM_ packs $ \packfile -> do forM_ packs $ \packfile -> do
removeWhenExistsWith R.removeLink packfile removeWhenExistsWith R.removeLink packfile
@ -114,12 +111,12 @@ explodePacks r = go =<< listPackFiles r
retrieveMissingObjects :: FsckResults -> Maybe FilePath -> Repo -> IO FsckResults retrieveMissingObjects :: FsckResults -> Maybe FilePath -> Repo -> IO FsckResults
retrieveMissingObjects missing referencerepo r retrieveMissingObjects missing referencerepo r
| not (foundBroken missing) = return missing | not (foundBroken missing) = return missing
| otherwise = withTmpDir (toOsPath "tmprepo") $ \tmpdir -> do | otherwise = withTmpDir (literalOsPath "tmprepo") $ \tmpdir -> do
unlessM (boolSystem "git" [Param "init", File tmpdir]) $ unlessM (boolSystem "git" [Param "init", File (fromOsPath tmpdir)]) $
giveup $ "failed to create temp repository in " ++ tmpdir giveup $ "failed to create temp repository in " ++ fromOsPath tmpdir
tmpr <- Config.read =<< Construct.fromPath (toRawFilePath tmpdir) tmpr <- Config.read =<< Construct.fromPath tmpdir
let repoconfig r' = toOsPath (localGitDir r' P.</> "config") let repoconfig r' = localGitDir r' </> "config"
whenM (doesFileExist (fromRawFilePath (fromOsPath (repoconfig r)))) $ whenM (doesFileExist (repoconfig r)) $
F.readFile (repoconfig r) >>= F.writeFile (repoconfig tmpr) F.readFile (repoconfig r) >>= F.writeFile (repoconfig tmpr)
rs <- Construct.fromRemotes r rs <- Construct.fromRemotes r
stillmissing <- pullremotes tmpr rs fetchrefstags missing stillmissing <- pullremotes tmpr rs fetchrefstags missing
@ -181,8 +178,8 @@ retrieveMissingObjects missing referencerepo r
copyObjects :: Repo -> Repo -> IO Bool copyObjects :: Repo -> Repo -> IO Bool
copyObjects srcr destr = rsync copyObjects srcr destr = rsync
[ Param "-qr" [ Param "-qr"
, File $ addTrailingPathSeparator $ fromRawFilePath $ objectsDir srcr , File $ fromOsPath $ addTrailingPathSeparator $ objectsDir srcr
, File $ addTrailingPathSeparator $ fromRawFilePath $ objectsDir destr , File $ fromOsPath $ addTrailingPathSeparator $ objectsDir destr
] ]
{- To deal with missing objects that cannot be recovered, resets any {- To deal with missing objects that cannot be recovered, resets any
@ -249,38 +246,35 @@ badBranches missing r = filterM isbad =<< getAllRefs r
- Relies on packed refs being exploded before it's called. - Relies on packed refs being exploded before it's called.
-} -}
getAllRefs :: Repo -> IO [Ref] getAllRefs :: Repo -> IO [Ref]
getAllRefs r = getAllRefs' (localGitDir r P.</> "refs") getAllRefs r = getAllRefs' (localGitDir r </> literalOsPath "refs")
getAllRefs' :: RawFilePath -> IO [Ref] getAllRefs' :: OsPath -> IO [Ref]
getAllRefs' refdir = do getAllRefs' refdir = do
let topsegs = length (P.splitPath refdir) - 1 let topsegs = length (splitPath refdir) - 1
let toref = Ref . toInternalGitPath . encodeBS let toref = Ref . toInternalGitPath
. joinPath . drop topsegs . splitPath . joinPath . drop topsegs . splitPath
. decodeBS
map toref <$> emptyWhenDoesNotExist (dirContentsRecursive refdir) map toref <$> emptyWhenDoesNotExist (dirContentsRecursive refdir)
explodePackedRefsFile :: Repo -> IO () explodePackedRefsFile :: Repo -> IO ()
explodePackedRefsFile r = do explodePackedRefsFile r = do
let f = packedRefsFile r let f = packedRefsFile r
let f' = toRawFilePath f
whenM (doesFileExist f) $ do whenM (doesFileExist f) $ do
rs <- mapMaybe parsePacked rs <- mapMaybe parsePacked
. map decodeBS . map decodeBS
. fileLines' . fileLines'
<$> catchDefaultIO "" (safeReadFile f') <$> catchDefaultIO "" (safeReadFile f)
forM_ rs makeref forM_ rs makeref
removeWhenExistsWith R.removeLink f' removeWhenExistsWith R.removeLink (fromOsPath f)
where where
makeref (sha, ref) = do makeref (sha, ref) = do
let gitd = localGitDir r let gitd = localGitDir r
let dest = gitd P.</> fromRef' ref let dest = gitd </> toOsPath (fromRef' ref)
let dest' = fromRawFilePath dest
createDirectoryUnder [gitd] (parentDir dest) createDirectoryUnder [gitd] (parentDir dest)
unlessM (doesFileExist dest') $ unlessM (doesFileExist dest) $
writeFile dest' (fromRef sha) writeFile (fromOsPath dest) (fromRef sha)
packedRefsFile :: Repo -> FilePath packedRefsFile :: Repo -> OsPath
packedRefsFile r = fromRawFilePath (localGitDir r) </> "packed-refs" packedRefsFile r = localGitDir r </> "packed-refs"
parsePacked :: String -> Maybe (Sha, Ref) parsePacked :: String -> Maybe (Sha, Ref)
parsePacked l = case words l of parsePacked l = case words l of
@ -411,7 +405,7 @@ checkIndexFast r = do
length indexcontents `seq` cleanup length indexcontents `seq` cleanup
missingIndex :: Repo -> IO Bool missingIndex :: Repo -> IO Bool
missingIndex r = not <$> doesFileExist (fromRawFilePath (localGitDir r) </> "index") missingIndex r = not <$> doesFileExist (localGitDir r </> "index")
{- Finds missing and ok files staged in the index. -} {- Finds missing and ok files staged in the index. -}
partitionIndex :: Repo -> IO ([LsFiles.StagedDetails], [LsFiles.StagedDetails], IO Bool) partitionIndex :: Repo -> IO ([LsFiles.StagedDetails], [LsFiles.StagedDetails], IO Bool)
@ -655,7 +649,7 @@ runRepair' removablebranch fsckresult forced referencerepo g = do
successfulRepair :: (Bool, [Branch]) -> Bool successfulRepair :: (Bool, [Branch]) -> Bool
successfulRepair = fst successfulRepair = fst
safeReadFile :: RawFilePath -> IO B.ByteString safeReadFile :: OsPath -> IO B.ByteString
safeReadFile f = do safeReadFile f = do
allowRead f allowRead (fromOsPath f)
F.readFile' (toOsPath f) F.readFile' f

12
Git/Status.hs
View file

@ -57,13 +57,13 @@ parseStatusZ = go []
in go (v : c) xs' in go (v : c) xs'
_ -> go c xs _ -> go c xs
cparse 'M' f _ = (Just (Modified (asTopFilePath (toRawFilePath f))), Nothing) cparse 'M' f _ = (Just (Modified (asTopFilePath (toOsPath f))), Nothing)
cparse 'A' f _ = (Just (Added (asTopFilePath (toRawFilePath f))), Nothing) cparse 'A' f _ = (Just (Added (asTopFilePath (toOsPath f))), Nothing)
cparse 'D' f _ = (Just (Deleted (asTopFilePath (toRawFilePath f))), Nothing) cparse 'D' f _ = (Just (Deleted (asTopFilePath (toOsPath f))), Nothing)
cparse 'T' f _ = (Just (TypeChanged (asTopFilePath (toRawFilePath f))), Nothing) cparse 'T' f _ = (Just (TypeChanged (asTopFilePath (toOsPath f))), Nothing)
cparse '?' f _ = (Just (Untracked (asTopFilePath (toRawFilePath f))), Nothing) cparse '?' f _ = (Just (Untracked (asTopFilePath (toOsPath f))), Nothing)
cparse 'R' f (oldf:xs) = cparse 'R' f (oldf:xs) =
(Just (Renamed (asTopFilePath (toRawFilePath oldf)) (asTopFilePath (toRawFilePath f))), Just xs) (Just (Renamed (asTopFilePath (toOsPath oldf)) (asTopFilePath (toOsPath f))), Just xs)
cparse _ _ _ = (Nothing, Nothing) cparse _ _ _ = (Nothing, Nothing)
getStatus :: [CommandParam] -> [FilePath] -> Repo -> IO ([StagedUnstaged Status], IO Bool) getStatus :: [CommandParam] -> [FilePath] -> Repo -> IO ([StagedUnstaged Status], IO Bool)

8
Git/Tree.hs
View file

@ -178,7 +178,7 @@ treeItemsToTree = go M.empty
Just (NewSubTree d l) -> Just (NewSubTree d l) ->
go (addsubtree idir m (NewSubTree d (c:l))) is go (addsubtree idir m (NewSubTree d (c:l))) is
_ -> _ ->
go (addsubtree idir m (NewSubTree (asTopFilePath idir) [c])) is go (addsubtree idir m (NewSubTree (asTopFilePath (toOsPath idir)) [c])) is
where where
p = gitPath i p = gitPath i
idir = P.takeDirectory p idir = P.takeDirectory p
@ -191,7 +191,7 @@ treeItemsToTree = go M.empty
Just (NewSubTree d' l) -> Just (NewSubTree d' l) ->
let l' = filter (\ti -> gitPath ti /= d) l let l' = filter (\ti -> gitPath ti /= d) l
in addsubtree parent m' (NewSubTree d' (t:l')) in addsubtree parent m' (NewSubTree d' (t:l'))
_ -> addsubtree parent m' (NewSubTree (asTopFilePath parent) [t]) _ -> addsubtree parent m' (NewSubTree (asTopFilePath (toOsPath parent)) [t])
| otherwise = M.insert d t m | otherwise = M.insert d t m
where where
parent = P.takeDirectory d parent = P.takeDirectory d
@ -362,7 +362,7 @@ graftTree' subtree graftloc basetree repo hdl = go basetree subdirs graftdirs
subdirs = P.splitDirectories $ gitPath graftloc subdirs = P.splitDirectories $ gitPath graftloc
graftdirs = map (asTopFilePath . toInternalGitPath) $ graftdirs = map (asTopFilePath . toInternalGitPath . toOsPath) $
pathPrefixes subdirs pathPrefixes subdirs
{- Assumes the list is ordered, with tree objects coming right before their {- Assumes the list is ordered, with tree objects coming right before their
@ -401,7 +401,7 @@ instance GitPath FilePath where
gitPath = toRawFilePath gitPath = toRawFilePath
instance GitPath TopFilePath where instance GitPath TopFilePath where
gitPath = getTopFilePath gitPath = fromOsPath . getTopFilePath
instance GitPath TreeItem where instance GitPath TreeItem where
gitPath (TreeItem f _ _) = gitPath f gitPath (TreeItem f _ _) = gitPath f

14
Git/UpdateIndex.hs
View file

@ -97,15 +97,15 @@ updateIndexLine sha treeitemtype file = L.fromStrict $
<> " blob " <> " blob "
<> fromRef' sha <> fromRef' sha
<> "\t" <> "\t"
<> indexPath file <> fromOsPath (indexPath file)
stageFile :: Sha -> TreeItemType -> RawFilePath -> Repo -> IO Streamer stageFile :: Sha -> TreeItemType -> OsPath -> Repo -> IO Streamer
stageFile sha treeitemtype file repo = do stageFile sha treeitemtype file repo = do
p <- toTopFilePath file repo p <- toTopFilePath file repo
return $ pureStreamer $ updateIndexLine sha treeitemtype p return $ pureStreamer $ updateIndexLine sha treeitemtype p
{- A streamer that removes a file from the index. -} {- A streamer that removes a file from the index. -}
unstageFile :: RawFilePath -> Repo -> IO Streamer unstageFile :: OsPath -> Repo -> IO Streamer
unstageFile file repo = do unstageFile file repo = do
p <- toTopFilePath file repo p <- toTopFilePath file repo
return $ unstageFile' p return $ unstageFile' p
@ -115,10 +115,10 @@ unstageFile' p = pureStreamer $ L.fromStrict $
"0 " "0 "
<> fromRef' deleteSha <> fromRef' deleteSha
<> "\t" <> "\t"
<> indexPath p <> fromOsPath (indexPath p)
{- A streamer that adds a symlink to the index. -} {- A streamer that adds a symlink to the index. -}
stageSymlink :: RawFilePath -> Sha -> Repo -> IO Streamer stageSymlink :: OsPath -> Sha -> Repo -> IO Streamer
stageSymlink file sha repo = do stageSymlink file sha repo = do
!line <- updateIndexLine !line <- updateIndexLine
<$> pure sha <$> pure sha
@ -141,7 +141,7 @@ indexPath = toInternalGitPath . getTopFilePath
- update-index. Sending Nothing will wait for update-index to finish - update-index. Sending Nothing will wait for update-index to finish
- updating the index. - updating the index.
-} -}
refreshIndex :: (MonadIO m, MonadMask m) => Repo -> ((Maybe RawFilePath -> IO ()) -> m ()) -> m () refreshIndex :: (MonadIO m, MonadMask m) => Repo -> ((Maybe OsPath -> IO ()) -> m ()) -> m ()
refreshIndex repo feeder = bracket refreshIndex repo feeder = bracket
(liftIO $ createProcess p) (liftIO $ createProcess p)
(liftIO . cleanupProcess) (liftIO . cleanupProcess)
@ -163,7 +163,7 @@ refreshIndex repo feeder = bracket
hClose h hClose h
forceSuccessProcess p pid forceSuccessProcess p pid
feeder $ \case feeder $ \case
Just f -> S.hPut h (S.snoc f 0) Just f -> S.hPut h (S.snoc (fromOsPath f) 0)
Nothing -> closer Nothing -> closer
liftIO $ closer liftIO $ closer
go _ = error "internal" go _ = error "internal"

1
Utility/Directory.hs
View file

@ -21,7 +21,6 @@ import Control.Monad
import System.PosixCompat.Files (isDirectory, isSymbolicLink) import System.PosixCompat.Files (isDirectory, isSymbolicLink)
import Control.Applicative import Control.Applicative
import System.IO.Unsafe (unsafeInterleaveIO) import System.IO.Unsafe (unsafeInterleaveIO)
import qualified System.FilePath.ByteString as P
import Data.Maybe import Data.Maybe
import Prelude import Prelude

3
Utility/Directory/Stream.hs
View file

@ -33,6 +33,7 @@ import qualified System.Posix.Directory.ByteString as Posix
import Utility.Directory import Utility.Directory
import Utility.Exception import Utility.Exception
import Utility.FileSystemEncoding import Utility.FileSystemEncoding
import Utility.OsPath
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
data DirectoryHandle = DirectoryHandle IsOpen Posix.DirStream data DirectoryHandle = DirectoryHandle IsOpen Posix.DirStream
@ -117,5 +118,5 @@ isDirectoryPopulated d = bracket (openDirectory d) closeDirectory check
case v of case v of
Nothing -> return False Nothing -> return False
Just f Just f
| not (dirCruft f) -> return True | not (toOsPath f `elem` dirCruft) -> return True
| otherwise -> check h | otherwise -> check h

6
Utility/FreeDesktop.hs
View file

@ -29,15 +29,9 @@ module Utility.FreeDesktop (
) where ) where
import Common import Common
import Utility.Exception
import Utility.UserInfo import Utility.UserInfo
import Utility.Process
import System.Environment import System.Environment
import Data.List
import Data.Maybe
import Control.Applicative
import Prelude
type DesktopEntry = [(Key, Value)] type DesktopEntry = [(Key, Value)]

35
Utility/OsPath.hs
View file

@ -19,19 +19,23 @@ module Utility.OsPath (
fromOsPath, fromOsPath,
module X, module X,
getSearchPath, getSearchPath,
unsafeFromChar
) where ) where
import Utility.FileSystemEncoding import Utility.FileSystemEncoding
import Data.ByteString.Short (ShortByteString)
import qualified Data.ByteString.Short as S
#ifdef WITH_OSPATH #ifdef WITH_OSPATH
import System.OsPath as X hiding (OsPath, OsString) import System.OsPath as X hiding (OsPath, OsString, unsafeFromChar)
import System.OsPath import System.OsPath
import "os-string" System.OsString.Internal.Types import "os-string" System.OsString.Internal.Types
import qualified Data.ByteString.Short as S
import qualified System.FilePath.ByteString as PB import qualified System.FilePath.ByteString as PB
#else #else
import System.FilePath.ByteString as X hiding (RawFilePath, getSearchPath) import System.FilePath.ByteString as X hiding (RawFilePath, getSearchPath)
import System.FilePath.ByteString (getSearchPath) import System.FilePath.ByteString (getSearchPath)
import qualified Data.ByteString as S import Data.ByteString (ByteString)
import Data.Char
import Data.Word
#endif #endif
class OsPathConv t where class OsPathConv t where
@ -48,24 +52,28 @@ literalOsPath = toOsPath
#ifdef WITH_OSPATH #ifdef WITH_OSPATH
instance OsPathConv RawFilePath where instance OsPathConv RawFilePath where
toOsPath = bytesToOsPath . S.toShort
fromOsPath = S.fromShort . bytesFromOsPath
instance OsPathConv ShortByteString where
toOsPath = bytesToOsPath toOsPath = bytesToOsPath
fromOsPath = bytesFromOsPath fromOsPath = bytesFromOsPath
{- Unlike System.OsString.fromBytes, on Windows this does not ensure a {- Unlike System.OsString.fromBytes, on Windows this does not ensure a
- valid USC-2LE encoding. The input ByteString must be in a valid encoding - valid USC-2LE encoding. The input ByteString must be in a valid encoding
- already or uses of the OsPath will fail. -} - already or uses of the OsPath will fail. -}
bytesToOsPath :: RawFilePath -> OsPath bytesToOsPath :: ShortByteString -> OsPath
#if defined(mingw32_HOST_OS) #if defined(mingw32_HOST_OS)
bytesToOsPath = OsString . WindowsString . S.toShort bytesToOsPath = OsString . WindowsString
#else #else
bytesToOsPath = OsString . PosixString . S.toShort bytesToOsPath = OsString . PosixString
#endif #endif
bytesFromOsPath :: OsPath -> RawFilePath bytesFromOsPath :: OsPath -> ShortByteString
#if defined(mingw32_HOST_OS) #if defined(mingw32_HOST_OS)
bytesFromOsPath = S.fromShort . getWindowsString . getOsString bytesFromOsPath = getWindowsString . getOsString
#else #else
bytesFromOsPath = S.fromShort . getPosixString . getOsString bytesFromOsPath = getPosixString . getOsString
#endif #endif
{- For some reason not included in System.OsPath -} {- For some reason not included in System.OsPath -}
@ -77,9 +85,16 @@ getSearchPath = map toOsPath <$> PB.getSearchPath
-} -}
type OsPath = RawFilePath type OsPath = RawFilePath
type OsString = S.ByteString type OsString = ByteString
instance OsPathConv RawFilePath where instance OsPathConv RawFilePath where
toOsPath = id toOsPath = id
fromOsPath = id fromOsPath = id
instance OsPathConv ShortByteString where
toOsPath = S.fromShort
fromOsPath = S.toShort
unsafeFromChar :: Char -> Word8
unsafeFromChar = fromIntegral . ord
#endif #endif

4
Utility/Path/Windows.hs
View file

@ -13,9 +13,9 @@ module Utility.Path.Windows (
) where ) where
import Utility.Path import Utility.Path
import Utility.OsPath
import Utility.FileSystemEncoding import Utility.FileSystemEncoding
import System.FilePath.ByteString (combine)
import qualified Data.ByteString as B import qualified Data.ByteString as B
import qualified System.FilePath.Windows.ByteString as P import qualified System.FilePath.Windows.ByteString as P
import System.Directory (getCurrentDirectory) import System.Directory (getCurrentDirectory)
@ -37,7 +37,7 @@ convertToWindowsNativeNamespace f
-- Make absolute because any '.' and '..' in the path -- Make absolute because any '.' and '..' in the path
-- will not be resolved once it's converted. -- will not be resolved once it's converted.
cwd <- toRawFilePath <$> getCurrentDirectory cwd <- toRawFilePath <$> getCurrentDirectory
let p = simplifyPath (combine cwd f) let p = fromOsPath (simplifyPath (toOsPath (combine cwd f)))
-- Normalize slashes. -- Normalize slashes.
let p' = P.normalise p let p' = P.normalise p
return (win32_file_namespace <> p') return (win32_file_namespace <> p')

2
Utility/StatelessOpenPGP.hs
View file

@ -163,7 +163,7 @@ feedRead cmd subcmd params password emptydirectory feeder reader = do
withTmpFile (toOsPath "sop") $ \tmpfile h -> do withTmpFile (toOsPath "sop") $ \tmpfile h -> do
liftIO $ B.hPutStr h password liftIO $ B.hPutStr h password
liftIO $ hClose h liftIO $ hClose h
let passwordfile = [Param $ "--with-password=" ++ fromRawFilePath (fromOsPath tmpfile)] let passwordfile = [Param $ "--with-password=" ++ fromOsPath tmpfile]
-- Don't need to pass emptydirectory since @FD is not used, -- Don't need to pass emptydirectory since @FD is not used,
-- and so tmpfile also does not need to be made absolute. -- and so tmpfile also does not need to be made absolute.
case emptydirectory of case emptydirectory of