From 54ad1b4cfb1c8302f1b862cb2699ab9351e3eb5b Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 1 Mar 2023 15:55:58 -0400 Subject: [PATCH] Windows: Support long filenames in more (possibly all) of the code Works around this bug in unix-compat: https://github.com/jacobstanley/unix-compat/issues/56 getFileStatus and other FilePath using functions in unix-compat do not do UNC conversion on Windows. Made Utility.RawFilePath use convertToWindowsNativeNamespace to do the necessary conversion on windows to support long filenames. Audited all imports of System.PosixCompat.Files to make sure that no functions that operate on FilePath were imported from it. Instead, use the equvilants from Utility.RawFilePath. In particular the re-export of that module in Common had to be removed, which led to lots of other changes throughout the code. The changes to Build.Configure, Build.DesktopFile, and Build.TestConfig make Utility.Directory not be needed to build setup. And so let it use Utility.RawFilePath, which depends on unix, which cannot be in setup-depends. Sponsored-by: Dartmouth College's Datalad project --- Annex/AutoMerge.hs | 1 + Annex/Content.hs | 1 + Annex/Content/LowLevel.hs | 1 + Annex/Content/PointerFile.hs | 7 ++-- Annex/CopyFile.hs | 6 ++- Annex/Ingest.hs | 9 +++-- Annex/Init.hs | 5 ++- Annex/Link.hs | 1 + Annex/Perms.hs | 2 + Annex/Tmp.hs | 3 +- Assistant/Install.hs | 2 + Assistant/Threads/Committer.hs | 8 ++-- Assistant/Threads/SanityChecker.hs | 6 +-- Assistant/Threads/Watcher.hs | 3 +- Assistant/Upgrade.hs | 2 +- Assistant/WebApp/Configurators/Local.hs | 3 +- Backend/WORM.hs | 3 +- Build/Configure.hs | 2 +- Build/DesktopFile.hs | 2 +- Build/TestConfig.hs | 2 +- CHANGELOG | 1 + CmdLine/Seek.hs | 10 +++-- Command/Add.hs | 2 +- Command/Fix.hs | 3 +- Command/Fsck.hs | 1 + Command/FuzzTest.hs | 2 +- Command/Import.hs | 1 + Command/ImportFeed.hs | 3 +- Command/Info.hs | 6 ++- Command/Lock.hs | 2 + Command/ReKey.hs | 2 + Command/Unannex.hs | 2 + Command/Uninit.hs | 2 + Command/Unlock.hs | 2 + Common.hs | 2 +- Git/Hook.hs | 5 ++- Limit.hs | 3 +- P2P/Address.hs | 7 +++- P2P/IO.hs | 1 + Remote/Ddar.hs | 4 +- Remote/Directory.hs | 5 ++- Remote/Git.hs | 2 +- Remote/Helper/Git.hs | 4 +- Test.hs | 8 ++-- Test/Framework.hs | 14 ++++--- Upgrade/V0.hs | 6 ++- Upgrade/V1.hs | 9 +++-- Upgrade/V7.hs | 3 +- Utility/DirWatcher/INotify.hs | 7 ++-- Utility/DirWatcher/Win32Notify.hs | 4 +- Utility/Directory.hs | 10 +++-- Utility/InodeCache.hs | 1 + Utility/QuickCheck.hs | 1 + Utility/RawFilePath.hs | 53 +++++++++++++++++++------ Utility/SshConfig.hs | 1 + Utility/Tmp.hs | 7 ++-- Utility/Tor.hs | 4 +- 57 files changed, 185 insertions(+), 84 deletions(-) diff --git a/Annex/AutoMerge.hs b/Annex/AutoMerge.hs index f4f95ff441..77afe521c9 100644 --- a/Annex/AutoMerge.hs +++ b/Annex/AutoMerge.hs @@ -39,6 +39,7 @@ import qualified Utility.RawFilePath as R import qualified Data.Set as S import qualified Data.Map as M import qualified Data.ByteString.Lazy as L +import System.PosixCompat.Files (isSymbolicLink) {- Merges from a branch into the current branch (which may not exist yet), - with automatic merge conflict resolution. diff --git a/Annex/Content.hs b/Annex/Content.hs index 589df43215..0090703047 100644 --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -104,6 +104,7 @@ import Utility.Metered import qualified Utility.RawFilePath as R import qualified System.FilePath.ByteString as P +import System.PosixCompat.Files (isSymbolicLink, linkCount) {- Prevents the content from being removed while the action is running. - Uses a shared lock. diff --git a/Annex/Content/LowLevel.hs b/Annex/Content/LowLevel.hs index 0271fa65de..947acabb1b 100644 --- a/Annex/Content/LowLevel.hs +++ b/Annex/Content/LowLevel.hs @@ -19,6 +19,7 @@ import Utility.CopyFile import qualified Utility.RawFilePath as R import qualified System.FilePath.ByteString as P +import System.PosixCompat.Files (linkCount) {- Runs the secure erase command if set, otherwise does nothing. - File may or may not be deleted at the end; caller is responsible for diff --git a/Annex/Content/PointerFile.hs b/Annex/Content/PointerFile.hs index 6c1ab8fd3b..7fc4be5327 100644 --- a/Annex/Content/PointerFile.hs +++ b/Annex/Content/PointerFile.hs @@ -22,6 +22,8 @@ import Utility.Touch import qualified System.Posix.Files as Posix #endif +import System.PosixCompat.Files (fileMode) + {- Populates a pointer file with the content of a key. - - If the file already has some other content, it is not modified. @@ -53,12 +55,11 @@ populatePointerFile restage k obj f = go =<< liftIO (isPointerFile f) - Does not check if the pointer file is modified. -} depopulatePointerFile :: Key -> RawFilePath -> Annex () depopulatePointerFile key file = do - let file' = fromRawFilePath file - st <- liftIO $ catchMaybeIO $ getFileStatus file' + st <- liftIO $ catchMaybeIO $ R.getFileStatus file let mode = fmap fileMode st secureErase file liftIO $ removeWhenExistsWith R.removeLink file - ic <- replaceWorkTreeFile file' $ \tmp -> do + ic <- replaceWorkTreeFile (fromRawFilePath file) $ \tmp -> do let tmp' = toRawFilePath tmp liftIO $ writePointerFile tmp' key mode #if ! defined(mingw32_HOST_OS) diff --git a/Annex/CopyFile.hs b/Annex/CopyFile.hs index 93ab346c7b..8fa84bddcb 100644 --- a/Annex/CopyFile.hs +++ b/Annex/CopyFile.hs @@ -15,10 +15,12 @@ import Utility.CopyFile import Utility.FileMode import Utility.Touch import Utility.Hash (IncrementalVerifier(..)) +import qualified Utility.RawFilePath as R import Control.Concurrent import qualified Data.ByteString as S import Data.Time.Clock.POSIX +import System.PosixCompat.Files (fileMode) -- To avoid the overhead of trying copy-on-write every time, it's tried -- once and if it fails, is not tried again. @@ -101,9 +103,9 @@ fileCopier copycowtried src dest meterupdate iv = fileContentCopier hsrc dest meterupdate iv -- Copy src mode and mtime. - mode <- fileMode <$> getFileStatus src + mode <- fileMode <$> R.getFileStatus (toRawFilePath src) mtime <- utcTimeToPOSIXSeconds <$> getModificationTime src - setFileMode dest mode + R.setFileMode dest' mode touch dest' mtime False return Copied diff --git a/Annex/Ingest.hs b/Annex/Ingest.hs index 89dc8aceaa..1dcbb2f6a6 100644 --- a/Annex/Ingest.hs +++ b/Annex/Ingest.hs @@ -51,6 +51,8 @@ import Annex.AdjustedBranch import Annex.FileMatcher import qualified Utility.RawFilePath as R +import System.PosixCompat.Files (fileMode) + data LockedDown = LockedDown { lockDownConfig :: LockDownConfig , keySource :: KeySource @@ -120,11 +122,12 @@ lockDown' cfg file = tryNonAsync $ ifM crippledFileSystem `catchIO` const (nohardlink' delta) withhardlink' delta tmpfile = do - createLink file tmpfile - cache <- genInodeCache (toRawFilePath tmpfile) delta + let tmpfile' = toRawFilePath tmpfile + R.createLink file' tmpfile' + cache <- genInodeCache tmpfile' delta return $ LockedDown cfg $ KeySource { keyFilename = file' - , contentLocation = toRawFilePath tmpfile + , contentLocation = tmpfile' , inodeCache = cache } diff --git a/Annex/Init.hs b/Annex/Init.hs index 8b86572bec..b152f46aa5 100644 --- a/Annex/Init.hs +++ b/Annex/Init.hs @@ -62,6 +62,7 @@ import qualified Utility.LockFile.Posix as Posix import qualified Data.Map as M import Control.Monad.IO.Class (MonadIO) +import System.PosixCompat.Files (ownerReadMode, isNamedPipe) #ifndef mingw32_HOST_OS import Data.Either import qualified System.FilePath.ByteString as P @@ -296,7 +297,7 @@ probeCrippledFileSystem' tmp freezecontent thawcontent hasfreezehook = do probe f = catchDefaultIO (True, []) $ do let f2 = f ++ "2" liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f2) - liftIO $ createSymbolicLink f f2 + liftIO $ R.createSymbolicLink (toRawFilePath f) (toRawFilePath f2) liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f2) (fromMaybe (liftIO . preventWrite) freezecontent) (toRawFilePath f) -- Should be unable to write to the file (unless @@ -372,7 +373,7 @@ probeFifoSupport = do removeWhenExistsWith R.removeLink f removeWhenExistsWith R.removeLink f2 ms <- tryIO $ do - createNamedPipe (fromRawFilePath f) ownerReadMode + R.createNamedPipe f ownerReadMode R.createLink f f2 R.getFileStatus f removeWhenExistsWith R.removeLink f diff --git a/Annex/Link.hs b/Annex/Link.hs index ad2ce15478..9c75a8b728 100644 --- a/Annex/Link.hs +++ b/Annex/Link.hs @@ -43,6 +43,7 @@ import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import qualified System.FilePath.ByteString as P +import System.PosixCompat.Files (isSymbolicLink) type LinkTarget = S.ByteString diff --git a/Annex/Perms.hs b/Annex/Perms.hs index e6ed48a4d0..ce8c835fcc 100644 --- a/Annex/Perms.hs +++ b/Annex/Perms.hs @@ -44,6 +44,8 @@ import Config import Utility.Directory.Create import qualified Utility.RawFilePath as R +import System.PosixCompat.Files (fileMode, intersectFileModes, nullFileMode, groupWriteMode, ownerWriteMode, ownerReadMode, groupReadMode, stdFileMode, ownerExecuteMode, groupExecuteMode) + withShared :: (SharedRepository -> Annex a) -> Annex a withShared a = a =<< coreSharedRepository <$> Annex.getGitConfig diff --git a/Annex/Tmp.hs b/Annex/Tmp.hs index f602f56805..5293deea29 100644 --- a/Annex/Tmp.hs +++ b/Annex/Tmp.hs @@ -15,6 +15,7 @@ import Types.CleanupActions import qualified Utility.RawFilePath as R import Data.Time.Clock.POSIX +import System.PosixCompat.Files (modificationTime) -- | For creation of tmp files, other than for key's contents. -- @@ -66,7 +67,7 @@ cleanupOtherTmp = do cleanold f = do now <- liftIO getPOSIXTime let oldenough = now - (60 * 60 * 24 * 7) - catchMaybeIO (modificationTime <$> getSymbolicLinkStatus f) >>= \case + catchMaybeIO (modificationTime <$> R.getSymbolicLinkStatus (toRawFilePath f)) >>= \case Just mtime | realToFrac mtime <= oldenough -> void $ tryIO $ removeWhenExistsWith R.removeLink (toRawFilePath f) _ -> return () diff --git a/Assistant/Install.hs b/Assistant/Install.hs index 6a31968d7b..c11b6d5585 100644 --- a/Assistant/Install.hs +++ b/Assistant/Install.hs @@ -27,6 +27,8 @@ import Utility.UserInfo import Utility.Android #endif +import System.PosixCompat.Files (ownerExecuteMode) + standaloneAppBase :: IO (Maybe FilePath) standaloneAppBase = getEnv "GIT_ANNEX_APP_BASE" diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs index 7b06e7d762..2e9a25c111 100644 --- a/Assistant/Threads/Committer.hs +++ b/Assistant/Threads/Committer.hs @@ -40,12 +40,14 @@ import qualified Database.Keys import qualified Command.Sync import Utility.Tuple import Utility.Metered +import qualified Utility.RawFilePath as R import Data.Time.Clock import qualified Data.Set as S import qualified Data.Map as M import Data.Either import Control.Concurrent +import System.PosixCompat.Files (fileID, deviceID, fileMode) {- This thread makes git commits at appropriate times. -} commitThread :: NamedThread @@ -358,7 +360,7 @@ handleAdds lockdowndir havelsof largefilematcher delayadd cs = returnWhen (null done change file key = liftAnnex $ do logStatus key InfoPresent - mode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus file + mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus (toRawFilePath file) stagePointerFile (toRawFilePath file) mode =<< hashPointerFile key showEndOk return $ Just $ finishedChange change key @@ -367,8 +369,8 @@ handleAdds lockdowndir havelsof largefilematcher delayadd cs = returnWhen (null - and is still a hard link to its contentLocation, - before ingesting it. -} sanitycheck keysource a = do - fs <- liftIO $ getSymbolicLinkStatus $ fromRawFilePath $ keyFilename keysource - ks <- liftIO $ getSymbolicLinkStatus $ fromRawFilePath $ contentLocation keysource + fs <- liftIO $ R.getSymbolicLinkStatus $ keyFilename keysource + ks <- liftIO $ R.getSymbolicLinkStatus $ contentLocation keysource if deviceID ks == deviceID fs && fileID ks == fileID fs then a else do diff --git a/Assistant/Threads/SanityChecker.hs b/Assistant/Threads/SanityChecker.hs index 34f46c8003..87587e227f 100644 --- a/Assistant/Threads/SanityChecker.hs +++ b/Assistant/Threads/SanityChecker.hs @@ -53,6 +53,7 @@ import Utility.DiskFree import Data.Time.Clock.POSIX import qualified Data.Text as T +import System.PosixCompat.Files (statusChangeTime, isSymbolicLink) {- This thread runs once at startup, and most other threads wait for it - to finish. (However, the webapp thread does not, to prevent the UI @@ -156,11 +157,10 @@ dailyCheck urlrenderer = do (unstaged, cleanup) <- liftIO $ Git.LsFiles.notInRepo [] False ["."] g now <- liftIO getPOSIXTime forM_ unstaged $ \file -> do - let file' = fromRawFilePath file - ms <- liftIO $ catchMaybeIO $ getSymbolicLinkStatus file' + ms <- liftIO $ catchMaybeIO $ R.getSymbolicLinkStatus file case ms of Just s | toonew (statusChangeTime s) now -> noop - | isSymbolicLink s -> addsymlink file' ms + | isSymbolicLink s -> addsymlink (fromRawFilePath file) ms _ -> noop liftIO $ void cleanup diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs index bbc4fa31c5..540ac5c6c5 100644 --- a/Assistant/Threads/Watcher.hs +++ b/Assistant/Threads/Watcher.hs @@ -51,6 +51,7 @@ import Data.Typeable import qualified Data.ByteString.Lazy as L import qualified Control.Exception as E import Data.Time.Clock +import System.PosixCompat.Files (fileMode, statusChangeTime) checkCanWatch :: Annex () checkCanWatch @@ -218,7 +219,7 @@ onAddFile symlinkssupported f fs = do unlessM (inAnnex oldkey) $ logStatus oldkey InfoMissing addlink file key = do - mode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus file + mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus (toRawFilePath file) liftAnnex $ stagePointerFile (toRawFilePath file) mode =<< hashPointerFile key madeChange file $ LinkChange (Just key) diff --git a/Assistant/Upgrade.hs b/Assistant/Upgrade.hs index 7ef410e452..5b8a49ebf6 100644 --- a/Assistant/Upgrade.hs +++ b/Assistant/Upgrade.hs @@ -222,7 +222,7 @@ upgradeToDistribution newdir cleanup distributionfile = do makeorigsymlink olddir = do let origdir = fromRawFilePath (parentDir (toRawFilePath olddir)) installBase removeWhenExistsWith R.removeLink (toRawFilePath origdir) - createSymbolicLink newdir origdir + R.createSymbolicLink (toRawFilePath newdir) (toRawFilePath origdir) {- Finds where the old version was installed. -} oldVersionLocation :: IO FilePath diff --git a/Assistant/WebApp/Configurators/Local.hs b/Assistant/WebApp/Configurators/Local.hs index cbbe2eac90..a5d400bfb6 100644 --- a/Assistant/WebApp/Configurators/Local.hs +++ b/Assistant/WebApp/Configurators/Local.hs @@ -40,6 +40,7 @@ import qualified Remote.GCrypt as GCrypt import qualified Types.Remote import Utility.Android import Types.ProposedAccepted +import qualified Utility.RawFilePath as R import qualified Data.Text as T import qualified Data.Map as M @@ -421,7 +422,7 @@ canWrite dir = do ( return dir , return $ fromRawFilePath $ parentDir $ toRawFilePath dir ) - catchBoolIO $ fileAccess tocheck False True False + catchBoolIO $ R.fileAccess (toRawFilePath tocheck) False True False {- Gets the UUID of the git repo at a location, which may not exist, or - not be a git-annex repo. -} diff --git a/Backend/WORM.hs b/Backend/WORM.hs index 233ca92e68..771a490e48 100644 --- a/Backend/WORM.hs +++ b/Backend/WORM.hs @@ -14,10 +14,11 @@ import Types.KeySource import Backend.Utilities import Git.FilePath import Utility.Metered +import qualified Utility.RawFilePath as R import qualified Data.ByteString.Char8 as S8 -import qualified Utility.RawFilePath as R import qualified Data.ByteString.Short as S (toShort, fromShort) +import System.PosixCompat.Files (modificationTime) backends :: [Backend] backends = [backend] diff --git a/Build/Configure.hs b/Build/Configure.hs index 02e33ebf2a..cce9488bae 100644 --- a/Build/Configure.hs +++ b/Build/Configure.hs @@ -10,7 +10,7 @@ import Build.Version import Utility.SafeCommand import Utility.Env.Basic import qualified Git.Version -import Utility.Directory +import Utility.SystemDirectory import Control.Monad import Control.Applicative diff --git a/Build/DesktopFile.hs b/Build/DesktopFile.hs index a4c4944ade..5c1b72c021 100644 --- a/Build/DesktopFile.hs +++ b/Build/DesktopFile.hs @@ -15,7 +15,7 @@ import Utility.Exception import Utility.FreeDesktop import Utility.Path import Utility.Monad -import Utility.Directory +import Utility.SystemDirectory import Utility.FileSystemEncoding import Config.Files import Utility.OSX diff --git a/Build/TestConfig.hs b/Build/TestConfig.hs index 988db58a9a..5458612d4c 100644 --- a/Build/TestConfig.hs +++ b/Build/TestConfig.hs @@ -7,7 +7,7 @@ module Build.TestConfig where import Utility.Path import Utility.Monad import Utility.SafeCommand -import Utility.Directory +import Utility.SystemDirectory import System.IO import System.FilePath diff --git a/CHANGELOG b/CHANGELOG index 443ab2c962..2f0c8fc3cf 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -4,6 +4,7 @@ git-annex (10.20230228) UNRELEASED; urgency=medium view branch, will enter an adjusted view branch. * status: This command is deprecated because it was only needed in direct mode; git status --short is very similar. + * Windows: Support long filenames in more (possibly all) of the code. -- Joey Hess Mon, 27 Feb 2023 12:31:14 -0400 diff --git a/CmdLine/Seek.hs b/CmdLine/Seek.hs index 4b9776a01b..ab557d42ab 100644 --- a/CmdLine/Seek.hs +++ b/CmdLine/Seek.hs @@ -52,6 +52,7 @@ import Control.Concurrent.STM import System.Posix.Types import Data.IORef import Data.Time.Clock.POSIX +import System.PosixCompat.Files (isDirectory, isSymbolicLink, deviceID, fileID) import qualified System.FilePath.ByteString as P data AnnexedFileSeeker = AnnexedFileSeeker @@ -114,7 +115,7 @@ withPathContents a params = do -- fail if the path that the user provided is a broken symlink, -- the same as it fails if the path that the user provided does not -- exist. - get p = ifM (isDirectory <$> getFileStatus p) + get p = ifM (isDirectory <$> R.getFileStatus p') ( map (\f -> let f' = toRawFilePath f in (f', P.makeRelative (P.takeDirectory (P.dropTrailingPathSeparator p')) f')) @@ -562,8 +563,9 @@ workTreeItems' (AllowHidden allowhidden) ww ps = case ww of currbranch <- getCurrentBranch stopattop <- prepviasymlink ps' <- flip filterM ps $ \p -> do - relf <- liftIO $ relPathCwdToFile $ toRawFilePath p - ifM (not <$> (exists p <||> hidden currbranch relf)) + let p' = toRawFilePath p + relf <- liftIO $ relPathCwdToFile p' + ifM (not <$> (exists p' <||> hidden currbranch relf)) ( prob (p ++ " not found") , ifM (viasymlink stopattop (upFrom relf)) ( prob (p ++ " is beyond a symbolic link") @@ -574,7 +576,7 @@ workTreeItems' (AllowHidden allowhidden) ww ps = case ww of then return NoWorkTreeItems else return (WorkTreeItems ps') - exists p = isJust <$> liftIO (catchMaybeIO $ getSymbolicLinkStatus p) + exists p = isJust <$> liftIO (catchMaybeIO $ R.getSymbolicLinkStatus p) prepviasymlink = do repotopst <- inRepo $ diff --git a/Command/Add.hs b/Command/Add.hs index 20ec77ae82..aaf0c91b73 100644 --- a/Command/Add.hs +++ b/Command/Add.hs @@ -31,7 +31,7 @@ import Annex.CheckIgnore import qualified Utility.RawFilePath as R import qualified System.FilePath.ByteString as P -import System.PosixCompat.Files (fileSize) +import System.PosixCompat.Files (fileSize, isSymbolicLink, isRegularFile, modificationTime, fileID, deviceID, fileMode, ownerExecuteMode, intersectFileModes) cmd :: Command cmd = notBareRepo $ diff --git a/Command/Fix.hs b/Command/Fix.hs index 39853c8942..83f0515f01 100644 --- a/Command/Fix.hs +++ b/Command/Fix.hs @@ -19,9 +19,10 @@ import Annex.Link import qualified Database.Keys import qualified Utility.RawFilePath as R +import System.PosixCompat.Files (fileMode, linkCount) #if ! defined(mingw32_HOST_OS) -import Utility.Touch import qualified System.Posix.Files as Posix +import Utility.Touch #endif cmd :: Command diff --git a/Command/Fsck.hs b/Command/Fsck.hs index 77929f14ba..e0b357fcbc 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -49,6 +49,7 @@ import qualified Data.Set as S import qualified Data.Map as M import Data.Either import qualified System.FilePath.ByteString as P +import System.PosixCompat.Files (fileMode, isSymbolicLink, modificationTime) cmd :: Command cmd = withAnnexOptions [jobsOption, jsonOptions, annexedMatchingOptions] $ diff --git a/Command/FuzzTest.hs b/Command/FuzzTest.hs index f12f461191..4fadffce30 100644 --- a/Command/FuzzTest.hs +++ b/Command/FuzzTest.hs @@ -274,4 +274,4 @@ newDir parent = go (100 :: Int) ) doesnotexist :: FilePath -> IO Bool -doesnotexist f = isNothing <$> catchMaybeIO (getSymbolicLinkStatus f) +doesnotexist f = isNothing <$> catchMaybeIO (R.getSymbolicLinkStatus (toRawFilePath f)) diff --git a/Command/Import.hs b/Command/Import.hs index b24bbcfd5f..634365c69f 100644 --- a/Command/Import.hs +++ b/Command/Import.hs @@ -37,6 +37,7 @@ import Utility.Metered import qualified Utility.RawFilePath as R import Control.Concurrent.STM +import System.PosixCompat.Files (isDirectory, isSymbolicLink, isRegularFile) cmd :: Command cmd = notBareRepo $ diff --git a/Command/ImportFeed.hs b/Command/ImportFeed.hs index b6ee11be9e..a2a6284eb3 100644 --- a/Command/ImportFeed.hs +++ b/Command/ImportFeed.hs @@ -50,6 +50,7 @@ import Command.AddUrl (addWorkTree, checkRaw) import Annex.UntrustedFilePath import qualified Annex.Branch import Logs +import qualified Utility.RawFilePath as R cmd :: Command cmd = notBareRepo $ withAnnexOptions [backendOption] $ @@ -312,7 +313,7 @@ performDownload' started addunlockedmatcher opts cache todownload = case locatio let (d, base) = splitFileName file in d show n ++ "_" ++ base tryanother = makeunique url (n + 1) file - alreadyexists = liftIO $ isJust <$> catchMaybeIO (getSymbolicLinkStatus f) + alreadyexists = liftIO $ isJust <$> catchMaybeIO (R.getSymbolicLinkStatus (toRawFilePath f)) checksameurl k = ifM (elem url <$> getUrls k) ( return Nothing , tryanother diff --git a/Command/Info.hs b/Command/Info.hs index 042b9d656b..3d0cc83859 100644 --- a/Command/Info.hs +++ b/Command/Info.hs @@ -13,6 +13,7 @@ import "mtl" Control.Monad.State.Strict import qualified Data.Map.Strict as M import qualified Data.Vector as V import qualified System.FilePath.ByteString as P +import System.PosixCompat.Files (isDirectory) import Data.Ord import qualified Data.Semigroup as Sem import Prelude @@ -47,6 +48,7 @@ import qualified Limit import Messages.JSON (DualDisp(..), ObjectMap(..)) import Annex.BloomFilter import qualified Command.Unused +import qualified Utility.RawFilePath as R -- a named computation that produces a statistic type Stat = StatState (Maybe (String, StatState String)) @@ -163,7 +165,7 @@ autoenableInfo = showCustom "info" (SeekInput []) $ do return True itemInfo :: InfoOptions -> (SeekInput, String) -> Annex () -itemInfo o (si, p) = ifM (isdir p) +itemInfo o (si, p) = ifM (isdir (toRawFilePath p)) ( dirInfo o p si , Remote.byName' p >>= \case Right r -> remoteInfo o r si @@ -177,7 +179,7 @@ itemInfo o (si, p) = ifM (isdir p) (_us, msg) -> noInfo p si msg ) where - isdir = liftIO . catchBoolIO . (isDirectory <$$> getFileStatus) + isdir = liftIO . catchBoolIO . (isDirectory <$$> R.getFileStatus) noInfo :: String -> SeekInput -> String -> Annex () noInfo s si msg = do diff --git a/Command/Lock.hs b/Command/Lock.hs index d3eb7d3ff6..352abb3745 100644 --- a/Command/Lock.hs +++ b/Command/Lock.hs @@ -20,6 +20,8 @@ import Annex.Ingest import Logs.Location import Git.FilePath import qualified Utility.RawFilePath as R + +import System.PosixCompat.Files (linkCount) cmd :: Command cmd = withAnnexOptions [jsonOptions, annexedMatchingOptions] $ diff --git a/Command/ReKey.hs b/Command/ReKey.hs index 91d0804222..63a081c743 100644 --- a/Command/ReKey.hs +++ b/Command/ReKey.hs @@ -20,6 +20,8 @@ import Annex.WorkTree import Utility.InodeCache import qualified Utility.RawFilePath as R +import System.PosixCompat.Files (linkCount, fileMode) + cmd :: Command cmd = command "rekey" SectionPlumbing "change keys used for files" diff --git a/Command/Unannex.hs b/Command/Unannex.hs index 0d990da074..d876f79b06 100644 --- a/Command/Unannex.hs +++ b/Command/Unannex.hs @@ -19,6 +19,8 @@ import Annex.InodeSentinal import Git.FilePath import qualified Utility.RawFilePath as R +import System.PosixCompat.Files (linkCount) + cmd :: Command cmd = withAnnexOptions [annexedMatchingOptions] $ command "unannex" SectionUtility diff --git a/Command/Uninit.hs b/Command/Uninit.hs index d8cba0c4df..57057e58f4 100644 --- a/Command/Uninit.hs +++ b/Command/Uninit.hs @@ -22,6 +22,8 @@ import Annex.WorkTree import Utility.FileMode import qualified Utility.RawFilePath as R +import System.PosixCompat.Files (linkCount) + cmd :: Command cmd = addCheck check $ command "uninit" SectionUtility diff --git a/Command/Unlock.hs b/Command/Unlock.hs index 7f76fdb033..b165025b43 100644 --- a/Command/Unlock.hs +++ b/Command/Unlock.hs @@ -18,6 +18,8 @@ import Git.FilePath import qualified Database.Keys import qualified Utility.RawFilePath as R +import System.PosixCompat.Files (fileMode) + cmd :: Command cmd = mkcmd "unlock" "unlock files for modification" diff --git a/Common.hs b/Common.hs index 81be976210..c430163063 100644 --- a/Common.hs +++ b/Common.hs @@ -13,7 +13,7 @@ import Data.Default as X import System.FilePath as X import System.IO as X hiding (FilePath) import System.Exit as X -import System.PosixCompat.Files as X hiding (fileSize, removeLink, rename) +import System.PosixCompat.Files as X (FileStatus) import Utility.Misc as X import Utility.Exception as X diff --git a/Git/Hook.hs b/Git/Hook.hs index 7885523050..39d653e020 100644 --- a/Git/Hook.hs +++ b/Git/Hook.hs @@ -14,6 +14,9 @@ import Git import Utility.Tmp import Utility.Shell import Utility.FileMode +import qualified Utility.RawFilePath as R + +import System.PosixCompat.Files (fileMode) data Hook = Hook { hookName :: FilePath @@ -88,7 +91,7 @@ hookExists h r = do let f = hookFile h r catchBoolIO $ #ifndef mingw32_HOST_OS - isExecutable . fileMode <$> getFileStatus f + isExecutable . fileMode <$> R.getFileStatus (toRawFilePath f) #else doesFileExist f #endif diff --git a/Limit.hs b/Limit.hs index b105c9fb88..9afaada438 100644 --- a/Limit.hs +++ b/Limit.hs @@ -45,6 +45,7 @@ import Data.Time.Clock.POSIX import qualified Data.Set as S import qualified Data.Map as M import qualified System.FilePath.ByteString as P +import System.PosixCompat.Files (accessTime, isSymbolicLink) {- Some limits can look at the current status of files on - disk, or in the annex. This allows controlling which happens. -} @@ -272,7 +273,7 @@ matchLockStatus wantlocked (MatchingFile fi) = liftIO $ do islocked <- isPointerFile f >>= \case Just _key -> return False Nothing -> isSymbolicLink - <$> getSymbolicLinkStatus (fromRawFilePath f) + <$> R.getSymbolicLinkStatus f return (islocked == wantlocked) matchLockStatus wantlocked (MatchingInfo p) = pure $ case providedLinkType p of diff --git a/P2P/Address.hs b/P2P/Address.hs index 030e5ada63..a7b3c6db07 100644 --- a/P2P/Address.hs +++ b/P2P/Address.hs @@ -14,8 +14,10 @@ import Git.Types import Creds import Utility.AuthToken import Utility.Tor +import qualified Utility.RawFilePath as R import qualified Data.Text as T +import System.PosixCompat.Files (fileOwner, fileGroup) -- | A P2P address, without an AuthToken. -- @@ -80,8 +82,9 @@ storeP2PAddress addr = do -- This may be run by root, so make the creds file -- and directory have the same owner and group as -- the git repository directory has. - st <- liftIO . getFileStatus =<< Annex.fromRepo repoLocation - let fixowner f = setOwnerAndGroup f (fileOwner st) (fileGroup st) + st <- liftIO . R.getFileStatus . toRawFilePath + =<< Annex.fromRepo repoLocation + let fixowner f = R.setOwnerAndGroup (toRawFilePath f) (fileOwner st) (fileGroup st) liftIO $ do fixowner tmpf fixowner (takeDirectory tmpf) diff --git a/P2P/IO.hs b/P2P/IO.hs index 875ed02f09..b37ce058c0 100644 --- a/P2P/IO.hs +++ b/P2P/IO.hs @@ -50,6 +50,7 @@ import Control.Concurrent.STM import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import qualified Network.Socket as S +import System.PosixCompat.Files (groupReadMode, groupWriteMode, otherReadMode, otherWriteMode) -- Type of interpreters of the Proto free monad. type RunProto m = forall a. Proto a -> m (Either ProtoFailure a) diff --git a/Remote/Ddar.hs b/Remote/Ddar.hs index bdbb2e222e..37b6d03c1f 100644 --- a/Remote/Ddar.hs +++ b/Remote/Ddar.hs @@ -14,6 +14,7 @@ module Remote.Ddar (remote) where import qualified Data.Map as M import qualified Data.ByteString.Lazy as L import System.IO.Error +import System.PosixCompat.Files (isDirectory) import Annex.Common import Types.Remote @@ -28,6 +29,7 @@ import Annex.Ssh import Annex.UUID import Utility.SshHost import Types.ProposedAccepted +import qualified Utility.RawFilePath as R data DdarRepo = DdarRepo { ddarRepoConfig :: RemoteGitConfig @@ -185,7 +187,7 @@ ddarDirectoryExists :: DdarRepo -> Annex (Either String Bool) ddarDirectoryExists ddarrepo | ddarLocal ddarrepo = do maybeStatus <- liftIO $ tryJust (guard . isDoesNotExistError) $ - getSymbolicLinkStatus $ ddarRepoLocation ddarrepo + R.getSymbolicLinkStatus $ toRawFilePath $ ddarRepoLocation ddarrepo return $ case maybeStatus of Left _ -> Right False Right status -> Right $ isDirectory status diff --git a/Remote/Directory.hs b/Remote/Directory.hs index dcefa0a9e7..d495d42fdd 100644 --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -19,6 +19,7 @@ import qualified Data.ByteString.Lazy as L import qualified Data.Map as M import qualified System.FilePath.ByteString as P import Data.Default +import System.PosixCompat.Files (isRegularFile, getFdStatus, deviceID) import Annex.Common import Types.Remote @@ -254,7 +255,7 @@ retrieveKeyFileCheapM _ (LegacyChunks _) = Nothing retrieveKeyFileCheapM d NoChunks = Just $ \k _af f -> liftIO $ do file <- fromRawFilePath <$> (absPath =<< getLocation d k) ifM (doesFileExist file) - ( createSymbolicLink file f + ( R.createSymbolicLink (toRawFilePath file) (toRawFilePath f) , giveup "content file not present in remote" ) #else @@ -522,7 +523,7 @@ storeExportWithContentIdentifierM ii dir cow src _k loc overwritablecids p = do void $ liftIO $ fileCopier cow src tmpf p Nothing let tmpf' = toRawFilePath tmpf resetAnnexFilePerm tmpf' - liftIO (getSymbolicLinkStatus tmpf) >>= liftIO . mkContentIdentifier ii tmpf' >>= \case + liftIO (R.getSymbolicLinkStatus tmpf') >>= liftIO . mkContentIdentifier ii tmpf' >>= \case Nothing -> giveup "unable to generate content identifier" Just newcid -> do checkExportContent ii dir loc diff --git a/Remote/Git.hs b/Remote/Git.hs index d42b0fa396..c65d1388d1 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -700,7 +700,7 @@ type FileCopier = FilePath -> FilePath -> Key -> MeterUpdate -> Annex Bool -> Ve mkFileCopier :: Bool -> State -> Annex FileCopier mkFileCopier remotewanthardlink (State _ _ copycowtried _ _) = do localwanthardlink <- wantHardLink - let linker = \src dest -> createLink src dest >> return True + let linker = \src dest -> R.createLink (toRawFilePath src) (toRawFilePath dest) >> return True if remotewanthardlink || localwanthardlink then return $ \src dest k p check verifyconfig -> ifM (liftIO (catchBoolIO (linker src dest))) diff --git a/Remote/Helper/Git.hs b/Remote/Helper/Git.hs index 5fd7ea1e2a..b9fb900849 100644 --- a/Remote/Helper/Git.hs +++ b/Remote/Helper/Git.hs @@ -11,8 +11,10 @@ import Annex.Common import qualified Git import Types.Availability import qualified Types.Remote as Remote +import qualified Utility.RawFilePath as R import Data.Time.Clock.POSIX +import System.PosixCompat.Files (modificationTime) repoCheap :: Git.Repo -> Bool repoCheap = not . Git.repoIsUrl @@ -37,7 +39,7 @@ guardUsable r fallback a gitRepoInfo :: Remote -> Annex [(String, String)] gitRepoInfo r = do d <- fromRawFilePath <$> fromRepo Git.localGitDir - mtimes <- liftIO $ mapM (modificationTime <$$> getFileStatus) + mtimes <- liftIO $ mapM (\p -> modificationTime <$> R.getFileStatus (toRawFilePath p)) =<< dirContentsRecursive (d "refs" "remotes" Remote.name r) let lastsynctime = case mtimes of [] -> "never" diff --git a/Test.hs b/Test.hs index 961514236b..c16e597d71 100644 --- a/Test.hs +++ b/Test.hs @@ -26,9 +26,9 @@ import Control.Concurrent.STM hiding (check) import Common import CmdLine.GitAnnex.Options +import qualified Utility.RawFilePath as R import qualified Utility.ShellEscape -import qualified Utility.RawFilePath as R import qualified Annex import qualified Git.Filename import qualified Git.Types @@ -1498,7 +1498,7 @@ test_nonannexed_symlink_conflict_resolution = do git_annex "sync" [] "sync in r1" indir r2 $ do disconnectOrigin - createSymbolicLink symlinktarget "conflictor" + R.createSymbolicLink (toRawFilePath symlinktarget) (toRawFilePath "conflictor") git "add" [conflictor] "git add conflictor" git_annex "sync" [] "sync in r2" pair r1 r2 @@ -1518,8 +1518,8 @@ test_nonannexed_symlink_conflict_resolution = do length v == 1 @? (what ++ " too many variant files in: " ++ show v) conflictor `elem` l @? (what ++ " conflictor file missing in: " ++ show l) - s <- catchMaybeIO (readSymbolicLink (d conflictor)) - s == Just symlinktarget + s <- catchMaybeIO (R.readSymbolicLink (toRawFilePath (d conflictor))) + s == Just (toRawFilePath symlinktarget) @? (what ++ " wrong target for nonannexed symlink: " ++ show s) {- Check merge conflict resolution when there is a local file, diff --git a/Test/Framework.hs b/Test/Framework.hs index 28e951fe86..8653dca1be 100644 --- a/Test/Framework.hs +++ b/Test/Framework.hs @@ -25,10 +25,12 @@ import System.Console.Concurrent import System.Console.ANSI import GHC.Conc import System.IO.Unsafe (unsafePerformIO) +import System.PosixCompat.Files (isSymbolicLink, isRegularFile, fileMode, unionFileModes, ownerWriteMode) import Common import Types.Test import Types.Concurrency +import qualified Utility.RawFilePath as R import qualified Annex import qualified Annex.UUID @@ -351,24 +353,24 @@ checklink f = ifM (annexeval Config.crippledFileSystem) ( (isJust <$> annexeval (Annex.Link.getAnnexLinkTarget (toRawFilePath f))) @? f ++ " is not a (crippled) symlink" , do - s <- getSymbolicLinkStatus f + s <- R.getSymbolicLinkStatus (toRawFilePath f) isSymbolicLink s @? f ++ " is not a symlink" ) checkregularfile :: FilePath -> Assertion checkregularfile f = do - s <- getSymbolicLinkStatus f + s <- R.getSymbolicLinkStatus (toRawFilePath f) isRegularFile s @? f ++ " is not a normal file" return () checkdoesnotexist :: FilePath -> Assertion checkdoesnotexist f = - (either (const True) (const False) <$> Utility.Exception.tryIO (getSymbolicLinkStatus f)) + (either (const True) (const False) <$> Utility.Exception.tryIO (R.getSymbolicLinkStatus (toRawFilePath f))) @? f ++ " exists unexpectedly" checkexists :: FilePath -> Assertion checkexists f = - (either (const False) (const True) <$> Utility.Exception.tryIO (getSymbolicLinkStatus f)) + (either (const False) (const True) <$> Utility.Exception.tryIO (R.getSymbolicLinkStatus (toRawFilePath f))) @? f ++ " does not exist" checkcontent :: FilePath -> Assertion @@ -381,14 +383,14 @@ checkunwritable f = do -- Look at permissions bits rather than trying to write or -- using fileAccess because if run as root, any file can be -- modified despite permissions. - s <- getFileStatus f + s <- R.getFileStatus (toRawFilePath f) let mode = fileMode s when (mode == mode `unionFileModes` ownerWriteMode) $ assertFailure $ "able to modify annexed file's " ++ f ++ " content" checkwritable :: FilePath -> Assertion checkwritable f = do - s <- getFileStatus f + s <- R.getFileStatus (toRawFilePath f) let mode = fileMode s unless (mode == mode `unionFileModes` ownerWriteMode) $ assertFailure $ "unable to modify " ++ f diff --git a/Upgrade/V0.hs b/Upgrade/V0.hs index 3e6d9e6202..27dfab4c7f 100644 --- a/Upgrade/V0.hs +++ b/Upgrade/V0.hs @@ -11,6 +11,9 @@ import Annex.Common import Types.Upgrade import Annex.Content import qualified Upgrade.V1 +import qualified Utility.RawFilePath as R + +import System.PosixCompat.Files (isRegularFile) upgrade :: Annex UpgradeResult upgrade = do @@ -46,7 +49,8 @@ getKeysPresent0 dir = ifM (liftIO $ doesDirectoryExist dir) where present d = do result <- tryIO $ - getFileStatus $ dir ++ "/" ++ takeFileName d + R.getFileStatus $ toRawFilePath $ + dir ++ "/" ++ takeFileName d case result of Right s -> return $ isRegularFile s Left _ -> return False diff --git a/Upgrade/V1.hs b/Upgrade/V1.hs index 107db03615..4f6dfca226 100644 --- a/Upgrade/V1.hs +++ b/Upgrade/V1.hs @@ -15,6 +15,7 @@ import qualified Data.ByteString as S import qualified Data.ByteString.Short as S (toShort, fromShort) import qualified Data.ByteString.Lazy as L import qualified System.FilePath.ByteString as P +import System.PosixCompat.Files (isRegularFile) import Annex.Common import Types.Upgrade @@ -30,6 +31,7 @@ import Backend import Utility.FileMode import Utility.Tmp import qualified Upgrade.V2 +import qualified Utility.RawFilePath as R -- v2 adds hashing of filenames of content and location log files. -- Key information is encoded in filenames differently, so @@ -101,7 +103,7 @@ updateSymlinks = do link <- fromRawFilePath <$> calcRepo (gitAnnexLink (toRawFilePath f) k) liftIO $ removeFile f - liftIO $ createSymbolicLink link f + liftIO $ R.createSymbolicLink (toRawFilePath link) (toRawFilePath f) Annex.Queue.addCommand [] "add" [Param "--"] [f] moveLocationLogs :: Annex () @@ -203,7 +205,8 @@ lookupKey1 file = do Left _ -> return Nothing Right l -> makekey l where - getsymlink = takeFileName <$> readSymbolicLink file + getsymlink = takeFileName . fromRawFilePath + <$> R.readSymbolicLink (toRawFilePath file) makekey l = maybeLookupBackendVariety (fromKey keyVariety k) >>= \case Nothing -> do unless (null kname || null bname || @@ -232,7 +235,7 @@ getKeyFilesPresent1' dir = ) where present f = do - result <- tryIO $ getFileStatus f + result <- tryIO $ R.getFileStatus (toRawFilePath f) case result of Right s -> return $ isRegularFile s Left _ -> return False diff --git a/Upgrade/V7.hs b/Upgrade/V7.hs index 219c11ed14..b3d1bd630f 100644 --- a/Upgrade/V7.hs +++ b/Upgrade/V7.hs @@ -24,6 +24,7 @@ import Config import qualified Utility.RawFilePath as R import qualified System.FilePath.ByteString as P +import System.PosixCompat.Files (isSymbolicLink) upgrade :: Bool -> Annex UpgradeResult upgrade automatic = do @@ -110,7 +111,7 @@ populateKeysDb = unlessM isBareRepo $ do (l, cleanup) <- inRepo $ LsFiles.inodeCaches [top] forM_ l $ \case (_f, Nothing) -> giveup "Unable to parse git ls-files --debug output while upgrading git-annex sqlite databases." - (f, Just ic) -> unlessM (liftIO $ catchBoolIO $ isSymbolicLink <$> getSymbolicLinkStatus f) $ do + (f, Just ic) -> unlessM (liftIO $ catchBoolIO $ isSymbolicLink <$> R.getSymbolicLinkStatus (toRawFilePath f)) $ do catKeyFile (toRawFilePath f) >>= \case Nothing -> noop Just k -> do diff --git a/Utility/DirWatcher/INotify.hs b/Utility/DirWatcher/INotify.hs index c33b02fa6b..700bff5773 100644 --- a/Utility/DirWatcher/INotify.hs +++ b/Utility/DirWatcher/INotify.hs @@ -7,9 +7,10 @@ module Utility.DirWatcher.INotify (watchDir) where -import Common hiding (isDirectory) +import Common import Utility.ThreadLock import Utility.DirWatcher.Types +import qualified Utility.RawFilePath as R import System.INotify import qualified System.Posix.Files as Files @@ -149,14 +150,14 @@ watchDir i dir ignored scanevents hooks indir f = dir f - getstatus f = catchMaybeIO $ getSymbolicLinkStatus $ indir f + getstatus f = catchMaybeIO $ R.getSymbolicLinkStatus $ toRawFilePath $ indir f checkfiletype check h f = do ms <- getstatus f case ms of Just s | check s -> runhook h f ms _ -> noop - filetype t f = catchBoolIO $ t <$> getSymbolicLinkStatus (indir f) + filetype t f = catchBoolIO $ t <$> R.getSymbolicLinkStatus (toRawFilePath (indir f)) failedaddwatch e -- Inotify fails when there are too many watches with a diff --git a/Utility/DirWatcher/Win32Notify.hs b/Utility/DirWatcher/Win32Notify.hs index 7a76f618a7..7eba40de97 100644 --- a/Utility/DirWatcher/Win32Notify.hs +++ b/Utility/DirWatcher/Win32Notify.hs @@ -11,7 +11,7 @@ import Common hiding (isDirectory) import Utility.DirWatcher.Types import System.Win32.Notify -import qualified System.PosixCompat.Files as Files +import qualified System.PosixCompat.Files (isRegularFile) watchDir :: FilePath -> (FilePath -> Bool) -> Bool -> WatchHooks -> IO WatchManager watchDir dir ignored scanevents hooks = do @@ -51,7 +51,7 @@ watchDir dir ignored scanevents hooks = do case ms of Nothing -> noop Just s - | Files.isRegularFile s -> + | isRegularFile s -> when scanevents $ runhook addHook ms | otherwise -> diff --git a/Utility/Directory.hs b/Utility/Directory.hs index b98d221369..a5c023f5cd 100644 --- a/Utility/Directory.hs +++ b/Utility/Directory.hs @@ -16,7 +16,7 @@ module Utility.Directory ( import Control.Monad import System.FilePath -import System.PosixCompat.Files (getSymbolicLinkStatus, isDirectory, isSymbolicLink) +import System.PosixCompat.Files (isDirectory, isSymbolicLink) import Control.Applicative import System.IO.Unsafe (unsafeInterleaveIO) import Data.Maybe @@ -25,7 +25,8 @@ import Prelude import Utility.SystemDirectory import Utility.Exception import Utility.Monad -import Utility.Applicative +import Utility.FileSystemEncoding +import qualified Utility.RawFilePath as R dirCruft :: FilePath -> Bool dirCruft "." = True @@ -65,7 +66,7 @@ dirContentsRecursiveSkipping skipdir followsubdirsymlinks topdir = go [topdir] | otherwise = do let skip = collect (entry:files) dirs' entries let recurse = collect files (entry:dirs') entries - ms <- catchMaybeIO $ getSymbolicLinkStatus entry + ms <- catchMaybeIO $ R.getSymbolicLinkStatus (toRawFilePath entry) case ms of (Just s) | isDirectory s -> recurse @@ -87,9 +88,10 @@ dirTreeRecursiveSkipping skipdir topdir = go [] [topdir] | skipdir (takeFileName dir) = go c dirs | otherwise = unsafeInterleaveIO $ do subdirs <- go [] - =<< filterM (isDirectory <$$> getSymbolicLinkStatus) + =<< filterM isdir =<< catchDefaultIO [] (dirContents dir) go (subdirs++dir:c) dirs + isdir p = isDirectory <$> R.getSymbolicLinkStatus (toRawFilePath p) {- Use with an action that removes something, which may or may not exist. - diff --git a/Utility/InodeCache.hs b/Utility/InodeCache.hs index 27ee0b2cc3..a9a6bb1906 100644 --- a/Utility/InodeCache.hs +++ b/Utility/InodeCache.hs @@ -51,6 +51,7 @@ import Utility.QuickCheck import qualified Utility.RawFilePath as R import System.PosixCompat.Types +import System.PosixCompat.Files (isRegularFile, fileID) import Data.Time.Clock.POSIX #ifdef mingw32_HOST_OS diff --git a/Utility/QuickCheck.hs b/Utility/QuickCheck.hs index 650f559324..96e31d5c08 100644 --- a/Utility/QuickCheck.hs +++ b/Utility/QuickCheck.hs @@ -6,6 +6,7 @@ -} {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} {-# LANGUAGE TypeSynonymInstances #-} module Utility.QuickCheck diff --git a/Utility/RawFilePath.hs b/Utility/RawFilePath.hs index 9d4f427e2e..b39423df5b 100644 --- a/Utility/RawFilePath.hs +++ b/Utility/RawFilePath.hs @@ -5,9 +5,11 @@ - - On Windows, filenames are in unicode, so RawFilePaths have to be - decoded. So this library will work, but less efficiently than using - - FilePath would. + - FilePath would. However, this library also takes care to support long + - filenames on Windows, by either using other libraries that do, or by + - doing UNC-style conversion itself. - - - Copyright 2019-2020 Joey Hess + - Copyright 2019-2023 Joey Hess - - License: BSD-2-clause -} @@ -27,7 +29,10 @@ module Utility.RawFilePath ( getCurrentDirectory, createDirectory, setFileMode, + setOwnerAndGroup, rename, + createNamedPipe, + fileAccess, ) where #ifndef mingw32_HOST_OS @@ -48,23 +53,28 @@ createDirectory p = D.createDirectory p 0o777 #else import System.PosixCompat (FileStatus, FileMode) +-- System.PosixCompat does not handle UNC-style conversion itself, +-- so all uses of it library have to be pre-converted below. See +-- https://github.com/jacobstanley/unix-compat/issues/56 import qualified System.PosixCompat as P -import qualified System.PosixCompat.Files as F import qualified System.Directory as D import Utility.FileSystemEncoding +import Utility.Path.Windows readSymbolicLink :: RawFilePath -> IO RawFilePath readSymbolicLink f = toRawFilePath <$> P.readSymbolicLink (fromRawFilePath f) createSymbolicLink :: RawFilePath -> RawFilePath -> IO () -createSymbolicLink a b = P.createSymbolicLink - (fromRawFilePath a) - (fromRawFilePath b) +createSymbolicLink a b = do + a' <- fromRawFilePath <$> convertToWindowsNativeNamespace a + b' <- fromRawFilePath <$> convertToWindowsNativeNamespace b + P.createSymbolicLink a' b' createLink :: RawFilePath -> RawFilePath -> IO () -createLink a b = P.createLink - (fromRawFilePath a) - (fromRawFilePath b) +createLink a b = do + a' <- fromRawFilePath <$> convertToWindowsNativeNamespace a + b' <- fromRawFilePath <$> convertToWindowsNativeNamespace b + P.createLink a' b' {- On windows, removeLink is not available, so only remove files, - not symbolic links. -} @@ -72,10 +82,12 @@ removeLink :: RawFilePath -> IO () removeLink = D.removeFile . fromRawFilePath getFileStatus :: RawFilePath -> IO FileStatus -getFileStatus = P.getFileStatus . fromRawFilePath +getFileStatus p = P.getFileStatus . fromRawFilePath + =<< convertToWindowsNativeNamespace p getSymbolicLinkStatus :: RawFilePath -> IO FileStatus -getSymbolicLinkStatus = P.getSymbolicLinkStatus . fromRawFilePath +getSymbolicLinkStatus p = P.getSymbolicLinkStatus . fromRawFilePath + =<< convertToWindowsNativeNamespace p doesPathExist :: RawFilePath -> IO Bool doesPathExist = D.doesPathExist . fromRawFilePath @@ -87,10 +99,27 @@ createDirectory :: RawFilePath -> IO () createDirectory = D.createDirectory . fromRawFilePath setFileMode :: RawFilePath -> FileMode -> IO () -setFileMode = F.setFileMode . fromRawFilePath +setFileMode p m = do + p' <- fromRawFilePath <$> convertToWindowsNativeNamespace p + P.setFileMode p' m {- Using renamePath rather than the rename provided in unix-compat - because of this bug https://github.com/jacobstanley/unix-compat/issues/56-} rename :: RawFilePath -> RawFilePath -> IO () rename a b = D.renamePath (fromRawFilePath a) (fromRawFilePath b) + +setOwnerAndGroup :: RawFilePath -> P.UserID -> P.GroupID -> IO () +setOwnerAndGroup p u g = do + p' <- fromRawFilePath <$> convertToWindowsNativeNamespace p + P.setOwnerAndGroup p' u g + +createNamedPipe :: RawFilePath -> FileMode -> IO () +createNamedPipe p m = do + p' <- fromRawFilePath <$> convertToWindowsNativeNamespace p + P.createNamedPipe p' m + +fileAccess :: RawFilePath -> Bool -> Bool -> Bool -> IO Bool +fileAccess p a b c = do + p' <- fromRawFilePath <$> convertToWindowsNativeNamespace p + P.fileAccess p' a b c #endif diff --git a/Utility/SshConfig.hs b/Utility/SshConfig.hs index bac38c530f..83c63fcd3d 100644 --- a/Utility/SshConfig.hs +++ b/Utility/SshConfig.hs @@ -32,6 +32,7 @@ import Utility.FileMode import Data.Char import Data.Ord import Data.Either +import System.PosixCompat.Files (groupWriteMode, otherWriteMode) data SshConfig = GlobalConfig SshSetting diff --git a/Utility/Tmp.hs b/Utility/Tmp.hs index 92bd921bc8..efb15bd9b3 100644 --- a/Utility/Tmp.hs +++ b/Utility/Tmp.hs @@ -21,12 +21,12 @@ import System.IO import System.FilePath import System.Directory import Control.Monad.IO.Class -import System.PosixCompat.Files hiding (removeLink) import System.IO.Error import Utility.Exception import Utility.FileSystemEncoding import Utility.FileMode +import qualified Utility.RawFilePath as R type Template = String @@ -62,14 +62,15 @@ viaTmp a file content = bracketIO setup cleanup use _ <- tryIO $ hClose h tryIO $ removeFile tmpfile use (tmpfile, h) = do + let tmpfile' = toRawFilePath tmpfile -- Make mode the same as if the file were created usually, -- not as a temp file. (This may fail on some filesystems -- that don't support file modes well, so ignore -- exceptions.) - _ <- liftIO $ tryIO $ setFileMode tmpfile =<< defaultFileMode + _ <- liftIO $ tryIO $ R.setFileMode tmpfile' =<< defaultFileMode liftIO $ hClose h a tmpfile content - liftIO $ rename tmpfile file + liftIO $ R.rename tmpfile' (toRawFilePath file) {- Runs an action with a tmp file located in the system's tmp directory - (or in "." if there is none) then removes the file. -} diff --git a/Utility/Tor.hs b/Utility/Tor.hs index a9d1037a13..9147e9b049 100644 --- a/Utility/Tor.hs +++ b/Utility/Tor.hs @@ -22,8 +22,10 @@ module Utility.Tor ( import Common import Utility.ThreadScheduler import Utility.FileMode +import Utility.RawFilePath (setOwnerAndGroup) import System.PosixCompat.Types +import System.PosixCompat.Files (ownerReadMode, ownerWriteMode, ownerExecuteMode) import Data.Char import Network.Socket import Network.Socks5 @@ -165,7 +167,7 @@ getHiddenServiceSocketFile _appname uid ident = prepHiddenServiceSocketDir :: AppName -> UserID -> UniqueIdent -> IO () prepHiddenServiceSocketDir appname uid ident = do createDirectoryIfMissing True d - setOwnerAndGroup d uid (-1) + setOwnerAndGroup (toRawFilePath d) uid (-1) modifyFileMode (toRawFilePath d) $ addModes [ownerReadMode, ownerExecuteMode, ownerWriteMode] where