Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 7666f4a9 by Fendor at 2026-04-17T22:29:51-04:00 Migrate `ghc-pkg` to use `OsPath` and `file-io` `ghc-pkg` should use UNC paths as much as possible to avoid MAX_PATH issues on windows. `file-io` uses UNC Paths by default on windows, ensuring we use the correct APIs and that we finally are no longer plagued by MAX_PATH issues in CI and private machines. On top of it, the higher correctness of `OsPath` is appreciated in this small codebase. Also, we improve memory usage very slightly, due to the more efficient memory representation of `OsPath` over `FilePath` Adds `ghc-pkg` regression test for MAX_PATH on windows Make sure `ghc-pkg` behaves as expected when long paths (> 255) are involved on windows. Let's generate a testcase where we can actually observe that `ghc-pkg` behaves as epxected. See the documentation for windows on Maximum Path Length Limitation: * `https://learn.microsoft.com/en-us/windows/win32/fileio/maximum-file-path-limitation` Adds changelog entry for long path support in ghc-pkg. - - - - - 9 changed files: - + changelog.d/ghc-pkg-long-path-support - compiler/GHC/Unit/State.hs - libraries/ghc-boot/GHC/Unit/Database.hs - libraries/ghc-boot/ghc-boot.cabal.in - testsuite/tests/cabal/Makefile - testsuite/tests/cabal/all.T - + testsuite/tests/cabal/ghcpkg10.stdout - utils/ghc-pkg/Main.hs - utils/ghc-pkg/ghc-pkg.cabal.in Changes: ===================================== changelog.d/ghc-pkg-long-path-support ===================================== @@ -0,0 +1,15 @@ +section: ghc-pkg +synopsis: Improve ``ghc-pkg``'s support for long paths on windows. +issues: #26960 +mrs: !15584 + +description: { + ``ghc-pkg`` can't handle working with file paths longer than the MAX_PATH + restrictions on windows as it is not using UNC file paths by default. + + By using UNC file paths whenever possible, we improve ``ghc-pkg`` on windows. + Note, this still requires the user to enable the use of long paths in order to opt-in + this behaviour on older windows machines. +} + + ===================================== compiler/GHC/Unit/State.hs ===================================== @@ -802,7 +802,7 @@ readUnitDatabase logger cfg conf_file = do if cache_exists then do debugTraceMsg logger 2 $ text "Using binary package database:" <+> ppr filename - readPackageDbForGhc (OsPath.unsafeDecodeUtf filename) + readPackageDbForGhc filename else do -- If there is no package.cache file, we check if the database is not -- empty by inspecting if the directory contains any .conf file. If it ===================================== libraries/ghc-boot/GHC/Unit/Database.hs ===================================== @@ -68,6 +68,8 @@ module GHC.Unit.Database -- * Misc , mkMungePathUrl , mungeUnitInfoPaths + , writeFileAtomic + , unsafeDecodeUtf ) where @@ -86,18 +88,23 @@ import Data.Binary.Get as Bin import Data.List (intersperse) import Control.Exception as Exception import Control.Monad (when) -import System.FilePath as FilePath +import qualified System.FilePath as FilePath #if !defined(mingw32_HOST_OS) import Data.Bits ((.|.)) -import System.Posix.Files +import System.Posix.Files.PosixString import System.Posix.Types (FileMode) +import System.OsString.Internal.Types (getOsString) #endif import System.IO import System.IO.Error import GHC.IO.Exception (IOErrorType(InappropriateType)) import qualified GHC.Data.ShortText as ST import GHC.IO.Handle.Lock -import System.Directory +import GHC.Stack.Types (HasCallStack) +import System.OsPath +import qualified System.Directory.OsPath as OsPath +import qualified System.Directory.Internal as OsPath.Internal +import qualified System.File.OsPath as FileIO -- | @ghc-boot@'s UnitInfo, serialized to the database. type DbUnitInfo = GenericUnitInfo BS.ByteString BS.ByteString BS.ByteString BS.ByteString DbModule @@ -314,13 +321,13 @@ data DbInstUnitId newtype PackageDbLock = PackageDbLock Handle -- | Acquire an exclusive lock related to package DB under given location. -lockPackageDb :: FilePath -> IO PackageDbLock +lockPackageDb :: OsPath -> IO PackageDbLock -- | Release the lock related to package DB. unlockPackageDb :: PackageDbLock -> IO () -- | Acquire a lock of given type related to package DB under given location. -lockPackageDbWith :: LockMode -> FilePath -> IO PackageDbLock +lockPackageDbWith :: LockMode -> OsPath -> IO PackageDbLock lockPackageDbWith mode file = do -- We are trying to open the lock file and then lock it. Thus the lock file -- needs to either exist or we need to be able to create it. Ideally we @@ -350,10 +357,10 @@ lockPackageDbWith mode file = do (lockFileOpenIn ReadWriteMode) (const $ lockFileOpenIn ReadMode) where - lock = file <.> "lock" + lock = file <.> OsPath.Internal.os "lock" lockFileOpenIn io_mode = bracketOnError - (openBinaryFile lock io_mode) + (FileIO.openBinaryFile lock io_mode) hClose -- If file locking support is not available, ignore the error and proceed -- normally. Without it the only thing we lose on non-Windows platforms is @@ -387,7 +394,7 @@ isDbOpenReadMode = \case -- | Read the part of the package DB that GHC is interested in. -- -readPackageDbForGhc :: FilePath -> IO [DbUnitInfo] +readPackageDbForGhc :: OsPath -> IO [DbUnitInfo] readPackageDbForGhc file = decodeFromFile file DbOpenReadOnly getDbForGhc >>= \case (pkgs, DbOpenReadOnly) -> return pkgs @@ -409,7 +416,7 @@ readPackageDbForGhc file = -- we additionally receive a PackageDbLock that represents a lock on the -- database, so that we can safely update it later. -- -readPackageDbForGhcPkg :: Binary pkgs => FilePath -> DbOpenMode mode t -> +readPackageDbForGhcPkg :: Binary pkgs => OsPath -> DbOpenMode mode t -> IO (pkgs, DbOpenMode mode PackageDbLock) readPackageDbForGhcPkg file mode = decodeFromFile file mode getDbForGhcPkg @@ -425,7 +432,7 @@ readPackageDbForGhcPkg file mode = -- | Write the whole of the package DB, both parts. -- -writePackageDb :: Binary pkgs => FilePath -> [DbUnitInfo] -> pkgs -> IO () +writePackageDb :: Binary pkgs => OsPath -> [DbUnitInfo] -> pkgs -> IO () writePackageDb file ghcPkgs ghcPkgPart = do writeFileAtomic file (runPut putDbForGhcPkg) #if !defined(mingw32_HOST_OS) @@ -446,10 +453,10 @@ writePackageDb file ghcPkgs ghcPkgPart = do ghcPart = encode ghcPkgs #if !defined(mingw32_HOST_OS) -addFileMode :: FilePath -> FileMode -> IO () +addFileMode :: OsPath -> FileMode -> IO () addFileMode file m = do - o <- fileMode <$> getFileStatus file - setFileMode file (m .|. o) + o <- fileMode <$> getFileStatus (getOsString file) + setFileMode (getOsString file) (m .|. o) #endif getHeader :: Get (Word32, Word32) @@ -496,7 +503,7 @@ headerMagic = BS.Char8.pack "\0ghcpkg\0" -- | Feed a 'Get' decoder with data chunks from a file. -- -decodeFromFile :: FilePath -> DbOpenMode mode t -> Get pkgs -> +decodeFromFile :: OsPath -> DbOpenMode mode t -> Get pkgs -> IO (pkgs, DbOpenMode mode PackageDbLock) decodeFromFile file mode decoder = case mode of DbOpenReadOnly -> do @@ -517,7 +524,7 @@ decodeFromFile file mode decoder = case mode of bracketOnError (lockPackageDb file) unlockPackageDb $ \lock -> do (, DbOpenReadWrite lock) <$> decodeFileContents where - decodeFileContents = withBinaryFile file ReadMode $ \hnd -> + decodeFileContents = FileIO.withBinaryFile file ReadMode $ \hnd -> feed hnd (runGetIncremental decoder) feed hnd (Partial k) = do chunk <- BS.hGet hnd BS.Lazy.defaultChunkSize @@ -527,21 +534,21 @@ decodeFromFile file mode decoder = case mode of feed _ (Done _ _ res) = return res feed _ (Fail _ _ msg) = ioError err where - err = mkIOError InappropriateType loc Nothing (Just file) + err = mkIOError InappropriateType loc Nothing (Just $ unsafeDecodeUtf file) `ioeSetErrorString` msg loc = "GHC.Unit.Database.readPackageDb" -- Copied from Cabal's Distribution.Simple.Utils. -writeFileAtomic :: FilePath -> BS.Lazy.ByteString -> IO () +writeFileAtomic :: OsPath -> BS.Lazy.ByteString -> IO () writeFileAtomic targetPath content = do let (targetDir, targetFile) = splitFileName targetPath Exception.bracketOnError - (openBinaryTempFileWithDefaultPermissions targetDir $ targetFile <.> "tmp") - (\(tmpPath, handle) -> hClose handle >> removeFile tmpPath) + (FileIO.openBinaryTempFileWithDefaultPermissions targetDir $ targetFile <.> OsPath.Internal.os "tmp") + (\(tmpPath, handle) -> hClose handle >> OsPath.removeFile tmpPath) (\(tmpPath, handle) -> do BS.Lazy.hPut handle content hClose handle - renameFile tmpPath targetPath) + OsPath.renameFile tmpPath targetPath) instance Binary DbUnitInfo where put (GenericUnitInfo @@ -711,7 +718,7 @@ mkMungePathUrl top_dir pkgroot = (munge_path, munge_url) -- rather than letting FilePath change it to use \ as the separator stripVarPrefix var path = case ST.stripPrefix var path of Just "" -> Just "" - Just cs | isPathSeparator (ST.head cs) -> Just cs + Just cs | FilePath.isPathSeparator (ST.head cs) -> Just cs _ -> Nothing @@ -742,3 +749,8 @@ mungeUnitInfoPaths top_dir pkgroot pkg = munge_paths = map munge_path munge_urls = map munge_url (munge_path,munge_url) = mkMungePathUrl top_dir pkgroot + +-- | Decode an 'OsPath' to 'FilePath', throwing an 'error' if decoding failed. +-- Prefer 'decodeUtf' and gracious error handling. +unsafeDecodeUtf :: HasCallStack => OsPath -> FilePath +unsafeDecodeUtf = OsPath.Internal.so ===================================== libraries/ghc-boot/ghc-boot.cabal.in ===================================== @@ -82,6 +82,8 @@ Library containers >= 0.5 && < 0.9, directory >= 1.2 && < 1.4, filepath >= 1.3 && < 1.6, + file-io >= 0.1.6 && < 0.3, + os-string >= 2.0.1 && < 2.1, deepseq >= 1.4 && < 1.6, ghc-platform >= 0.1, ghc-toolchain >= 0.1 ===================================== testsuite/tests/cabal/Makefile ===================================== @@ -79,6 +79,25 @@ ghcpkg04 : @: # testpkg-1.2.3.4 and newtestpkg-2.0 are both exposed now '$(TEST_HC)' $(TEST_HC_OPTS) -package-db $(PKGCONF04) -c ghcpkg04.hs || true +PKGCONF20=local20.package.conf +LOCAL_GHC_PKG20 = '$(GHC_PKG)' --no-user-package-db + +DIR1=asdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdf +DIR2=zxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcv +DIR3=uiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiop +DIR4=qwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwer +WDIR=$(DIR1)/$(DIR2)/$(DIR3)/$(DIR4) +.PHONY: ghcpkg10 +ghcpkg10 : + @mkdir -p $(WDIR) + @rm -rf $(WDIR)/$(PKGCONF20) + $(LOCAL_GHC_PKG20) -f $(WDIR)/$(PKGCONF20) init $(WDIR)/$(PKGCONF20) + $(LOCAL_GHC_PKG20) -f $(WDIR)/$(PKGCONF20) list + $(LOCAL_GHC_PKG20) -f $(WDIR)/$(PKGCONF20) register --force test.pkg 2>/dev/null + $(LOCAL_GHC_PKG20) -f $(WDIR)/$(PKGCONF20) describe testpkg | $(STRIP_PKGROOT) + $(LOCAL_GHC_PKG20) -f $(WDIR)/$(PKGCONF20) describe testpkg-1.2.3.4 | $(STRIP_PKGROOT) + $(LOCAL_GHC_PKG20) -f $(WDIR)/$(PKGCONF20) field testpkg-1.2.3.4 import-dirs + # Test stacking of package.confs (also #2441) PKGCONF05a=local05a.package.conf PKGCONF05b=local05b.package.conf ===================================== testsuite/tests/cabal/all.T ===================================== @@ -5,6 +5,7 @@ def ignore_warnings(str): return re.sub(r'Warning:.*\n', '', str) test('ghcpkg01', [extra_files(['test.pkg', 'test2.pkg', 'test3.pkg'])], makefile_test, []) +test('ghcpkg10', [extra_files(['test.pkg', 'test2.pkg', 'test3.pkg'])], makefile_test, []) # Use ignore_stderr to prevent (when HADDOCK_DOCS=NO): # warning: haddock-interfaces .. doesn't exist or isn't a file ===================================== testsuite/tests/cabal/ghcpkg10.stdout ===================================== @@ -0,0 +1,50 @@ +asdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdf/zxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcv/uiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiop/qwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwer/local20.package.conf + (no packages) +Reading package info from "test.pkg" ... done. +name: testpkg +version: 1.2.3.4 +visibility: public +id: testpkg-1.2.3.4-XXX +key: testpkg-1.2.3.4-XXX +license: BSD3 +copyright: (c) The Univsersity of Glasgow 2004 +maintainer: glasgow-haskell-users@haskell.org +author: simonmar@microsoft.com +stability: stable +homepage: http://www.haskell.org/ghc +package-url: http://www.haskell.org/ghc +description: A Test Package +category: none +exposed: True +exposed-modules: A +hidden-modules: B C.D +import-dirs: /usr/local/lib/testpkg "c:/Program Files/testpkg" +library-dirs: /usr/local/lib/testpkg "c:/Program Files/testpkg" +hs-libraries: testpkg-1.2.3.4-XXX +include-dirs: /usr/local/include/testpkg "c:/Program Files/testpkg" +pkgroot: + +name: testpkg +version: 1.2.3.4 +visibility: public +id: testpkg-1.2.3.4-XXX +key: testpkg-1.2.3.4-XXX +license: BSD3 +copyright: (c) The Univsersity of Glasgow 2004 +maintainer: glasgow-haskell-users@haskell.org +author: simonmar@microsoft.com +stability: stable +homepage: http://www.haskell.org/ghc +package-url: http://www.haskell.org/ghc +description: A Test Package +category: none +exposed: True +exposed-modules: A +hidden-modules: B C.D +import-dirs: /usr/local/lib/testpkg "c:/Program Files/testpkg" +library-dirs: /usr/local/lib/testpkg "c:/Program Files/testpkg" +hs-libraries: testpkg-1.2.3.4-XXX +include-dirs: /usr/local/include/testpkg "c:/Program Files/testpkg" +pkgroot: + +import-dirs: /usr/local/lib/testpkg "c:/Program Files/testpkg" ===================================== utils/ghc-pkg/Main.hs ===================================== @@ -47,12 +47,19 @@ import Distribution.Types.UnqualComponentName import Distribution.Types.LibraryName import Distribution.Types.MungedPackageName import Distribution.Types.MungedPackageId -import Distribution.Simple.Utils (toUTF8BS, writeUTF8File, readUTF8File) +import Distribution.Simple.Utils (ignoreBOM, toUTF8BS, toUTF8LBS, fromUTF8LBS) import qualified Data.Version as Version -import System.FilePath as FilePath +import System.OsPath as OsPath +import qualified System.FilePath as FilePath import qualified System.FilePath.Posix as FilePath.Posix -import System.Directory ( getXdgDirectory, createDirectoryIfMissing, getAppUserDataDirectory, - getModificationTime, XdgDirectory ( XdgData ) ) +import System.Directory.OsPath + ( getXdgDirectory, createDirectoryIfMissing, getAppUserDataDirectory, + getModificationTime, XdgDirectory ( XdgData ), + doesDirectoryExist, getDirectoryContents, + doesFileExist, removeFile, + getCurrentDirectory ) +import System.Directory.Internal (os) +import qualified System.File.OsPath as FileIO import Text.Printf import Prelude hiding (Foldable(..)) @@ -65,15 +72,13 @@ import Data.Bifunctor import Data.Char ( toLower ) import Control.Monad -import System.Directory ( doesDirectoryExist, getDirectoryContents, - doesFileExist, removeFile, - getCurrentDirectory ) import System.Exit ( exitWith, ExitCode(..) ) import System.Environment ( getArgs, getProgName, getEnv ) import System.IO import System.IO.Error -import GHC.IO ( catchException ) +import GHC.IO ( catchException, unsafePerformIO ) import GHC.IO.Exception (IOErrorType(InappropriateType)) +import GHC.Stack.Types (HasCallStack) import Data.List ( group, sort, sortBy, nub, partition, find , intercalate, intersperse, unfoldr , isInfixOf, isSuffixOf, isPrefixOf, stripPrefix ) @@ -429,8 +434,9 @@ runit verbosity cli nonopts = do print filename glob filename >>= print #endif - ["init", filename] -> - initPackageDB filename verbosity cli + ["init", filename] -> do + filenameOs <- encodeFS filename + initPackageDB filenameOs verbosity cli ["register", filename] -> registerPackage filename verbosity cli multi_instance @@ -538,7 +544,7 @@ readPackageArg AsDefault str = Id <$> readGlobPkgId str data PackageDB (mode :: GhcPkg.DbMode) = PackageDB { - location, locationAbsolute :: !FilePath, + location, locationAbsolute :: !OsPath, -- We need both possibly-relative and definitely-absolute package -- db locations. This is because the relative location is used as -- an identifier for the db, so it is important we do not modify it. @@ -570,14 +576,14 @@ allPackagesInStack = concatMap packages -- specified package DB can depend on, since dependencies can only extend -- down the stack, not up (e.g. global packages cannot depend on user -- packages). -stackUpTo :: FilePath -> PackageDBStack -> PackageDBStack +stackUpTo :: OsPath -> PackageDBStack -> PackageDBStack stackUpTo to_modify = dropWhile ((/= to_modify) . location) -readFromSettingsFile :: FilePath - -> (FilePath -> RawSettings -> Either String b) +readFromSettingsFile :: OsPath + -> (OsPath -> RawSettings -> Either String b) -> IO (Either String b) readFromSettingsFile settingsFile f = do - settingsStr <- readFile settingsFile + settingsStr <- readUtf8File settingsFile pure $ do mySettings <- case maybeReadFuzzy settingsStr of Just s -> pure $ Map.fromList s @@ -586,11 +592,11 @@ readFromSettingsFile settingsFile f = do Nothing -> Left $ "Can't parse settings file " ++ show settingsFile f settingsFile mySettings -readFromTargetFile :: FilePath +readFromTargetFile :: OsPath -> (Target -> b) -> IO (Either String b) readFromTargetFile targetFile f = do - targetStr <- readFile targetFile + targetStr <- readUtf8File targetFile pure $ do target <- case maybeReadFuzzy targetStr of Just t -> Right t @@ -626,33 +632,35 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do case [ f | FlagGlobalConfig f <- my_flags ] of -- See Note [Base Dir] for more information on the base dir / top dir. [] -> do mb_dir <- getBaseDir - case mb_dir of + mb_dir_os <- traverse encodeFS mb_dir + case mb_dir_os of Nothing -> die err_msg Just dir -> do -- Look for where it is given in the settings file, if marked there. -- See Note [Settings file] about this file, and why we need GHC to share it with us. - let settingsFile = dir "settings" + let settingsFile = dir os "settings" exists_settings_file <- doesFileExist settingsFile erel_db <- if exists_settings_file - then readFromSettingsFile settingsFile getGlobalPackageDb - else pure (Left ("Settings file doesn't exist: " ++ settingsFile)) + then do + readFromSettingsFile settingsFile (\ settings -> getGlobalPackageDb (unsafeDecodeUtf settings)) + else pure (Left ("Settings file doesn't exist: " ++ showOsPath settingsFile)) case erel_db of - Right rel_db -> return (dir, dir rel_db) + Right rel_db -> return (dir, dir unsafeEncodeUtf rel_db) -- If the version of GHC doesn't have this field or the settings file -- doesn't exist for some reason, look in the libdir. Left err -> do r <- lookForPackageDBIn dir case r of - Nothing -> die (unlines [err, ("Fallback: Can't find package database in " ++ dir)]) + Nothing -> die (unlines [err, ("Fallback: Can't find package database in " ++ showOsPath dir)]) Just path -> return (dir, path) fs -> do -- The value of the $topdir variable used in some package descriptions -- Note that the way we calculate this is slightly different to how it -- is done in ghc itself. We rely on the convention that the global -- package db lives in ghc's libdir. - let pkg_db = last fs + let pkg_db = unsafeEncodeUtf $ last fs top_dir <- absolutePath (takeDirectory pkg_db) return (top_dir, pkg_db) @@ -662,10 +670,10 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do -- getXdgDirectory can fail (e.g. if $HOME isn't set) mb_user_conf <- - case [ f | FlagUserConfig f <- my_flags ] of + case [ unsafeEncodeUtf f | FlagUserConfig f <- my_flags ] of _ | no_user_db -> return Nothing [] -> do - let targetFile = top_dir "targets" "default.target" + let targetFile = top_dir os "targets" os "default.target" exists_settings_file <- doesFileExist targetFile targetArchOS <- case exists_settings_file of False -> do @@ -694,15 +702,15 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do -- otherwise we use $XDG_DATA_HOME/$UNIQUE_SUBDIR -- -- UNIQUE_SUBDIR is typically a combination of the target platform and GHC version - m_appdir <- getFirstSuccess $ map (fmap ( subdir)) - [ getAppUserDataDirectory "ghc" -- this is ~/.ghc/ - , getXdgDirectory XdgData "ghc" -- this is $XDG_DATA_HOME/ + m_appdir <- getFirstSuccess $ map (fmap ( unsafeEncodeUtf subdir)) + [ getAppUserDataDirectory $ os "ghc" -- this is ~/.ghc/ + , getXdgDirectory XdgData $ os "ghc" -- this is $XDG_DATA_HOME/ ] case m_appdir of Nothing -> return Nothing Just dir -> do lookForPackageDBIn dir >>= \case - Nothing -> return (Just (dir "package.conf.d", False)) + Nothing -> return (Just (dir os "package.conf.d", False)) Just f -> return (Just (f, True)) fs -> return (Just (last fs, True)) @@ -716,11 +724,11 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do e_pkg_path <- tryIO (System.Environment.getEnv "GHC_PACKAGE_PATH") let env_stack = - case e_pkg_path of + case fmap unsafeEncodeUtf e_pkg_path of Left _ -> sys_databases Right path - | not (null path) && isSearchPathSeparator (last path) - -> splitSearchPath (init path) ++ sys_databases + | hasTrailingPathSeparator path + -> splitSearchPath (dropTrailingPathSeparator path) <> sys_databases | otherwise -> splitSearchPath path @@ -733,7 +741,7 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do | Just (user_conf, _user_exists) <- mb_user_conf = Just user_conf is_db_flag FlagGlobal = Just virt_global_conf - is_db_flag (FlagConfig f) = Just f + is_db_flag (FlagConfig f) = Just $ unsafeEncodeUtf f is_db_flag _ = Nothing let flag_db_names | null db_flags = env_stack @@ -748,7 +756,7 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do -- stack, unless any of them are present in the stack -- already. let final_stack = filter (`notElem` env_stack) - [ f | FlagConfig f <- reverse my_flags ] + [ unsafeEncodeUtf f | FlagConfig f <- reverse my_flags ] ++ env_stack top_db = if null db_flags @@ -764,7 +772,7 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do when (verbosity > Normal) $ do infoLn ("db stack: " ++ show (map location db_stack)) F.forM_ db_to_operate_on $ \db -> - infoLn ("modifying: " ++ (location db)) + infoLn ("modifying: " ++ showOsPath (location db)) infoLn ("flag db stack: " ++ show (map location flag_db_stack)) return (db_stack, db_to_operate_on, flag_db_stack) @@ -843,17 +851,19 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do return (db_stack, GhcPkg.DbOpenReadWrite to_modify) where - couldntOpenDbForModification :: FilePath -> IOError -> IO a + couldntOpenDbForModification :: OsPath -> IOError -> IO a couldntOpenDbForModification db_path e = die $ "Couldn't open database " - ++ db_path ++ " for modification: " ++ show e + ++ showOsPath db_path ++ " for modification: " ++ show e -- Parse package db in read-only mode. - readDatabase :: FilePath -> IO (PackageDB 'GhcPkg.DbReadOnly) + readDatabase :: OsPath -> IO (PackageDB 'GhcPkg.DbReadOnly) readDatabase db_path = do db <- readParseDatabase verbosity mb_user_conf GhcPkg.DbOpenReadOnly use_cache db_path if expand_vars - then return $ mungePackageDBPaths top_dir db + then do + top_dir_filepath <- decodeFS top_dir + return $ mungePackageDBPaths top_dir_filepath db else return db stateSequence :: Monad m => s -> [s -> m (a, s)] -> m ([a], s) @@ -863,20 +873,20 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do (as, s'') <- stateSequence s' ms return (a : as, s'') -lookForPackageDBIn :: FilePath -> IO (Maybe FilePath) +lookForPackageDBIn :: OsPath -> IO (Maybe OsPath) lookForPackageDBIn dir = do - let path_dir = dir "package.conf.d" + let path_dir = dir os "package.conf.d" exists_dir <- doesDirectoryExist path_dir if exists_dir then return (Just path_dir) else do - let path_file = dir "package.conf" + let path_file = dir os "package.conf" exists_file <- doesFileExist path_file if exists_file then return (Just path_file) else return Nothing readParseDatabase :: forall mode t. Verbosity - -> Maybe (FilePath,Bool) + -> Maybe (OsPath,Bool) -> GhcPkg.DbOpenMode mode t -> Bool -- use cache - -> FilePath + -> OsPath -> IO (PackageDB mode) readParseDatabase verbosity mb_user_conf mode use_cache path -- the user database (only) is allowed to be non-existent @@ -898,7 +908,7 @@ readParseDatabase verbosity mb_user_conf mode use_cache path Just db -> return db Nothing -> die $ "ghc no longer supports single-file style package " - ++ "databases (" ++ path ++ ") use 'ghc-pkg init'" + ++ "databases (" ++ showOsPath path ++ ") use 'ghc-pkg init'" ++ "to create the database with the correct format." | otherwise -> ioError err @@ -914,7 +924,7 @@ readParseDatabase verbosity mb_user_conf mode use_cache path -- It's fine if the cache is not there as long as the -- database is empty. when (not $ null confs) $ do - warn ("WARNING: cache does not exist: " ++ cache) + warn ("WARNING: cache does not exist: " ++ showOsPath cache) warn ("ghc will fail to read this package db. " ++ recacheAdvice) else do @@ -923,7 +933,7 @@ readParseDatabase verbosity mb_user_conf mode use_cache path ignore_cache (const $ return ()) Right tcache -> do when (verbosity >= Verbose) $ do - warn ("Timestamp " ++ show tcache ++ " for " ++ cache) + warn ("Timestamp " ++ show tcache ++ " for " ++ showOsPath cache) -- If any of the .conf files is newer than package.cache, we -- assume that cache is out of date. cache_outdated <- (`anyM` confs) $ \conf -> @@ -931,12 +941,12 @@ readParseDatabase verbosity mb_user_conf mode use_cache path if not cache_outdated then do when (verbosity > Normal) $ - infoLn ("using cache: " ++ cache) + infoLn ("using cache: " ++ showOsPath cache) GhcPkg.readPackageDbForGhcPkg cache mode >>= uncurry mkPackageDB else do whenReportCacheErrors $ do - warn ("WARNING: cache is out of date: " ++ cache) + warn ("WARNING: cache is out of date: " ++ showOsPath cache) warn ("ghc will see an old view of this " ++ "package db. " ++ recacheAdvice) ignore_cache $ \file -> do @@ -947,11 +957,11 @@ readParseDatabase verbosity mb_user_conf mode use_cache path GT -> " (older than cache)" EQ -> " (same as cache)" warn ("Timestamp " ++ show tFile - ++ " for " ++ file ++ rel) + ++ " for " ++ showOsPath file ++ rel) where - confs = map (path ) $ filter (".conf" `isSuffixOf`) fs + confs = map (path ) $ filter (os ".conf" `OsPath.isExtensionOf`) fs - ignore_cache :: (FilePath -> IO ()) -> IO (PackageDB mode) + ignore_cache :: (OsPath -> IO ()) -> IO (PackageDB mode) ignore_cache checkTime = do -- If we're opening for modification, we need to acquire a -- lock even if we don't open the cache now, because we are @@ -987,17 +997,18 @@ readParseDatabase verbosity mb_user_conf mode use_cache path packages = pkgs } -parseSingletonPackageConf :: Verbosity -> FilePath -> IO InstalledPackageInfo +parseSingletonPackageConf :: Verbosity -> OsPath -> IO InstalledPackageInfo parseSingletonPackageConf verbosity file = do - when (verbosity > Normal) $ infoLn ("reading package config: " ++ file) - BS.readFile file >>= fmap fst . parsePackageInfo + when (verbosity > Normal) $ infoLn ("reading package config: " ++ showOsPath file) + FileIO.readFile file >>= fmap fst . parsePackageInfo . BS.toStrict + -cachefilename :: FilePath -cachefilename = "package.cache" +cachefilename :: OsPath +cachefilename = os "package.cache" mungePackageDBPaths :: FilePath -> PackageDB mode -> PackageDB mode mungePackageDBPaths top_dir db@PackageDB { packages = pkgs } = - db { packages = map (mungePackagePaths top_dir pkgroot) pkgs } + db { packages = map (mungePackagePaths top_dir (unsafeDecodeUtf pkgroot)) pkgs } where pkgroot = takeDirectory $ dropTrailingPathSeparator (locationAbsolute db) -- It so happens that for both styles of package db ("package.conf" @@ -1044,12 +1055,13 @@ mkMungePathUrl top_dir pkgroot = (munge_path, munge_url) | Just p' <- stripVarPrefix "$httptopdir" p = toUrlPath top_dir p' | otherwise = p + toUrlPath :: FilePath -> FilePath -> FilePath toUrlPath r p = "file:///" -- URLs always use posix style '/' separators: ++ FilePath.Posix.joinPath (r : -- We need to drop a leading "/" or "\\" -- if there is one: - dropWhile (all isPathSeparator) + dropWhile (all FilePath.isPathSeparator) (FilePath.splitDirectories p)) -- We could drop the separator here, and then use above. However, @@ -1057,7 +1069,7 @@ mkMungePathUrl top_dir pkgroot = (munge_path, munge_url) -- rather than letting FilePath change it to use \ as the separator stripVarPrefix var path = case stripPrefix var path of Just [] -> Just [] - Just cs@(c : _) | isPathSeparator c -> Just cs + Just cs@(c : _) | FilePath.isPathSeparator c -> Just cs _ -> Nothing -- ----------------------------------------------------------------------------- @@ -1074,18 +1086,18 @@ mkMungePathUrl top_dir pkgroot = (munge_path, munge_url) -- ghc itself also cooperates in this workaround -tryReadParseOldFileStyleDatabase :: Verbosity -> Maybe (FilePath, Bool) - -> GhcPkg.DbOpenMode mode t -> Bool -> FilePath +tryReadParseOldFileStyleDatabase :: Verbosity -> Maybe (OsPath, Bool) + -> GhcPkg.DbOpenMode mode t -> Bool -> OsPath -> IO (Maybe (PackageDB mode)) tryReadParseOldFileStyleDatabase verbosity mb_user_conf mode use_cache path = do -- assumes we've already established that path exists and is not a dir - content <- readFile path `catchIO` \_ -> return "" + content <- readUtf8File path `catchIO` \_ -> return "" if take 2 content == "[]" then do path_abs <- absolutePath path let path_dir = adjustOldDatabasePath path - warn $ "Warning: ignoring old file-style db and trying " ++ path_dir + warn $ "Warning: ignoring old file-style db and trying " ++ showOsPath path_dir direxists <- doesDirectoryExist path_dir if direxists then do @@ -1112,7 +1124,7 @@ tryReadParseOldFileStyleDatabase verbosity mb_user_conf adjustOldFileStylePackageDB :: PackageDB mode -> IO (PackageDB mode) adjustOldFileStylePackageDB db = do -- assumes we have not yet established if it's an old style or not - mcontent <- liftM Just (readFile (location db)) `catchIO` \_ -> return Nothing + mcontent <- liftM Just (readUtf8File (location db)) `catchIO` \_ -> return Nothing case fmap (take 2) mcontent of -- it is an old style and empty db, so look for a dir kind in location.d/ Just "[]" -> return db { @@ -1121,20 +1133,20 @@ adjustOldFileStylePackageDB db = do } -- it is old style but not empty, we have to bail Just _ -> die $ "ghc no longer supports single-file style package " - ++ "databases (" ++ location db ++ ") use 'ghc-pkg init'" + ++ "databases (" ++ showOsPath (location db) ++ ") use 'ghc-pkg init'" ++ "to create the database with the correct format." -- probably not old style, carry on as normal Nothing -> return db -adjustOldDatabasePath :: FilePath -> FilePath -adjustOldDatabasePath = (<.> "d") +adjustOldDatabasePath :: OsPath -> OsPath +adjustOldDatabasePath = (<.> os "d") -- ----------------------------------------------------------------------------- -- Creating a new package DB -initPackageDB :: FilePath -> Verbosity -> [Flag] -> IO () +initPackageDB :: OsPath -> Verbosity -> [Flag] -> IO () initPackageDB filename verbosity _flags = do - let eexist = die ("cannot create: " ++ filename ++ " already exists") + let eexist = die ("cannot create: " ++ showOsPath filename ++ " already exists") b1 <- doesFileExist filename when b1 eexist b2 <- doesDirectoryExist filename @@ -1183,7 +1195,8 @@ registerPackage input verbosity my_flags multi_instance f -> do when (verbosity >= Normal) $ info ("Reading package info from " ++ show f ++ " ... ") - readUTF8File f + fs <- encodeFS f + readUtf8File fs expanded <- if expand_env_vars then expandEnvVars s force else return s @@ -1199,7 +1212,11 @@ registerPackage input verbosity my_flags multi_instance -- validate the expanded pkg, but register the unexpanded pkgroot <- absolutePath (takeDirectory to_modify) let top_dir = takeDirectory (location (last db_stack)) - pkg_expanded = mungePackagePaths top_dir pkgroot pkg + + top_dir_filepath <- decodeFS top_dir + pkgroot_filepath <- decodeFS pkgroot + let + pkg_expanded = mungePackagePaths top_dir_filepath pkgroot_filepath pkg let truncated_stack = stackUpTo to_modify db_stack -- truncate the stack for validation, because we don't allow @@ -1274,13 +1291,13 @@ changeDBDir verbosity cmds db db_stack = do updateDBCache verbosity db db_stack where do_cmd (RemovePackage p) = do - let file = location db display (installedUnitId p) <.> "conf" - when (verbosity > Normal) $ infoLn ("removing " ++ file) + let file = location db unsafeEncodeUtf (display (installedUnitId p)) <.> os "conf" + when (verbosity > Normal) $ infoLn ("removing " ++ showOsPath file) removeFileSafe file do_cmd (AddPackage p) = do - let file = location db display (installedUnitId p) <.> "conf" - when (verbosity > Normal) $ infoLn ("writing " ++ file) - writeUTF8File file (showInstalledPackageInfo p) + let file = location db unsafeEncodeUtf (display (installedUnitId p)) <.> os "conf" + when (verbosity > Normal) $ infoLn ("writing " ++ showOsPath file) + writeUtf8File file (showInstalledPackageInfo p) do_cmd (ModifyPackage p) = do_cmd (AddPackage p) @@ -1338,13 +1355,13 @@ updateDBCache verbosity db db_stack = do warn $ " " ++ pkg when (verbosity > Normal) $ - infoLn ("writing cache " ++ filename) + infoLn ("writing cache " ++ showOsPath filename) let d = fmap (fromPackageCacheFormat . fst) pkgsGhcCacheFormat GhcPkg.writePackageDb filename d pkgsCabalFormat `catchIO` \e -> if isPermissionError e - then die $ filename ++ ": you don't have permission to modify this file" + then die $ showOsPath filename ++ ": you don't have permission to modify this file" else ioError e case packageDbLock db of @@ -1583,7 +1600,7 @@ listPackages verbosity my_flags mPackageName mModuleName = do broken = map installedUnitId (brokenPackages pkg_map) show_normal PackageDB{ location = db_name, packages = pkg_confs } = - do hPutStrLn stdout db_name + do hPutStrLn stdout (showOsPath db_name) if null pkg_confs then hPutStrLn stdout " (no packages)" else hPutStrLn stdout $ unlines (map (" " ++) (map pp_pkg pkg_confs)) @@ -1610,7 +1627,7 @@ listPackages verbosity my_flags mPackageName mModuleName = do #else let show_colour PackageDB{ location = db_name, packages = pkg_confs } = - do hPutStrLn stdout db_name + do hPutStrLn stdout (showOsPath db_name) if null pkg_confs then hPutStrLn stdout " (no packages)" else hPutStrLn stdout $ unlines (map (" " ++) (map pp_pkg pkg_confs)) @@ -1698,7 +1715,7 @@ dumpUnits verbosity my_flags expand_pkgroot = do doDump expand_pkgroot [ (pkg, locationAbsolute db) | db <- flag_db_stack, pkg <- packages db ] -doDump :: Bool -> [(InstalledPackageInfo, FilePath)] -> IO () +doDump :: Bool -> [(InstalledPackageInfo, OsPath)] -> IO () doDump expand_pkgroot pkgs = do -- fix the encoding to UTF-8, since this is an interchange format hSetEncoding stdout utf8 @@ -1731,7 +1748,7 @@ findPackagesByDB db_stack pkgarg cannotFindPackage :: PackageArg -> Maybe (PackageDB mode) -> IO a cannotFindPackage pkgarg mdb = die $ "cannot find package " ++ pkg_msg pkgarg - ++ maybe "" (\db -> " in " ++ location db) mdb + ++ maybe "" (\db -> " in " ++ showOsPath (location db)) mdb where pkg_msg (Id pkgid) = displayGlobPkgId pkgid pkg_msg (IUId ipid) = display ipid @@ -1944,7 +1961,7 @@ checkPackageConfig pkg verbosity db_stack checkExposedModules db_stack pkg checkOtherModules pkg let has_code = Set.null (openModuleSubstFreeHoles (Map.fromList (instantiatedWith pkg))) - when has_code $ mapM_ (checkHSLib verbosity (libraryDirs pkg ++ libraryDynDirs pkg)) (hsLibraries pkg) + when has_code $ mapM_ (checkHSLib verbosity (fmap unsafeEncodeUtf $ libraryDirs pkg ++ libraryDynDirs pkg)) (hsLibraries pkg) -- ToDo: check these somehow? -- extra_libraries :: [String], -- c_includes :: [String], @@ -2011,20 +2028,20 @@ checkPath url_ok is_dir warn_only thisfield d || "https://" `isPrefixOf` d) = return () | url_ok - , Just d' <- stripPrefix "file://" d - = checkPath False is_dir warn_only thisfield d' + , Just f <- stripPrefix "file://" d + = checkPath False is_dir warn_only thisfield f -- Note: we don't check for $topdir/${pkgroot} here. We rely on these -- variables having been expanded already, see mungePackagePaths. - | isRelative d = verror ForceFiles $ + | isRelative d' = verror ForceFiles $ thisfield ++ ": " ++ d ++ " is a relative path which " ++ "makes no sense (as there is nothing for it to be " ++ "relative to). You can make paths relative to the " ++ "package database itself by using ${pkgroot}." -- relative paths don't make any sense; #4134 | otherwise = do - there <- liftIO $ if is_dir then doesDirectoryExist d else doesFileExist d + there <- liftIO $ if is_dir then doesDirectoryExist d' else doesFileExist d' when (not there) $ let msg = thisfield ++ ": " ++ d ++ " doesn't exist or isn't a " ++ if is_dir then "directory" else "file" @@ -2032,6 +2049,8 @@ checkPath url_ok is_dir warn_only thisfield d if warn_only then vwarn msg else verror ForceFiles msg + where + d' = unsafeEncodeUtf d checkDep :: PackageDBStack -> UnitId -> Validate () checkDep db_stack pkgid @@ -2050,24 +2069,25 @@ checkDuplicateDepends deps where dups = [ p | (p:_:_) <- group (sort deps) ] -checkHSLib :: Verbosity -> [String] -> String -> Validate () +checkHSLib :: Verbosity -> [OsPath] -> String -> Validate () checkHSLib _verbosity dirs lib = do - let filenames = ["lib" ++ lib ++ ".a", - "lib" ++ lib ++ "_p.a", - "lib" ++ lib ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".so", - "lib" ++ lib ++ "_p" ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".so", - "lib" ++ lib ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".dylib", - "lib" ++ lib ++ "_p" ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".dylib", - lib ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".dll", - lib ++ "_p" ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".dll", - lib ++ ".bytecodelib" - ] + let filenames = fmap OsPath.unsafeEncodeUtf + [ "lib" ++ lib ++ ".a" + , "lib" ++ lib ++ "_p.a" + , "lib" ++ lib ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".so" + , "lib" ++ lib ++ "_p" ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".so" + , "lib" ++ lib ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".dylib" + , "lib" ++ lib ++ "_p" ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".dylib" + , lib ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".dll" + , lib ++ "_p" ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".dll" + , lib ++ ".bytecodelib" + ] b <- liftIO $ doesFileExistOnPath filenames dirs when (not b) $ verror ForceFiles ("cannot find any of " ++ show filenames ++ " on library path") -doesFileExistOnPath :: [FilePath] -> [FilePath] -> IO Bool +doesFileExistOnPath :: [OsPath] -> [OsPath] -> IO Bool doesFileExistOnPath filenames paths = anyM doesFileExist fullFilenames where fullFilenames = [ path filename | filename <- filenames @@ -2096,9 +2116,9 @@ checkModuleFile :: InstalledPackageInfo -> ModuleName -> Validate () checkModuleFile pkg modl = -- there's no interface file for GHC.Prim unless (modl == ModuleName.fromString "GHC.Prim") $ do - let files = [ ModuleName.toFilePath modl <.> extension - | extension <- ["hi", "p_hi", "dyn_hi", "p_dyn_hi"] ] - b <- liftIO $ doesFileExistOnPath files (importDirs pkg) + let files = [ unsafeEncodeUtf (ModuleName.toFilePath modl) <.> extension + | extension <- fmap os ["hi", "p_hi", "dyn_hi", "p_dyn_hi"] ] + b <- liftIO $ doesFileExistOnPath files (fmap unsafeEncodeUtf $ importDirs pkg) when (not b) $ verror ForceFiles ("cannot find any of " ++ show files) @@ -2273,19 +2293,45 @@ installSignalHandlers = do return () #endif +-- ------------------------------------------------ +-- OsPath Utils + +-- | Show an 'OsPath', throwing an exception if we fail to decode it. +showOsPath :: HasCallStack => OsPath -> FilePath +showOsPath = unsafePerformIO . decodeFS + +-- | Turn a path relative to the current directory into a (normalised) +-- absolute path. +absolutePath :: OsPath -> IO OsPath +absolutePath path = return . normalise . ( path) =<< getCurrentDirectory + +-- ------------------------------------------------ + catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a catchIO = catchException tryIO :: IO a -> IO (Either Exception.IOException a) tryIO = Exception.try --- removeFileSave doesn't throw an exceptions, if the file is already deleted -removeFileSafe :: FilePath -> IO () +----------------------------------------- +-- Adapted from ghc/compiler/utils/Panic + +-- | 'removeFileSave' doesn't throw an exceptions, if the file is already deleted +removeFileSafe :: OsPath -> IO () removeFileSafe fn = removeFile fn `catchIO` \ e -> when (not $ isDoesNotExistError e) $ ioError e --- | Turn a path relative to the current directory into a (normalised) --- absolute path. -absolutePath :: FilePath -> IO FilePath -absolutePath path = return . normalise . ( path) =<< getCurrentDirectory +-- | Read a file using UTF-8 encoding +-- +-- Taken from https://github.com/haskell/cabal/blob/cea1d8ff1a80df3c3b3148d1556bd3edf656da... +-- and adapted to 'OsPath'. +writeUtf8File :: OsPath -> String -> IO () +writeUtf8File file contents = writeFileAtomic file (toUTF8LBS contents) + +-- | Read a file and interpret its content to be UTF-8 encoded. +-- +-- Taken from https://github.com/haskell/cabal/blob/cea1d8ff1a80df3c3b3148d1556bd3edf656da... +-- and adapted to 'OsPath'. +readUtf8File :: OsPath -> IO String +readUtf8File file = (ignoreBOM . fromUTF8LBS) <$> FileIO.readFile file ===================================== utils/ghc-pkg/ghc-pkg.cabal.in ===================================== @@ -25,6 +25,7 @@ Executable ghc-pkg process >= 1 && < 1.7, containers, filepath, + file-io, Cabal, Cabal-syntax, binary, View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7666f4a981eda798e4fbe88e97db8f36... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7666f4a981eda798e4fbe88e97db8f36... You're receiving this email because of your account on gitlab.haskell.org.