merge from git-annex

Support building with unix-compat 0.7

1 files changed, 47 insertions, 12 deletions

diff --git a/Utility/RawFilePath.hs b/Utility/RawFilePath.hs
index f32b226..b39423d 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 <id@joeyh.name>
+ - Copyright 2019-2023 Joey Hess <id@joeyh.name>
  -
  - License: BSD-2-clause
  -}
@@ -27,6 +29,10 @@ module Utility.RawFilePath (
 	getCurrentDirectory,
 	createDirectory,
 	setFileMode,
+	setOwnerAndGroup,
+	rename,
+	createNamedPipe,
+	fileAccess,
 ) where
 
 #ifndef mingw32_HOST_OS
@@ -47,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. -}
@@ -71,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
@@ -86,5 +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