From 2ff716be30493cc6025d9da1767d9481dee44f9e Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 10 Feb 2025 16:25:31 -0400 Subject: [PATCH] OsPath build flag no longer depends on filepath-bytestring However, filepath-bytestring is still in Setup-Depends. That's because Utility.OsPath uses it when not built with OsPath. It would be maybe possible to make Utility.OsPath fall back to using filepath, and eliminate that dependency too, but it would mean either wrapping all of System.FilePath's functions, or using `type OsPath = FilePath` Annex.Import uses ifdefs to avoid converting back to FilePath when not on windows. On windows it's a bit slower due to that conversion. Utility.Path.Windows.convertToWindowsNativeNamespace got a bit slower too, but not really worth optimising I think. Note that importing Utility.FileSystemEncoding at the same time as System.Posix.ByteString will result in conflicting definitions for RawFilePath. filepath-bytestring avoids that by importing RawFilePath from System.Posix.ByteString, but that's not possible in Utility.FileSystemEncoding, since Setup-Depends does not include unix. This turned out not to affect any code in git-annex though. Sponsored-by: Leon Schuermann --- Annex/Import.hs | 17 ++++++++-- Backend/Hash.hs | 2 +- Backend/Utilities.hs | 11 ++++--- Command/AddUrl.hs | 6 ++-- Database/RawFilePath.hs | 12 +++---- Git/Tree.hs | 61 +++++++++++++++++------------------ Types/GitConfig.hs | 3 +- Utility/FileSystemEncoding.hs | 16 ++++----- Utility/OpenFd.hs | 3 +- Utility/OsPath.hs | 4 +-- Utility/Path/Windows.hs | 7 ++-- Utility/Touch.hs | 3 +- git-annex.cabal | 4 ++- 13 files changed, 81 insertions(+), 68 deletions(-) diff --git a/Annex/Import.hs b/Annex/Import.hs index 497a868c15..b351504ace 100644 --- a/Annex/Import.hs +++ b/Annex/Import.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} module Annex.Import ( ImportTreeConfig(..), @@ -68,8 +69,10 @@ import Backend.Utilities import Control.Concurrent.STM import qualified Data.Map.Strict as M import qualified Data.Set as S -import qualified System.FilePath.Posix.ByteString as Posix import qualified Data.ByteArray.Encoding as BA +#ifdef mingw32_HOST_OS +import qualified System.FilePath.Posix as Posix +#endif {- Configures how to build an import tree. -} data ImportTreeConfig @@ -428,8 +431,12 @@ buildImportTreesGeneric converttree basetree msubdir importable@(ImportableConte -- Full directory prefix where the sub tree is located. let fullprefix = asTopFilePath $ case msubdir of Nothing -> subdir - Just d -> toOsPath $ - fromOsPath (getTopFilePath d) Posix. fromOsPath subdir + Just d -> +#ifdef mingw32_HOST_OS + toOsPath $ fromOsPath (getTopFilePath d) Posix. fromOsPath subdir +#else + getTopFilePath d subdir +#endif Tree ts <- converttree (Just fullprefix) $ map (\(p, i) -> (mkImportLocation p, i)) (importableContentsSubTree c) @@ -1091,7 +1098,11 @@ getImportableContents r importtreeconfig ci matcher = do isknown <||> (matches <&&> notignored) where -- Checks, from least to most expensive. +#ifdef mingw32_HOST_OS ingitdir = ".git" `elem` Posix.splitDirectories (fromOsPath (fromImportLocation loc)) +#else + ingitdir = literalOsPath ".git" `elem` splitDirectories (fromImportLocation loc) +#endif matches = matchesImportLocation matcher loc sz isknown = isKnownImportLocation dbhandle loc notignored = notIgnoredImportLocation importtreeconfig ci loc diff --git a/Backend/Hash.hs b/Backend/Hash.hs index 652bd796d7..c22c24db85 100644 --- a/Backend/Hash.hs +++ b/Backend/Hash.hs @@ -187,7 +187,7 @@ trivialMigrate' oldkey newbackend afile maxextlen maxexts AssociatedFile Nothing -> Nothing AssociatedFile (Just file) -> Just $ alterKey oldkey $ \d -> d { keyName = S.toShort $ keyHash oldkey - <> selectExtension maxextlen maxexts (fromOsPath file) + <> selectExtension maxextlen maxexts file , keyVariety = newvariety } {- Upgrade to fix bad previous migration that created a diff --git a/Backend/Utilities.hs b/Backend/Utilities.hs index 69da541452..f96e540161 100644 --- a/Backend/Utilities.hs +++ b/Backend/Utilities.hs @@ -14,11 +14,11 @@ import qualified Annex import Utility.Hash import Types.Key import Types.KeySource +import qualified Utility.OsString as OS import qualified Data.ByteString as S import qualified Data.ByteString.Short as S (ShortByteString, toShort) import qualified Data.ByteString.Lazy as L -import qualified System.FilePath.ByteString as P import Data.Char import Data.Word @@ -49,13 +49,13 @@ addE source sethasext k = do let ext = selectExtension (annexMaxExtensionLength c) (annexMaxExtensions c) - (fromOsPath (keyFilename source)) + (keyFilename source) return $ alterKey k $ \d -> d { keyName = keyName d <> S.toShort ext , keyVariety = sethasext (keyVariety d) } -selectExtension :: Maybe Int -> Maybe Int -> RawFilePath -> S.ByteString +selectExtension :: Maybe Int -> Maybe Int -> OsPath -> S.ByteString selectExtension maxlen maxextensions f | null es = "" | otherwise = S.intercalate "." ("":es) @@ -64,11 +64,12 @@ selectExtension maxlen maxextensions f take (fromMaybe maxExtensions maxextensions) $ filter (S.all validInExtension) $ takeWhile shortenough $ - reverse $ S.split (fromIntegral (ord '.')) (P.takeExtensions f') + reverse $ S.split (fromIntegral (ord '.')) $ + fromOsPath $ takeExtensions f' shortenough e = S.length e <= fromMaybe maxExtensionLen maxlen -- Avoid treating a file ".foo" as having its whole name as an -- extension. - f' = S.dropWhile (== fromIntegral (ord '.')) (P.takeFileName f) + f' = OS.dropWhile (== unsafeFromChar '.') (takeFileName f) validInExtension :: Word8 -> Bool validInExtension c diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs index 87a1ae629f..d81628e6b8 100644 --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -38,7 +38,6 @@ import qualified Utility.RawFilePath as R import qualified Annex.Transfer as Transfer import Network.URI -import qualified System.FilePath.ByteString as P cmd :: Command cmd = notBareRepo $ withAnnexOptions @@ -200,8 +199,9 @@ checkUrl addunlockedmatcher r o si u = do startRemote :: AddUnlockedMatcher -> Remote -> AddUrlOptions -> SeekInput -> FilePath -> URLString -> Maybe Integer -> CommandStart startRemote addunlockedmatcher r o si file uri sz = do pathmax <- liftIO $ fileNameLengthLimit "." - let file' = toOsPath $ P.joinPath $ map (truncateFilePath pathmax) $ - P.splitDirectories (toRawFilePath file) + let file' = joinPath $ + map (toOsPath . truncateFilePath pathmax . fromOsPath) $ + splitDirectories (toOsPath file) startingAddUrl si uri o $ do showNote $ UnquotedString $ "from " ++ Remote.name r showDestinationFile file' diff --git a/Database/RawFilePath.hs b/Database/RawFilePath.hs index ba82b9f90d..e154b74a3a 100644 --- a/Database/RawFilePath.hs +++ b/Database/RawFilePath.hs @@ -38,7 +38,7 @@ module Database.RawFilePath where #if MIN_VERSION_persistent_sqlite(2,13,3) import Database.Persist.Sqlite import qualified Database.Sqlite as Sqlite -import qualified System.FilePath.ByteString as P +import Utility.RawFilePath (RawFilePath) import qualified Control.Exception as E import Control.Monad.Logger (MonadLoggerIO) import Control.Monad.IO.Unlift (MonadUnliftIO) @@ -47,7 +47,7 @@ import Control.Monad.Trans.Reader (ReaderT) import UnliftIO.Resource (ResourceT, runResourceT) openWith' - :: P.RawFilePath + :: RawFilePath -> (SqlBackend -> Sqlite.Connection -> r) -> SqliteConnectionInfo -> LogFunc @@ -58,7 +58,7 @@ openWith' db f connInfo logFunc = do return $ f backend conn runSqlite' :: (MonadUnliftIO m) - => P.RawFilePath + => RawFilePath -> ReaderT SqlBackend (NoLoggingT (ResourceT m)) a -> m a runSqlite' connstr = runResourceT @@ -68,7 +68,7 @@ runSqlite' connstr = runResourceT withSqliteConn' :: (MonadUnliftIO m, MonadLoggerIO m) - => P.RawFilePath + => RawFilePath -> (SqlBackend -> m a) -> m a withSqliteConn' connstr = withSqliteConnInfo' connstr $ @@ -76,7 +76,7 @@ withSqliteConn' connstr = withSqliteConnInfo' connstr $ runSqliteInfo' :: (MonadUnliftIO m) - => P.RawFilePath + => RawFilePath -> SqliteConnectionInfo -> ReaderT SqlBackend (NoLoggingT (ResourceT m)) a -> m a @@ -87,7 +87,7 @@ runSqliteInfo' db conInfo = runResourceT withSqliteConnInfo' :: (MonadUnliftIO m, MonadLoggerIO m) - => P.RawFilePath + => RawFilePath -> SqliteConnectionInfo -> (SqlBackend -> m a) -> m a diff --git a/Git/Tree.hs b/Git/Tree.hs index 33a4b3cda0..bf304ed1fb 100644 --- a/Git/Tree.hs +++ b/Git/Tree.hs @@ -37,14 +37,13 @@ import Git.Command import Git.Sha import qualified Git.LsTree as LsTree import qualified Utility.CoProcess as CoProcess -import qualified System.FilePath.ByteString as P +import qualified Utility.OsString as OS import Numeric import System.Posix.Types import Control.Monad.IO.Class import qualified Data.Set as S import qualified Data.Map as M -import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as S8 newtype Tree = Tree [TreeContent] @@ -178,10 +177,10 @@ treeItemsToTree = go M.empty Just (NewSubTree d l) -> go (addsubtree idir m (NewSubTree d (c:l))) is _ -> - go (addsubtree idir m (NewSubTree (asTopFilePath (toOsPath idir)) [c])) is + go (addsubtree idir m (NewSubTree (asTopFilePath idir) [c])) is where p = gitPath i - idir = P.takeDirectory p + idir = takeDirectory p c = treeItemToTreeContent i addsubtree d m t @@ -191,10 +190,10 @@ treeItemsToTree = go M.empty Just (NewSubTree d' l) -> let l' = filter (\ti -> gitPath ti /= d) l in addsubtree parent m' (NewSubTree d' (t:l')) - _ -> addsubtree parent m' (NewSubTree (asTopFilePath (toOsPath parent)) [t]) + _ -> addsubtree parent m' (NewSubTree (asTopFilePath parent) [t]) | otherwise = M.insert d t m where - parent = P.takeDirectory d + parent = takeDirectory d {- Flattens the top N levels of a Tree. -} flattenTree :: Int -> Tree -> Tree @@ -285,9 +284,9 @@ adjustTree adjusttreeitem addtreeitems resolveaddconflict removefiles r repo = addtreeitempathmap = mkPathMap addtreeitems addtreeitemprefixmap = mkSubTreePathPrefixMap addtreeitems - removeset = S.fromList $ map (P.normalise . gitPath) removefiles - removed (TreeBlob f _ _) = S.member (P.normalise (gitPath f)) removeset - removed (TreeCommit f _ _) = S.member (P.normalise (gitPath f)) removeset + removeset = S.fromList $ map (normalise . gitPath) removefiles + removed (TreeBlob f _ _) = S.member (normalise (gitPath f)) removeset + removed (TreeCommit f _ _) = S.member (normalise (gitPath f)) removeset removed (RecordedSubTree _ _ _) = False removed (NewSubTree _ _) = False @@ -303,7 +302,7 @@ adjustTree adjusttreeitem addtreeitems resolveaddconflict removefiles r repo = addoldnew' (M.delete k oldm) ns Nothing -> n : addoldnew' oldm ns addoldnew' oldm [] = M.elems oldm - mkk = P.normalise . gitPath + mkk = normalise . gitPath {- Grafts subtree into the basetree at the specified location, replacing - anything that the basetree already had at that location. @@ -360,9 +359,9 @@ graftTree' subtree graftloc basetree repo hdl = go basetree subdirs graftdirs | d == graftloc = graftin' [] | otherwise = NewSubTree d [graftin' rest] - subdirs = P.splitDirectories $ gitPath graftloc + subdirs = splitDirectories $ gitPath graftloc - graftdirs = map (asTopFilePath . toInternalGitPath . toOsPath) $ + graftdirs = map (asTopFilePath . toInternalGitPath) $ pathPrefixes subdirs {- Assumes the list is ordered, with tree objects coming right before their @@ -392,16 +391,16 @@ extractTree l = case go [] inTopTree l of parseerr = Left class GitPath t where - gitPath :: t -> RawFilePath + gitPath :: t -> OsPath -instance GitPath RawFilePath where +instance GitPath OsPath where gitPath = id instance GitPath FilePath where - gitPath = toRawFilePath + gitPath = toOsPath instance GitPath TopFilePath where - gitPath = fromOsPath . getTopFilePath + gitPath = getTopFilePath instance GitPath TreeItem where gitPath (TreeItem f _ _) = gitPath f @@ -418,22 +417,22 @@ instance GitPath TreeContent where inTopTree :: GitPath t => t -> Bool inTopTree = inTree topTreePath -topTreePath :: RawFilePath -topTreePath = "." +topTreePath :: OsPath +topTreePath = literalOsPath "." inTree :: (GitPath t, GitPath f) => t -> f -> Bool -inTree t f = gitPath t == P.takeDirectory (gitPath f) +inTree t f = gitPath t == takeDirectory (gitPath f) beneathSubTree :: (GitPath t, GitPath f) => t -> f -> Bool -beneathSubTree t f = subTreePrefix t `B.isPrefixOf` subTreePath f +beneathSubTree t f = subTreePrefix t `OS.isPrefixOf` subTreePath f -subTreePath :: GitPath t => t -> RawFilePath -subTreePath = P.normalise . gitPath +subTreePath :: GitPath t => t -> OsPath +subTreePath = normalise . gitPath -subTreePrefix :: GitPath t => t -> RawFilePath +subTreePrefix :: GitPath t => t -> OsPath subTreePrefix t - | B.null tp = tp - | otherwise = P.addTrailingPathSeparator (P.normalise tp) + | OS.null tp = tp + | otherwise = addTrailingPathSeparator (normalise tp) where tp = gitPath t @@ -443,23 +442,23 @@ subTreePrefix t - Values that are not in any subdirectory are placed in - the topTreePath key. -} -mkPathMap :: GitPath t => [t] -> M.Map RawFilePath [t] +mkPathMap :: GitPath t => [t] -> M.Map OsPath [t] mkPathMap l = M.fromListWith (++) $ - map (\ti -> (P.takeDirectory (gitPath ti), [ti])) l + map (\ti -> (takeDirectory (gitPath ti), [ti])) l {- Input is eg splitDirectories "foo/bar/baz", - for which it will output ["foo", "foo/bar", "foo/bar/baz"] -} -pathPrefixes :: [RawFilePath] -> [RawFilePath] +pathPrefixes :: [OsPath] -> [OsPath] pathPrefixes = go [] where go _ [] = [] - go base (d:rest) = (P.joinPath base P. d) : go (base ++ [d]) rest + go base (d:rest) = (joinPath base d) : go (base ++ [d]) rest {- Makes a Map where the keys are all subtree path prefixes, - and the values are items with that subtree path prefix. -} -mkSubTreePathPrefixMap :: GitPath t => [t] -> M.Map RawFilePath [t] +mkSubTreePathPrefixMap :: GitPath t => [t] -> M.Map OsPath [t] mkSubTreePathPrefixMap l = M.fromListWith (++) $ concatMap go l where go ti = map (\p -> (p, [ti])) - (map subTreePrefix $ pathPrefixes $ P.splitDirectories $ subTreePath ti) + (map subTreePrefix $ pathPrefixes $ splitDirectories $ subTreePath ti) diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs index 55a5403c5f..255778387f 100644 --- a/Types/GitConfig.hs +++ b/Types/GitConfig.hs @@ -64,7 +64,6 @@ import Control.Concurrent.STM import qualified Data.Set as S import qualified Data.Map as M import qualified Data.ByteString as B -import qualified System.FilePath.ByteString as P -- | A configurable value, that may not be fully determined yet because -- the global git config has not yet been loaded. @@ -244,7 +243,7 @@ extractGitConfig configsource r = GitConfig , annexPidLock = getbool (annexConfig "pidlock") False , annexPidLockTimeout = Seconds $ fromMaybe 300 $ getmayberead (annexConfig "pidlocktimeout") - , annexDbDir = (\d -> toOsPath (toRawFilePath d P. fromUUID hereuuid)) + , annexDbDir = (\d -> toOsPath d fromUUID hereuuid) <$> getmaybe (annexConfig "dbdir") , annexAddUnlocked = configurable Nothing $ fmap Just $ getmaybe (annexConfig "addunlocked") diff --git a/Utility/FileSystemEncoding.hs b/Utility/FileSystemEncoding.hs index cf9355ccd5..d66d8a008c 100644 --- a/Utility/FileSystemEncoding.hs +++ b/Utility/FileSystemEncoding.hs @@ -23,7 +23,6 @@ module Utility.FileSystemEncoding ( import qualified GHC.IO.Encoding as Encoding import System.IO -import System.FilePath.ByteString (RawFilePath, encodeFilePath, decodeFilePath) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L #ifdef mingw32_HOST_OS @@ -37,6 +36,9 @@ import Data.Char import Data.List #endif +-- | A literal file path +type RawFilePath = S.ByteString + {- Makes all subsequent Handles that are opened, as well as stdio Handles, - use the filesystem encoding, instead of the encoding of the current - locale. @@ -90,9 +92,7 @@ encodeBL = L8.fromString decodeBS :: S.ByteString -> FilePath #ifndef mingw32_HOST_OS -- This does the same thing as System.FilePath.ByteString.decodeFilePath, --- with an identical implementation. However, older versions of that library --- truncated at NUL, which this must not do, because it may end up used on --- something other than a unix filepath. +-- with an identical implementation. {-# NOINLINE decodeBS #-} decodeBS b = unsafePerformIO $ do enc <- Encoding.getFileSystemEncoding @@ -104,9 +104,7 @@ decodeBS = S8.toString encodeBS :: FilePath -> S.ByteString #ifndef mingw32_HOST_OS -- This does the same thing as System.FilePath.ByteString.encodeFilePath, --- with an identical implementation. However, older versions of that library --- truncated at NUL, which this must not do, because it may end up used on --- something other than a unix filepath. +-- with an identical implementation. {-# NOINLINE encodeBS #-} encodeBS f = unsafePerformIO $ do enc <- Encoding.getFileSystemEncoding @@ -116,10 +114,10 @@ encodeBS = S8.fromString #endif fromRawFilePath :: RawFilePath -> FilePath -fromRawFilePath = decodeFilePath +fromRawFilePath = decodeBS toRawFilePath :: FilePath -> RawFilePath -toRawFilePath = encodeFilePath +toRawFilePath = encodeBS {- Truncates a FilePath to the given number of bytes (or less), - as represented on disk. diff --git a/Utility/OpenFd.hs b/Utility/OpenFd.hs index 16a364a4d1..17be54e016 100644 --- a/Utility/OpenFd.hs +++ b/Utility/OpenFd.hs @@ -14,7 +14,8 @@ module Utility.OpenFd where import System.Posix.IO.ByteString import System.Posix.Types -import System.FilePath.ByteString (RawFilePath) + +import Utility.RawFilePath openFdWithMode :: RawFilePath -> OpenMode -> Maybe FileMode -> OpenFileFlags -> IO Fd #if MIN_VERSION_unix(2,8,0) diff --git a/Utility/OsPath.hs b/Utility/OsPath.hs index fb4e23dca5..acdd12e97e 100644 --- a/Utility/OsPath.hs +++ b/Utility/OsPath.hs @@ -31,7 +31,7 @@ import qualified Data.ByteString.Lazy as L import System.OsPath as X hiding (OsPath, OsString, pack, unpack, unsafeFromChar) import System.OsPath import "os-string" System.OsString.Internal.Types -import qualified System.FilePath.ByteString as PB +import qualified System.FilePath as PS #if defined(mingw32_HOST_OS) import GHC.IO (unsafePerformIO) import System.OsString.Encoding.Internal (cWcharsToChars_UCS2) @@ -100,7 +100,7 @@ bytesFromOsPath = getPosixString . getOsString {- For some reason not included in System.OsPath -} getSearchPath :: IO [OsPath] -getSearchPath = map toOsPath <$> PB.getSearchPath +getSearchPath = map toOsPath <$> PS.getSearchPath {- Used for string constants. Note that when using OverloadedStrings, - the IsString instance for ShortByteString only works properly with diff --git a/Utility/Path/Windows.hs b/Utility/Path/Windows.hs index 583f90dd61..4e2da49f70 100644 --- a/Utility/Path/Windows.hs +++ b/Utility/Path/Windows.hs @@ -15,9 +15,10 @@ module Utility.Path.Windows ( import Utility.Path import Utility.OsPath import Utility.SystemDirectory +import Utility.FileSystemEncoding import qualified Data.ByteString as B -import qualified System.FilePath.Windows.ByteString as P +import qualified System.FilePath.Windows as WinPath {- Convert a filepath to use Windows's native namespace. - This avoids filesystem length limits. @@ -36,9 +37,9 @@ convertToWindowsNativeNamespace f -- Make absolute because any '.' and '..' in the path -- will not be resolved once it's converted. cwd <- getCurrentDirectory - let p = fromOsPath (simplifyPath (combine cwd (toOsPath f))) + let p = simplifyPath (combine cwd (toOsPath f)) -- Normalize slashes. - let p' = P.normalise p + let p' = encodeBS $ WinPath.normalise $ fromOsPath p return (win32_file_namespace <> p') where win32_dev_namespace = "\\\\.\\" diff --git a/Utility/Touch.hs b/Utility/Touch.hs index 8831f306a3..67005934bd 100644 --- a/Utility/Touch.hs +++ b/Utility/Touch.hs @@ -14,10 +14,11 @@ module Utility.Touch ( #if ! defined(mingw32_HOST_OS) -import System.FilePath.ByteString (RawFilePath) import System.Posix.Files.ByteString import Data.Time.Clock.POSIX +import Utility.RawFilePath + {- Changes the access and modification times of an existing file. Can follow symlinks, or not. -} touchBoth :: RawFilePath -> POSIXTime -> POSIXTime -> Bool -> IO () diff --git a/git-annex.cabal b/git-annex.cabal index e189e49459..9b0f95143a 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -230,7 +230,6 @@ Executable git-annex directory (>= 1.2.7.0), disk-free-space, filepath, - filepath-bytestring (>= 1.4.2.1.1), IfElse, monad-logger (>= 0.3.10), free, @@ -339,6 +338,9 @@ Executable git-annex filepath (>= 1.5.2.0), file-io (>= 0.1.3) CPP-Options: -DWITH_OSPATH + else + Build-Depends: + filepath-bytestring (>= 1.4.2.1.1) if (os(windows)) Build-Depends: