diff --git a/Annex/Magic.hs b/Annex/Magic.hs index c408cd50d0..eec8b404af 100644 --- a/Annex/Magic.hs +++ b/Annex/Magic.hs @@ -34,8 +34,10 @@ initMagicMime = catchMaybeIO $ do m <- magicOpen [MagicMime] liftIO $ getEnv "GIT_ANNEX_DIR" >>= \case Nothing -> magicLoadDefault m - Just d -> magicLoad m - (d "magic" "magic.mgc") + Just d -> magicLoad m $ fromOsPath $ + toOsPath d + literalOsPath "magic" + literalOsPath "magic.mgc" return m #else initMagicMime = return Nothing diff --git a/Assistant/Install/AutoStart.hs b/Assistant/Install/AutoStart.hs index 59fb7b674d..366e202731 100644 --- a/Assistant/Install/AutoStart.hs +++ b/Assistant/Install/AutoStart.hs @@ -10,6 +10,7 @@ module Assistant.Install.AutoStart where +import Common import Utility.FreeDesktop #ifdef darwin_HOST_OS import Utility.OSX @@ -18,11 +19,11 @@ import Utility.SystemDirectory import Utility.FileSystemEncoding #endif -installAutoStart :: FilePath -> FilePath -> IO () +installAutoStart :: String -> OsPath -> IO () installAutoStart command file = do #ifdef darwin_HOST_OS - createDirectoryIfMissing True (fromRawFilePath (parentDir (toRawFilePath file))) - writeFile file $ genOSXAutoStartFile osxAutoStartLabel command + createDirectoryIfMissing True (parentDir file) + writeFile (fromOsPath file) $ genOSXAutoStartFile osxAutoStartLabel command ["assistant", "--autostart"] #else writeDesktopMenuFile (fdoAutostart command) file diff --git a/Assistant/Install/Menu.hs b/Assistant/Install/Menu.hs index 91fcd3baf5..c7b4b00a8d 100644 --- a/Assistant/Install/Menu.hs +++ b/Assistant/Install/Menu.hs @@ -10,26 +10,24 @@ module Assistant.Install.Menu where +import Common import Utility.FreeDesktop import Utility.FileSystemEncoding import Utility.Path import System.IO import Utility.SystemDirectory -#ifndef darwin_HOST_OS -import System.FilePath -#endif -installMenu :: FilePath -> FilePath -> FilePath -> FilePath -> IO () +installMenu :: String -> OsPath -> OsPath -> OsPath -> IO () #ifdef darwin_HOST_OS installMenu _command _menufile _iconsrcdir _icondir = return () #else installMenu command menufile iconsrcdir icondir = do writeDesktopMenuFile (fdoDesktopMenu command) menufile - installIcon (iconsrcdir "logo.svg") $ - iconFilePath (iconBaseName ++ ".svg") "scalable" icondir - installIcon (iconsrcdir "logo_16x16.png") $ - iconFilePath (iconBaseName ++ ".png") "16x16" icondir + installIcon (iconsrcdir literalOsPath "logo.svg") $ + iconFilePath (toOsPath (iconBaseName ++ ".svg")) "scalable" icondir + installIcon (iconsrcdir literalOsPath "logo_16x16.png") $ + iconFilePath (toOsPath (iconBaseName ++ ".png")) "16x16" icondir #endif {- The command can be either just "git-annex", or the full path to use @@ -43,11 +41,11 @@ fdoDesktopMenu command = genDesktopEntry (Just iconBaseName) ["Network", "FileTransfer"] -installIcon :: FilePath -> FilePath -> IO () +installIcon :: OsPath -> OsPath -> IO () installIcon src dest = do - createDirectoryIfMissing True (fromRawFilePath (parentDir (toRawFilePath dest))) - withBinaryFile src ReadMode $ \hin -> - withBinaryFile dest WriteMode $ \hout -> + createDirectoryIfMissing True (parentDir dest) + withBinaryFile (fromOsPath src) ReadMode $ \hin -> + withBinaryFile (fromOsPath dest) WriteMode $ \hout -> hGetContents hin >>= hPutStr hout iconBaseName :: String diff --git a/Build/DesktopFile.hs b/Build/DesktopFile.hs index 00af543551..3dd887d048 100644 --- a/Build/DesktopFile.hs +++ b/Build/DesktopFile.hs @@ -11,12 +11,8 @@ module Build.DesktopFile where -import Utility.Exception +import Common import Utility.FreeDesktop -import Utility.Path -import Utility.Monad -import Utility.SystemDirectory -import Utility.FileSystemEncoding import Config.Files import Utility.OSX import Assistant.Install.AutoStart @@ -25,8 +21,6 @@ import Assistant.Install.Menu import System.Environment #ifndef mingw32_HOST_OS import System.Posix.User -import Data.Maybe -import Control.Applicative import Prelude #endif @@ -42,10 +36,10 @@ systemwideInstall = isroot <||> (not <$> userdirset) systemwideInstall = return False #endif -inDestDir :: FilePath -> IO FilePath +inDestDir :: OsPath -> IO OsPath inDestDir f = do destdir <- catchDefaultIO "" (getEnv "DESTDIR") - return $ destdir ++ "/" ++ f + return $ toOsPath destdir <> literalOsPath "/" <> f writeFDODesktop :: FilePath -> IO () writeFDODesktop command = do @@ -54,7 +48,7 @@ writeFDODesktop command = do datadir <- if systemwide then return systemDataDir else userDataDir menufile <- inDestDir (desktopMenuFilePath "git-annex" datadir) icondir <- inDestDir (iconDir datadir) - installMenu command menufile "doc" icondir + installMenu command menufile (literalOsPath "doc") icondir configdir <- if systemwide then return systemConfigDir else userConfigDir installAutoStart command @@ -78,8 +72,8 @@ install command = do ( return () , do programfile <- inDestDir =<< programFile - createDirectoryIfMissing True (fromRawFilePath (parentDir (toRawFilePath programfile))) - writeFile programfile command + createDirectoryIfMissing True (parentDir programfile) + writeFile (fromOsPath programfile) command ) installUser :: FilePath -> IO () diff --git a/Config/Files.hs b/Config/Files.hs index 83e4eda085..801c626845 100644 --- a/Config/Files.hs +++ b/Config/Files.hs @@ -9,28 +9,27 @@ module Config.Files where +import Common import Utility.FreeDesktop import Utility.Exception -import System.FilePath - {- ~/.config/git-annex/file -} -userConfigFile :: FilePath -> IO FilePath +userConfigFile :: OsPath -> IO OsPath userConfigFile file = do - dir <- userConfigDir - return $ dir "git-annex" file + dir <- toOsPath <$> userConfigDir + return $ dir literalOsPath "git-annex" file -autoStartFile :: IO FilePath -autoStartFile = userConfigFile "autostart" +autoStartFile :: IO OsPath +autoStartFile = userConfigFile (literalOsPath "autostart") {- The path to git-annex is written here; which is useful when something - has installed it to some awful non-PATH location. -} -programFile :: IO FilePath -programFile = userConfigFile "program" +programFile :: IO OsPath +programFile = userConfigFile (literalOsPath "program") {- A .noannex file in a git repository prevents git-annex from - initializing that repository. The content of the file is returned. -} -noAnnexFileContent :: Maybe FilePath -> IO (Maybe String) +noAnnexFileContent :: Maybe OsPath -> IO (Maybe String) noAnnexFileContent repoworktree = case repoworktree of Nothing -> return Nothing - Just wt -> catchMaybeIO (readFile (wt ".noannex")) + Just wt -> catchMaybeIO (readFile (fromOsPath (wt literalOsPath ".noannex"))) diff --git a/Config/Files/AutoStart.hs b/Config/Files/AutoStart.hs index 8b20644901..1b49c81e20 100644 --- a/Config/Files/AutoStart.hs +++ b/Config/Files/AutoStart.hs @@ -14,38 +14,37 @@ import Config.Files import Utility.Tmp {- Returns anything listed in the autostart file (which may not exist). -} -readAutoStartFile :: IO [FilePath] +readAutoStartFile :: IO [OsPath] readAutoStartFile = do f <- autoStartFile - filter valid . nub . map dropTrailingPathSeparator . lines - <$> catchDefaultIO "" (readFile f) + filter valid . nub . map (dropTrailingPathSeparator . toOsPath) . lines + <$> catchDefaultIO "" (readFile (fromOsPath f)) where -- Ignore any relative paths; some old buggy versions added eg "." valid = isAbsolute -modifyAutoStartFile :: ([FilePath] -> [FilePath]) -> IO () +modifyAutoStartFile :: ([OsPath] -> [OsPath]) -> IO () modifyAutoStartFile func = do dirs <- readAutoStartFile let dirs' = nubBy equalFilePath $ func dirs when (dirs' /= dirs) $ do f <- autoStartFile - createDirectoryIfMissing True $ - fromRawFilePath (parentDir (toRawFilePath f)) + createDirectoryIfMissing True (parentDir f) viaTmp (writeFile . fromRawFilePath . fromOsPath) - (toOsPath (toRawFilePath f)) - (unlines dirs') + (toOsPath f) + (unlines (map fromOsPath dirs')) {- Adds a directory to the autostart file. If the directory is already - present, it's moved to the top, so it will be used as the default - when opening the webapp. -} -addAutoStartFile :: FilePath -> IO () +addAutoStartFile :: OsPath -> IO () addAutoStartFile path = do - path' <- fromRawFilePath <$> absPath (toRawFilePath path) + path' <- absPath path modifyAutoStartFile $ (:) path' {- Removes a directory from the autostart file. -} -removeAutoStartFile :: FilePath -> IO () +removeAutoStartFile :: OsPath -> IO () removeAutoStartFile path = do - path' <- fromRawFilePath <$> absPath (toRawFilePath path) + path' <- absPath path modifyAutoStartFile $ filter (not . equalFilePath path') diff --git a/Git.hs b/Git.hs index d8a9de2256..9626cf58e5 100644 --- a/Git.hs +++ b/Git.hs @@ -86,7 +86,7 @@ repoWorkTree Repo { location = Local { worktree = Just d } } = Just d repoWorkTree _ = Nothing {- Path to a local repository's .git directory. -} -localGitDir :: Repo -> RawFilePath +localGitDir :: Repo -> OsPath localGitDir Repo { location = Local { gitdir = d } } = d localGitDir _ = giveup "unknown localGitDir" @@ -147,16 +147,17 @@ attributesLocal repo = localGitDir repo P. "info" P. "attributes" {- Path to a given hook script in a repository, only if the hook exists - and is executable. -} -hookPath :: String -> Repo -> IO (Maybe FilePath) +hookPath :: String -> Repo -> IO (Maybe OsPath) hookPath script repo = do - let hook = fromRawFilePath (localGitDir repo) "hooks" script + let hook = localGitDir repo literalOsPath "hooks" toOsPath script ifM (catchBoolIO $ isexecutable hook) ( return $ Just hook , return Nothing ) where #if mingw32_HOST_OS isexecutable f = doesFileExist f #else - isexecutable f = isExecutable . fileMode <$> getSymbolicLinkStatus f + isexecutable f = isExecutable . fileMode + <$> getSymbolicLinkStatus (fromOsPath f) #endif {- Makes the path to a local Repo be relative to the cwd. -} diff --git a/Git/Config.hs b/Git/Config.hs index b6fd77b249..c99a84ee21 100644 --- a/Git/Config.hs +++ b/Git/Config.hs @@ -99,7 +99,7 @@ read' repo = go repo global :: IO (Maybe Repo) global = do home <- myHomeDir - ifM (doesFileExist $ home ".gitconfig") + ifM (doesFileExist $ toOsPath home literalOsPath ".gitconfig") ( Just <$> withCreateProcess p go , return Nothing ) @@ -153,22 +153,22 @@ store' k v repo = repo -} updateLocation :: Repo -> IO Repo updateLocation r@(Repo { location = LocalUnknown d }) = case isBare r of - Just True -> ifM (doesDirectoryExist (fromRawFilePath dotgit)) + Just True -> ifM (doesDirectoryExist dotgit) ( updateLocation' r $ Local dotgit Nothing , updateLocation' r $ Local d Nothing ) Just False -> mknonbare {- core.bare not in config, probably because safe.directory - did not allow reading the config -} - Nothing -> ifM (Git.Construct.isBareRepo (fromRawFilePath d)) + Nothing -> ifM (Git.Construct.isBareRepo d) ( mkbare , mknonbare ) where - dotgit = d P. ".git" + dotgit = d literalOsPath ".git" -- git treats eg ~/foo as a bare git repository located in -- ~/foo/.git if ~/foo/.git/config has core.bare=true - mkbare = ifM (doesDirectoryExist (fromRawFilePath dotgit)) + mkbare = ifM (doesDirectoryExist dotgit) ( updateLocation' r $ Local dotgit Nothing , updateLocation' r $ Local d Nothing ) diff --git a/Git/Construct.hs b/Git/Construct.hs index ac3c536cc9..90aed92bde 100644 --- a/Git/Construct.hs +++ b/Git/Construct.hs @@ -176,43 +176,43 @@ fromRemoteLocation s knownurl repo = gen $ parseRemoteLocation s knownurl repo fromRemotePath :: FilePath -> Repo -> IO Repo fromRemotePath dir repo = do dir' <- expandTilde dir - fromPath $ repoPath repo P. toRawFilePath dir' + fromPath $ repoPath repo P. dir' {- Git remotes can have a directory that is specified relative - to the user's home directory, or that contains tilde expansions. - This converts such a directory to an absolute path. - Note that it has to run on the system where the remote is. -} -repoAbsPath :: RawFilePath -> IO RawFilePath +repoAbsPath :: OsPath -> IO OsPath repoAbsPath d = do - d' <- expandTilde (fromRawFilePath d) + d' <- expandTilde (fromOsPath d) h <- myHomeDir - return $ toRawFilePath $ h d' + return $ toOsPath h d' -expandTilde :: FilePath -> IO FilePath +expandTilde :: FilePath -> IO OsPath #ifdef mingw32_HOST_OS -expandTilde = return +expandTilde = return . toOsPath #else expandTilde p = expandt True p -- If unable to expand a tilde, eg due to a user not existing, -- use the path as given. - `catchNonAsync` (const (return p)) + `catchNonAsync` (const (return (toOsPath p))) where - expandt _ [] = return "" + expandt _ [] = return $ literalOsPath "" expandt _ ('/':cs) = do v <- expandt True cs - return ('/':v) + return $ literalOsPath "/" <> v expandt True ('~':'/':cs) = do h <- myHomeDir - return $ h cs - expandt True "~" = myHomeDir + return $ toOsPath h toOsPath cs + expandt True "~" = toOsPath <$> myHomeDir expandt True ('~':cs) = do let (name, rest) = findname "" cs u <- getUserEntryForName name - return $ homeDirectory u rest + return $ toOsPath (homeDirectory u) toOsPath rest expandt _ (c:cs) = do v <- expandt False cs - return (c:v) + return $ toOsPath [c] <> v findname n [] = (n, "") findname n (c:cs) | c == '/' = (n, cs) @@ -221,11 +221,11 @@ expandTilde p = expandt True p {- Checks if a git repository exists in a directory. Does not find - git repositories in parent directories. -} -checkForRepo :: RawFilePath -> IO (Maybe RepoLocation) +checkForRepo :: OsPath -> IO (Maybe RepoLocation) checkForRepo dir = check isRepo $ check (checkGitDirFile dir) $ - check (checkdir (isBareRepo dir')) $ + check (checkdir (isBareRepo dir)) $ return Nothing where check test cont = maybe cont (return . Just) =<< test @@ -234,23 +234,22 @@ checkForRepo dir = , return Nothing ) isRepo = checkdir $ - doesFileExist (dir' ".git" "config") + doesFileExist (dir literalOsPath ".git" literalOsPath "config") <||> -- A git-worktree lacks .git/config, but has .git/gitdir. -- (Normally the .git is a file, not a symlink, but it can -- be converted to a symlink and git will still work; -- this handles that case.) - doesFileExist (dir' ".git" "gitdir") - dir' = fromRawFilePath dir + doesFileExist (dir literalOsPath ".git" literalOsPath "gitdir") -isBareRepo :: FilePath -> IO Bool -isBareRepo dir = doesFileExist (dir "config") - <&&> doesDirectoryExist (dir "objects") +isBareRepo :: OsPath -> IO Bool +isBareRepo dir = doesFileExist (dir literalOsPath "config") + <&&> doesDirectoryExist (dir literalOsPath "objects") -- Check for a .git file. -checkGitDirFile :: RawFilePath -> IO (Maybe RepoLocation) +checkGitDirFile :: OsPath -> IO (Maybe RepoLocation) checkGitDirFile dir = adjustGitDirFile' $ Local - { gitdir = dir P. ".git" + { gitdir = dir literalOsPath ".git" , worktree = Just dir } diff --git a/Git/CurrentRepo.hs b/Git/CurrentRepo.hs index 747caaac9e..40adad0d53 100644 --- a/Git/CurrentRepo.hs +++ b/Git/CurrentRepo.hs @@ -51,7 +51,7 @@ get = do Just d -> do curr <- R.getCurrentDirectory unless (d `dirContains` curr) $ - setCurrentDirectory (fromRawFilePath d) + setCurrentDirectory d relPath $ addworktree wt r where getpathenv s = do diff --git a/Git/FilePath.hs b/Git/FilePath.hs index b27c0c7059..d562262ae1 100644 --- a/Git/FilePath.hs +++ b/Git/FilePath.hs @@ -32,13 +32,11 @@ import Common import Git import Git.Quote -import qualified System.FilePath.ByteString as P -import qualified System.FilePath.Posix.ByteString import GHC.Generics import Control.DeepSeq -{- A RawFilePath, relative to the top of the git repository. -} -newtype TopFilePath = TopFilePath { getTopFilePath :: RawFilePath } +{- A path relative to the top of the git repository. -} +newtype TopFilePath = TopFilePath { getTopFilePath :: OsPath } deriving (Show, Eq, Ord, Generic) instance NFData TopFilePath @@ -53,16 +51,16 @@ descBranchFilePath (BranchFilePath b f) = UnquotedByteString (fromRef' b) <> ":" <> QuotedPath (getTopFilePath f) {- Path to a TopFilePath, within the provided git repo. -} -fromTopFilePath :: TopFilePath -> Git.Repo -> RawFilePath -fromTopFilePath p repo = P.combine (repoPath repo) (getTopFilePath p) +fromTopFilePath :: TopFilePath -> Git.Repo -> OsPath +fromTopFilePath p repo = combine (repoPath repo) (getTopFilePath p) {- The input FilePath can be absolute, or relative to the CWD. -} -toTopFilePath :: RawFilePath -> Git.Repo -> IO TopFilePath +toTopFilePath :: OsPath -> Git.Repo -> IO TopFilePath toTopFilePath file repo = TopFilePath <$> relPathDirToFile (repoPath repo) file {- The input RawFilePath must already be relative to the top of the git - repository -} -asTopFilePath :: RawFilePath -> TopFilePath +asTopFilePath :: OsPath -> TopFilePath asTopFilePath file = TopFilePath file {- Git may use a different representation of a path when storing @@ -72,25 +70,24 @@ asTopFilePath file = TopFilePath file - despite Windows using '\'. - -} -type InternalGitPath = RawFilePath +type InternalGitPath = OsPath -toInternalGitPath :: RawFilePath -> InternalGitPath +toInternalGitPath :: OsPath -> InternalGitPath #ifndef mingw32_HOST_OS toInternalGitPath = id #else -toInternalGitPath = encodeBS . replace "\\" "/" . decodeBS +toInternalGitPath = toOsPath . encodeBS . replace "\\" "/" . decodeBS . fromOsPath #endif -fromInternalGitPath :: InternalGitPath -> RawFilePath +fromInternalGitPath :: InternalGitPath -> OsPath #ifndef mingw32_HOST_OS fromInternalGitPath = id #else -fromInternalGitPath = encodeBS . replace "/" "\\" . decodeBS +fromInternalGitPath = toOsPath . encodeBS . replace "/" "\\" . decodeBS . fromOsPath #endif {- isAbsolute on Windows does not think "/foo" or "\foo" is absolute, - so try posix paths. -} absoluteGitPath :: RawFilePath -> Bool -absoluteGitPath p = P.isAbsolute p || - System.FilePath.Posix.ByteString.isAbsolute (toInternalGitPath p) +absoluteGitPath p = isAbsolute p || isAbsolute (toInternalGitPath p) diff --git a/Git/HashObject.hs b/Git/HashObject.hs index 35031f20ae..0d3d9eaa28 100644 --- a/Git/HashObject.hs +++ b/Git/HashObject.hs @@ -83,7 +83,7 @@ instance HashableBlob Builder where {- Injects a blob into git. Unfortunately, the current git-hash-object - interface does not allow batch hashing without using temp files. -} hashBlob :: HashableBlob b => HashObjectHandle -> b -> IO Sha -hashBlob h b = withTmpFile (toOsPath "hash") $ \tmp tmph -> do +hashBlob h b = withTmpFile (literalOsPath "hash") $ \tmp tmph -> do hashableBlobToHandle tmph b hClose tmph hashFile h (fromOsPath tmp) diff --git a/Git/Hook.hs b/Git/Hook.hs index c2e5a8125e..bf400cc26f 100644 --- a/Git/Hook.hs +++ b/Git/Hook.hs @@ -50,7 +50,7 @@ hookFile h r = localGitDir r P. "hooks" P. hookName h - is run with a bundled bash, so should start with #!/bin/sh -} hookWrite :: Hook -> Repo -> IO Bool -hookWrite h r = ifM (doesFileExist (fromRawFilePath f)) +hookWrite h r = ifM (doesFileExist f) ( expectedContent h r >>= \case UnexpectedContent -> return False ExpectedContent -> return True @@ -81,7 +81,7 @@ hookUnWrite h r = ifM (doesFileExist f) , return True ) where - f = fromRawFilePath $ hookFile h r + f = hookFile h r data ExpectedContent = UnexpectedContent | ExpectedContent | OldExpectedContent diff --git a/Git/Ref.hs b/Git/Ref.hs index c6b2027280..8c2a846d3d 100644 --- a/Git/Ref.hs +++ b/Git/Ref.hs @@ -113,8 +113,8 @@ exists ref = runBool {- The file used to record a ref. (Git also stores some refs in a - packed-refs file.) -} -file :: Ref -> Repo -> FilePath -file ref repo = fromRawFilePath (localGitDir repo) fromRef ref +file :: Ref -> Repo -> OsPath +file ref repo = localGitDir repo toOsPath (fromRef' ref) {- Checks if HEAD exists. It generally will, except for in a repository - that was just created. -} diff --git a/Git/Tree.hs b/Git/Tree.hs index af2a132aa4..4c7c129a44 100644 --- a/Git/Tree.hs +++ b/Git/Tree.hs @@ -137,7 +137,7 @@ mkTreeOutput fm ot s f = concat , " " , fromRef s , "\t" - , takeFileName (fromRawFilePath (getTopFilePath f)) + , fromOsPath (takeFileName (getTopFilePath f)) , "\NUL" ] diff --git a/Git/Types.hs b/Git/Types.hs index b28380bc46..0a0ff44d68 100644 --- a/Git/Types.hs +++ b/Git/Types.hs @@ -9,6 +9,10 @@ module Git.Types where +import Utility.SafeCommand +import Utility.FileSystemEncoding +import Utility.OsPath + import Network.URI import Data.String import Data.Default @@ -16,8 +20,6 @@ import qualified Data.Map as M import qualified Data.ByteString as S import qualified Data.List.NonEmpty as NE import System.Posix.Types -import Utility.SafeCommand -import Utility.FileSystemEncoding import qualified Data.Semigroup as Sem import Prelude @@ -32,8 +34,8 @@ import Prelude - else known about it. -} data RepoLocation - = Local { gitdir :: RawFilePath, worktree :: Maybe RawFilePath } - | LocalUnknown RawFilePath + = Local { gitdir :: OsPath, worktree :: Maybe OsPath } + | LocalUnknown OsPath | Url URI | UnparseableUrl String | Unknown diff --git a/Utility/FreeDesktop.hs b/Utility/FreeDesktop.hs index 896b89b991..fb7d712c53 100644 --- a/Utility/FreeDesktop.hs +++ b/Utility/FreeDesktop.hs @@ -28,13 +28,12 @@ module Utility.FreeDesktop ( userDesktopDir ) where +import Common import Utility.Exception import Utility.UserInfo import Utility.Process import System.Environment -import System.FilePath -import System.Directory import Data.List import Data.Maybe import Control.Applicative @@ -78,53 +77,53 @@ buildDesktopMenuFile d = unlines ("[Desktop Entry]" : map keyvalue d) ++ "\n" where keyvalue (k, v) = k ++ "=" ++ toString v -writeDesktopMenuFile :: DesktopEntry -> String -> IO () +writeDesktopMenuFile :: DesktopEntry -> OsPath -> IO () writeDesktopMenuFile d file = do createDirectoryIfMissing True (takeDirectory file) - writeFile file $ buildDesktopMenuFile d + writeFile (fromOsPath file) $ buildDesktopMenuFile d {- Path to use for a desktop menu file, in either the systemDataDir or - the userDataDir -} -desktopMenuFilePath :: String -> FilePath -> FilePath +desktopMenuFilePath :: String -> OsPath -> OsPath desktopMenuFilePath basename datadir = - datadir "applications" desktopfile basename + datadir literalOsPath "applications" desktopfile basename {- Path to use for a desktop autostart file, in either the systemDataDir - or the userDataDir -} -autoStartPath :: String -> FilePath -> FilePath +autoStartPath :: String -> OsPath -> OsPath autoStartPath basename configdir = - configdir "autostart" desktopfile basename + configdir literalOsPath "autostart" desktopfile basename {- Base directory to install an icon file, in either the systemDataDir - or the userDatadir. -} -iconDir :: FilePath -> FilePath -iconDir datadir = datadir "icons" "hicolor" +iconDir :: OsPath -> OsPath +iconDir datadir = datadir literalOsPath "icons" literalOsPath "hicolor" {- Filename of an icon, given the iconDir to use. - - The resolution is something like "48x48" or "scalable". -} -iconFilePath :: FilePath -> String -> FilePath -> FilePath +iconFilePath :: OsPath -> String -> OsPath -> OsPath iconFilePath file resolution icondir = - icondir resolution "apps" file + icondir toOsPath resolution literalOsPath "apps" file -desktopfile :: FilePath -> FilePath -desktopfile f = f ++ ".desktop" +desktopfile :: FilePath -> OsPath +desktopfile f = toOsPath $ f ++ ".desktop" {- Directory used for installation of system wide data files.. -} -systemDataDir :: FilePath -systemDataDir = "/usr/share" +systemDataDir :: OsPath +systemDataDir = literalOsPath "/usr/share" {- Directory used for installation of system wide config files. -} -systemConfigDir :: FilePath -systemConfigDir = "/etc/xdg" +systemConfigDir :: OsPath +systemConfigDir = literalOsPath "/etc/xdg" {- Directory for user data files. -} -userDataDir :: IO FilePath -userDataDir = xdgEnvHome "DATA_HOME" ".local/share" +userDataDir :: IO OsPath +userDataDir = toOsPath <$> xdgEnvHome "DATA_HOME" ".local/share" {- Directory for user config files. -} -userConfigDir :: IO FilePath -userConfigDir = xdgEnvHome "CONFIG_HOME" ".config" +userConfigDir :: IO OsPath +userConfigDir = toOsPath <$> xdgEnvHome "CONFIG_HOME" ".config" {- Directory for the user's Desktop, may be localized. - @@ -142,6 +141,6 @@ userDesktopDir = maybe fallback return =<< (parse <$> xdg_user_dir) xdgEnvHome :: String -> String -> IO String xdgEnvHome envbase homedef = do - home <- myHomeDir - catchDefaultIO (home homedef) $ - getEnv $ "XDG_" ++ envbase + home <- toOsPath <$> myHomeDir + catchDefaultIO (fromOsPath $ home toOsPath homedef) $ + getEnv ("XDG_" ++ envbase) diff --git a/Utility/OSX.hs b/Utility/OSX.hs index f5820a78d6..1f14d30923 100644 --- a/Utility/OSX.hs +++ b/Utility/OSX.hs @@ -14,20 +14,19 @@ module Utility.OSX ( genOSXAutoStartFile, ) where +import Common import Utility.UserInfo -import System.FilePath +autoStartBase :: String -> OsPath +autoStartBase label = literalOsPath "Library" literalOsPath "LaunchAgents" literalOsPath (label ++ ".plist") -autoStartBase :: String -> FilePath -autoStartBase label = "Library" "LaunchAgents" label ++ ".plist" +systemAutoStart :: String -> OsPath +systemAutoStart label = literalOsPath "/" autoStartBase label -systemAutoStart :: String -> FilePath -systemAutoStart label = "/" autoStartBase label - -userAutoStart :: String -> IO FilePath +userAutoStart :: String -> IO OsPath userAutoStart label = do home <- myHomeDir - return $ home autoStartBase label + return $ toOsPath home autoStartBase label {- Generates an OSX autostart plist file with a given label, command, and - params to run at boot or login. -} diff --git a/Utility/OsString.hs b/Utility/OsString.hs index 8d92c2637a..e1854adaec 100644 --- a/Utility/OsString.hs +++ b/Utility/OsString.hs @@ -21,11 +21,12 @@ import System.OsString as X hiding (length) import qualified System.OsString import qualified Data.ByteString as B import Utility.OsPath +import Prelude ((.), Int) {- Avoid System.OsString.length, which returns the number of code points on - windows. This is the number of bytes. -} length :: System.OsString.OsString -> Int -length = B.length . fromOsString +length = B.length . fromOsPath #else import Data.ByteString as X hiding (length) import Data.ByteString (length) diff --git a/Utility/Path.hs b/Utility/Path.hs index fba9177f1f..da30b2f917 100644 --- a/Utility/Path.hs +++ b/Utility/Path.hs @@ -28,7 +28,6 @@ module Utility.Path ( ) where import qualified Data.ByteString as B -import qualified System.FilePath.ByteString as PB import Data.List import Data.Maybe import Control.Monad @@ -70,9 +69,10 @@ simplifyPath path = dropTrailingPathSeparator $ norm c [] = reverse c norm c (p:ps) - | p' == ".." && not (null c) && dropTrailingPathSeparator (c !! 0) /= ".." = - norm (drop 1 c) ps - | p' == "." = norm c ps + | p' == dotdot && not (null c) + && dropTrailingPathSeparator (c !! 0) /= dotdot = + norm (drop 1 c) ps + | p' == dot = norm c ps | otherwise = norm (p:c) ps where p' = dropTrailingPathSeparator p @@ -86,8 +86,8 @@ parentDir = takeDirectory . dropTrailingPathSeparator upFrom :: OsPath -> Maybe OsPath upFrom dir | length dirs < 2 = Nothing - | otherwise = Just $ joinDrive drive $ toOsPath $ - B.intercalate (B.singleton PB.pathSeparator) $ init dirs + | otherwise = Just $ joinDrive drive $ + OS.intercalate (OS.singleton pathSeparator) $ init dirs where -- on Unix, the drive will be "/" when the dir is absolute, -- otherwise "" @@ -101,8 +101,8 @@ upFrom dir dirContains :: OsPath -> OsPath -> Bool dirContains a b = a == b || a' == b' - || (a'' `B.isPrefixOf` b' && avoiddotdotb) - || a' == "." && normalise ("." b') == b' && nodotdot b' + || (a'' `OS.isPrefixOf` b' && avoiddotdotb) + || a' == dot && normalise (dot b') == b' && nodotdot b' || dotdotcontains where a' = norm a @@ -124,7 +124,7 @@ dirContains a b = a == b nodotdot p = all (not . isdotdot) (splitPath p) - isdotdot s = dropTrailingPathSeparator s == ".." + isdotdot s = dropTrailingPathSeparator s == dotdot {- This handles the case where a is ".." or "../.." etc, - and b is "foo" or "../foo" etc. The rule is that when @@ -185,10 +185,10 @@ runSegmentPaths' si c a paths = segmentPaths' si c paths <$> a paths - count as dotfiles. -} dotfile :: OsPath -> Bool dotfile file - | f == "." = False - | f == ".." = False - | f == "" = False - | otherwise = "." `OS.isPrefixOf` f || dotfile (takeDirectory file) + | f == dot = False + | f == dotdot = False + | f == literalOsPath "" = False + | otherwise = dot `OS.isPrefixOf` f || dotfile (takeDirectory file) where f = takeFileName file @@ -226,7 +226,7 @@ relPathDirToFileAbs from to common = map fst $ takeWhile same $ zip pfrom pto same (c,d) = c == d uncommon = drop numcommon pto - dotdots = replicate (length pfrom - numcommon) ".." + dotdots = replicate (length pfrom - numcommon) dotdot numcommon = length common #ifdef mingw32_HOST_OS normdrive = map toLower @@ -255,7 +255,7 @@ inSearchPath command = isJust <$> searchPath command searchPath :: String -> IO (Maybe OsPath) searchPath command | isAbsolute command' = copyright $ check command' - | otherwise = getSearchPath >>= getM indir . map toOsPath + | otherwise = getSearchPath >>= getM indir where command' = toOsPath command indir d = check (d command') @@ -275,7 +275,14 @@ searchPath command searchPathContents :: (OsPath -> Bool) -> IO [OsPath] searchPathContents p = filterM doesFileExist - =<< (concat <$> (getSearchPath >>= mapM (go . toOsPath))) + =<< (concat <$> (getSearchPath >>= mapM go)) where go d = map (d ) . filter p <$> catchDefaultIO [] (getDirectoryContents d) + +dot :: OsPath +dot = literalOsPath "." + +dotdot :: OsPath +dotdot = literalOsPath ".." + diff --git a/Utility/Path/AbsRel.hs b/Utility/Path/AbsRel.hs index 566e6786fa..ec0f98e25e 100644 --- a/Utility/Path/AbsRel.hs +++ b/Utility/Path/AbsRel.hs @@ -17,7 +17,6 @@ module Utility.Path.AbsRel ( relHome, ) where -import System.FilePath.ByteString import qualified Data.ByteString as B import Control.Applicative import Prelude diff --git a/Utility/Path/Tests.hs b/Utility/Path/Tests.hs index 88f94b3faa..857a3aad4b 100644 --- a/Utility/Path/Tests.hs +++ b/Utility/Path/Tests.hs @@ -17,7 +17,6 @@ module Utility.Path.Tests ( prop_dirContains_regressionTest, ) where -import System.FilePath.ByteString import qualified Data.ByteString as B import Data.List import Data.Maybe @@ -25,8 +24,8 @@ import Data.Char import Control.Applicative import Prelude +import Common import Utility.Path -import Utility.FileSystemEncoding import Utility.QuickCheck prop_upFrom_basics :: TestableFilePath -> Bool