diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,14 @@ # Revision history for file-io +## 0.2.0 -- 2025-01-30 + +* Add ability to use `cloexec` in `openTempFile'` wrt [#44](https://github.com/haskell/file-io/issues/44) + +## 0.1.6 -- 2025-01-30 + +* Fix long path support on windows wrt [#39](https://github.com/haskell/file-io/issues/39) +* Respect current locale when returning a handle wrt [#45](https://github.com/haskell/file-io/issues/45) + ## 0.1.5 -- 2024-11-26 * Don't use QuasiQotes diff --git a/System/File/OsPath/Internal.hs b/System/File/OsPath/Internal.hs --- a/System/File/OsPath/Internal.hs +++ b/System/File/OsPath/Internal.hs @@ -160,14 +160,14 @@ -- be truncated to 3 chars, e.g. \"foobar.ext\" will be -- \"fooXXX.ext\". -> IO (OsPath, Handle) -openTempFile tmp_dir template = openTempFile' "openTempFile" tmp_dir template False 0o600 +openTempFile tmp_dir template = openTempFile' "openTempFile" tmp_dir template False 0o600 False -- | Like 'openTempFile', but opens the file in binary mode. See 'openBinaryFile' for more comments. -- -- @since 0.1.3 openBinaryTempFile :: OsPath -> OsString -> IO (OsPath, Handle) openBinaryTempFile tmp_dir template - = openTempFile' "openBinaryTempFile" tmp_dir template True 0o600 + = openTempFile' "openBinaryTempFile" tmp_dir template True 0o600 False -- | Like 'openTempFile', but uses the default file permissions -- @@ -175,7 +175,7 @@ openTempFileWithDefaultPermissions :: OsPath -> OsString -> IO (OsPath, Handle) openTempFileWithDefaultPermissions tmp_dir template - = openTempFile' "openTempFileWithDefaultPermissions" tmp_dir template False 0o666 + = openTempFile' "openTempFileWithDefaultPermissions" tmp_dir template False 0o666 False -- | Like 'openBinaryTempFile', but uses the default file permissions -- @@ -183,7 +183,7 @@ openBinaryTempFileWithDefaultPermissions :: OsPath -> OsString -> IO (OsPath, Handle) openBinaryTempFileWithDefaultPermissions tmp_dir template - = openTempFile' "openBinaryTempFileWithDefaultPermissions" tmp_dir template True 0o666 + = openTempFile' "openBinaryTempFileWithDefaultPermissions" tmp_dir template True 0o666 False -- --------------------------------------------------------------------------- -- Internals @@ -232,13 +232,13 @@ augmentError str osfp = flip catchException (ioError . addFilePathToIOError str osfp) -openTempFile' :: String -> OsPath -> OsString -> Bool -> CMode +openTempFile' :: String -> OsPath -> OsString -> Bool -> CMode -> Bool -> IO (OsPath, Handle) -openTempFile' loc (OsString tmp_dir) template@(OsString tmpl) binary mode +openTempFile' loc (OsString tmp_dir) template@(OsString tmpl) binary mode cloExec | any_ (== OSP.pathSeparator) template = throwIO $ userError $ "openTempFile': Template string must not contain path separator characters: " ++ P.lenientDecode tmpl | otherwise = do - (fp, hdl) <- P.findTempName (prefix, suffix) loc tmp_dir mode + (fp, hdl) <- P.findTempName (prefix, suffix) loc tmp_dir mode cloExec when binary $ hSetBinaryMode hdl True pure (OsString fp, hdl) where diff --git a/file-io.cabal b/file-io.cabal --- a/file-io.cabal +++ b/file-io.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: file-io -version: 0.1.5 +version: 0.2.0 synopsis: Basic file IO operations via 'OsPath' description: Basic file IO operations like Prelude, but for 'OsPath'. homepage: https://github.com/hasufell/file-io @@ -29,6 +29,11 @@ default: False manual: False +flag long-paths + description: Enable a hack for ad-hoc long path support on Windows + default: True + manual: True + library default-language: Haskell2010 @@ -51,6 +56,9 @@ else build-depends: filepath >= 1.4.100.0 && < 1.5.0.0 + if flag(long-paths) + cpp-options: -DLONG_PATHS + exposed-modules: System.File.OsPath System.File.OsPath.Internal @@ -111,6 +119,8 @@ main-is: Properties.hs type: exitcode-stdio-1.0 default-language: Haskell2010 - build-depends: base >=4.13.0.0 && <5, bytestring, tasty, tasty-hunit, file-io, filepath, temporary + build-depends: base >=4.13.0.0 && <5, bytestring, directory, tasty, tasty-hunit, file-io, filepath, temporary ghc-options: -Wall -threaded -rtsopts "-with-rtsopts=-N10" + if flag(long-paths) + cpp-options: -DLONG_PATHS diff --git a/posix/System/File/Platform.hs b/posix/System/File/Platform.hs --- a/posix/System/File/Platform.hs +++ b/posix/System/File/Platform.hs @@ -20,10 +20,11 @@ import qualified System.OsPath.Posix as PS import Data.IORef (IORef, newIORef) import System.Posix (CMode) -import System.IO (utf8, latin1) +import System.IO (utf8, latin1, hSetEncoding) import System.IO.Unsafe (unsafePerformIO) import System.Posix.Internals (c_getpid) import GHC.IORef (atomicModifyIORef'_) +import GHC.IO.Encoding (getLocaleEncoding) import Foreign.C (getErrno, eEXIST, errnoToIOError) #if !MIN_VERSION_filepath(1, 5, 0) @@ -63,7 +64,9 @@ fdToHandle_ :: IOMode -> PosixPath -> Fd -> IO Handle fdToHandle_ iomode fp (Fd fd) = (`onException` closeFd (Fd fd)) $ do fp' <- fromRight (fmap PS.toChar . PS.unpack $ fp) <$> try @SomeException (PS.decodeFS fp) - fdToHandle' fd Nothing False fp' iomode True + h' <- fdToHandle' fd Nothing False fp' iomode True + getLocaleEncoding >>= hSetEncoding h' + pure h' openFileWithCloseOnExec :: PosixPath -> IOMode -> IO Handle openFileWithCloseOnExec = openFile_ defaultFileFlags' { cloexec = True } @@ -81,8 +84,9 @@ -> String -> PosixPath -> CMode + -> Bool -> IO (PosixPath, Handle) -findTempName (prefix, suffix) loc tmp_dir mode = go +findTempName (prefix, suffix) loc tmp_dir mode cloExec = go where go = do rs <- rand_string @@ -100,7 +104,7 @@ else fmap (filepath,) $ fdToHandle_ ReadWriteMode filepath fd openTempFile_ :: PosixPath -> CMode -> IO Fd - openTempFile_ fp cmode = openFd fp ReadWrite defaultFileFlags' { creat = Just cmode, nonBlock = True, noctty = True, exclusive = True } + openTempFile_ fp cmode = openFd fp ReadWrite defaultFileFlags' { creat = Just cmode, nonBlock = True, noctty = True, exclusive = True, cloexec = cloExec } tempCounter :: IORef Int tempCounter = unsafePerformIO $ newIORef 0 diff --git a/tests/Properties.hs b/tests/Properties.hs --- a/tests/Properties.hs +++ b/tests/Properties.hs @@ -7,6 +7,7 @@ module Main where +import GHC.IO.Encoding import Control.Exception import qualified System.FilePath as FP import Test.Tasty @@ -18,12 +19,21 @@ import System.IO import System.IO.Temp import qualified Data.ByteString as BS +#if defined(LONG_PATHS) +import Control.Monad (when) +import System.Directory.OsPath (createDirectory) +import System.IO.Error (catchIOError) +#endif main :: IO () main = defaultMain $ testGroup "All" [ testGroup "System.File.OsPath" - [ testCase "readFile . writeFile" writeFileReadFile + [ +#if defined(LONG_PATHS) + testCase "writeFile (very long path)" writeFileLongPath, +#endif + testCase "readFile . writeFile" writeFileReadFile , testCase "readFile . writeFile . writeFile" writeWriteFileReadFile , testCase "readFile . appendFile . writeFile" appendFileReadFile , testCase "iomode: ReadFile does not allow write" iomodeReadFile @@ -53,9 +63,33 @@ , testCase "openBinaryTempFileWithDefaultPermissions" (openTempFile2 OSP.openBinaryTempFileWithDefaultPermissions) , testCase "openBinaryTempFileWithDefaultPermissions (reopen file)" (openTempFile1 OSP.openBinaryTempFileWithDefaultPermissions) , testCase "openBinaryTempFileWithDefaultPermissions (filepaths different)" (openTempFile3 OSP.openBinaryTempFileWithDefaultPermissions) + , testCase "respect setLocaleEncoding when opening a Handle" respectSetLocaleEncoding ] ] +#if defined(LONG_PATHS) +writeFileLongPath :: Assertion +writeFileLongPath = do + withSystemTempDirectory "test" $ \baseDir' -> do + baseDir <- OSP.encodeFS baseDir' + let longName = mconcat (replicate 10 [osp|its_very_long|]) + let longDir = baseDir longName longName + + supportsLongPaths <- do + -- create 2 dirs because 1 path segment by itself can't exceed MAX_PATH + -- tests: [createDirectory] + createDirectory (baseDir longName) + createDirectory longDir + return True + `catchIOError` \ _ -> + return False + + when supportsLongPaths $ do + OSP.writeFile (longDir [osp|foo|]) "test" + contents <- OSP.readFile (longDir [osp|foo|]) + "test" @=? contents +#endif + writeFileReadFile :: Assertion writeFileReadFile = do withSystemTempDirectory "test" $ \baseDir' -> do @@ -299,4 +333,14 @@ #else fileLockedType = ResourceBusy #endif + +respectSetLocaleEncoding :: Assertion +respectSetLocaleEncoding = do + withSystemTempDirectory "test" $ \baseDir' -> do + baseDir <- OSP.encodeFS baseDir' + let fp = baseDir [osp|foo|] + OSP.writeFile fp "testx" + setLocaleEncoding utf8 + enc <- OSP.withFile fp ReadMode hGetEncoding + (Just $ show utf8) @=? (show <$> enc) diff --git a/tests/T15Win.hs b/tests/T15Win.hs --- a/tests/T15Win.hs +++ b/tests/T15Win.hs @@ -12,7 +12,6 @@ import System.IO import System.IO.Temp -import Control.Exception (bracketOnError) import Data.Bits import System.OsPath.Windows ( WindowsPath, pstr ) import qualified System.OsPath.Windows as WS @@ -36,7 +35,7 @@ ] openFile32 :: WindowsPath -> IOMode -> IO Win32.HANDLE -openFile32 fp iomode = +openFile32 fp _iomode = WS.createFile fp Win32.gENERIC_READ diff --git a/windows/System/File/Platform.hsc b/windows/System/File/Platform.hsc --- a/windows/System/File/Platform.hsc +++ b/windows/System/File/Platform.hsc @@ -1,22 +1,25 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE PackageImports #-} +{-# LANGUAGE MultiWayIf #-} module System.File.Platform where import Control.Exception (bracketOnError, try, SomeException, onException) import Data.Bits +import Data.Coerce import Data.Maybe (fromJust) -import System.IO (IOMode(..), Handle) +import System.IO (IOMode(..), Handle, hSetEncoding) import System.OsPath.Windows ( WindowsPath ) +import qualified System.OsPath.Windows as OSP import qualified System.OsPath.Windows as WS import Foreign.C.Types -import qualified System.OsString.Windows as WS hiding (decodeFS) -import System.OsString.Windows ( encodeUtf, WindowsString ) +import System.OsString.Windows ( encodeUtf, WindowsString, WindowsChar ) import qualified System.Win32 as Win32 import qualified System.Win32.WindowsString.File as WS import System.Win32.WindowsString.Types (withTString, peekTString) +import GHC.IO.Encoding (getLocaleEncoding) #if MIN_VERSION_Win32(2, 14, 0) import System.Win32.WindowsString.Types (withFilePath) #endif @@ -43,8 +46,8 @@ #if MIN_VERSION_filepath(1, 5, 0) import System.OsString.Encoding +import qualified "os-string" System.OsString.Data.ByteString.Short.Word16 as BC import "os-string" System.OsString.Internal.Types (WindowsString(..), WindowsChar(..)) -import qualified "os-string" System.OsString.Data.ByteString.Short as BC #else import Data.Coerce (coerce) import System.OsPath.Encoding @@ -52,9 +55,22 @@ import qualified "filepath" System.OsPath.Data.ByteString.Short.Word16 as BC #endif +import System.IO.Error (modifyIOError, ioeSetFileName) +import GHC.IO.Encoding.UTF16 (mkUTF16le) +import GHC.IO.Encoding.Failure (CodingFailureMode(TransliterateCodingFailure)) +import Control.Exception (displayException, Exception) + +#if defined(LONG_PATHS) +import System.IO.Error (ioeSetLocation, ioeGetLocation, catchIOError) +import Data.Char (isAlpha, isAscii, toUpper) +import qualified System.Win32.WindowsString.Info as WS +#endif + -- | Open a file and return the 'Handle'. openFile :: WindowsPath -> IOMode -> IO Handle -openFile fp iomode = bracketOnError +openFile fp' iomode = (`ioeSetWsPath` fp') `modifyIOError` do + fp <- furnishPath fp' + bracketOnError (WS.createFile fp accessMode @@ -71,7 +87,7 @@ #endif Nothing) Win32.closeHandle - (toHandle fp iomode) + (toHandle fp' iomode) where accessMode = case iomode of ReadMode -> Win32.gENERIC_READ @@ -104,7 +120,9 @@ -- | Open an existing file and return the 'Handle'. openExistingFile :: WindowsPath -> IOMode -> IO Handle -openExistingFile fp iomode = bracketOnError +openExistingFile fp' iomode = (`ioeSetWsPath` fp') `modifyIOError` do + fp <- furnishPath fp' + bracketOnError (WS.createFile fp accessMode @@ -156,8 +174,9 @@ -> String -> WindowsPath -> CMode + -> Bool -> IO (WindowsPath, Handle) -findTempName (prefix, suffix) loc tmp_dir mode = go +findTempName (prefix, suffix) loc tmp_dir mode _cloExec = go where go = do let label = if prefix == mempty then fromJust (encodeUtf "ghc") else prefix @@ -220,12 +239,12 @@ return $ WS.pack $ fmap (WS.unsafeFromChar) (printf "%x-%x-%x" r1 r2 r3) lenientDecode :: WindowsString -> String -lenientDecode ws = let utf16le' = WS.decodeWith utf16le_b ws - ucs2' = WS.decodeWith ucs2le ws - in case (utf16le', ucs2') of - (Right s, ~_) -> s - (_, Right s) -> s - (Left _, Left _) -> error "lenientDecode: failed to decode" +lenientDecode wstr = let utf16le' = WS.decodeWith utf16le_b wstr + ucs2' = WS.decodeWith ucs2le wstr + in case (utf16le', ucs2') of + (Right s, ~_) -> s + (_, Right s) -> s + (Left _, Left _) -> error "lenientDecode: failed to decode" toHandle :: WindowsPath -> IOMode -> Win32.HANDLE -> IO Handle @@ -238,7 +257,9 @@ when (iomode == AppendMode ) $ void $ Win32.setFilePointerEx h 0 Win32.fILE_END fd <- _open_osfhandle (fromIntegral (ptrToIntPtr h)) (#const _O_BINARY) fp' <- either (const (fmap WS.toChar . WS.unpack $ fp)) id <$> try @SomeException (WS.decodeFS fp) - fdToHandle' fd Nothing False fp' iomode True + h' <- fdToHandle' fd Nothing False fp' iomode True + getLocaleEncoding >>= hSetEncoding h' + pure h' #endif #if !MIN_VERSION_filepath(1, 5, 0) @@ -248,3 +269,162 @@ #endif +ioeSetWsPath :: IOError -> WindowsPath -> IOError +ioeSetWsPath err = + ioeSetFileName err . + rightOrError . + WS.decodeWith (mkUTF16le TransliterateCodingFailure) + +rightOrError :: Exception e => Either e a -> a +rightOrError (Left e) = error (displayException e) +rightOrError (Right a) = a + +-- inlined stuff from directory package +furnishPath :: WindowsPath -> IO WindowsPath +#if !defined(LONG_PATHS) +furnishPath path = pure path +#else +furnishPath path = + (toExtendedLengthPath <$> rawPrependCurrentDirectory path) + `catchIOError` \ _ -> + pure path + +toExtendedLengthPath :: WindowsPath -> WindowsPath +toExtendedLengthPath path = + if WS.isRelative path + then simplifiedPath + else + if | ws "\\??\\" `isPrefixOf'` simplifiedPath -> simplifiedPath + | ws "\\\\?\\" `isPrefixOf'` simplifiedPath -> simplifiedPath + | ws "\\\\.\\" `isPrefixOf'` simplifiedPath -> simplifiedPath + | ws "\\\\" `isPrefixOf'` simplifiedPath -> ws "\\\\?\\UNC" <> drop' 1 simplifiedPath + | otherwise -> ws "\\\\?\\" <> simplifiedPath + where simplifiedPath = simplifyWindows path + +rawPrependCurrentDirectory :: WindowsPath -> IO WindowsPath +rawPrependCurrentDirectory path + | WS.isRelative path = + ((`ioeAddLocation` "prependCurrentDirectory") . + (`ioeSetWsPath` path)) `modifyIOError` do + getFullPathName path + | otherwise = pure path + +simplifyWindows :: WindowsPath -> WindowsPath +simplifyWindows path + | path == mempty = mempty + | drive' == ws "\\\\?\\" = drive' <> subpath + | otherwise = simplifiedPath + where + simplifiedPath = WS.joinDrive drive' subpath' + (drive, subpath) = WS.splitDrive path + drive' = upperDrive (normaliseTrailingSep (normalisePathSeps drive)) + subpath' = appendSep . avoidEmpty . prependSep . WS.joinPath . + stripPardirs . expandDots . skipSeps . + WS.splitDirectories $ subpath + + upperDrive d = case WS.unpack d of + c : k : s + | isAlpha (WS.toChar c), WS.toChar k == ':', all WS.isPathSeparator s -> + -- unsafeFromChar is safe here since all characters are ASCII. + WS.pack (WS.unsafeFromChar (toUpper (WS.toChar c)) : WS.unsafeFromChar ':' : s) + _ -> d + skipSeps = + (WS.pack <$>) . + filter (not . (`elem` (pure <$> WS.pathSeparators))) . + (WS.unpack <$>) + stripPardirs | pathIsAbsolute || subpathIsAbsolute = dropWhile (== ws "..") + | otherwise = id + prependSep | subpathIsAbsolute = (WS.pack [WS.pathSeparator] <>) + | otherwise = id + avoidEmpty | not pathIsAbsolute + , drive == mempty || hasTrailingPathSep -- prefer "C:" over "C:." + = emptyToCurDir + | otherwise = id + appendSep p | hasTrailingPathSep, not (pathIsAbsolute && p == mempty) + = WS.addTrailingPathSeparator p + | otherwise = p + pathIsAbsolute = not (WS.isRelative path) + subpathIsAbsolute = any WS.isPathSeparator (take 1 (WS.unpack subpath)) + hasTrailingPathSep = WS.hasTrailingPathSeparator subpath + +expandDots :: [WindowsPath] -> [WindowsPath] +expandDots = reverse . go [] + where + go ys' xs' = + case xs' of + [] -> ys' + x : xs + | x == ws "." -> go ys' xs + | x == ws ".." -> + case ys' of + [] -> go (x : ys') xs + y : ys + | y == ws ".." -> go (x : ys') xs + | otherwise -> go ys xs + | otherwise -> go (x : ys') xs + +-- | Remove redundant trailing slashes and pick the right kind of slash. +normaliseTrailingSep :: WindowsPath -> WindowsPath +normaliseTrailingSep path = do + let path' = reverse (WS.unpack path) + let (sep, path'') = span WS.isPathSeparator path' + let addSep = if null sep then id else (WS.pathSeparator :) + WS.pack (reverse (addSep path'')) + +normalisePathSeps :: WindowsPath -> WindowsPath +normalisePathSeps p = WS.pack (normaliseChar <$> WS.unpack p) + where normaliseChar c = if WS.isPathSeparator c then WS.pathSeparator else c + +emptyToCurDir :: WindowsPath -> WindowsPath +emptyToCurDir path + | path == mempty = ws "." + | otherwise = path + +ws :: String -> WindowsString +ws = rightOrError . WS.encodeUtf + +getFullPathName :: WindowsPath -> IO WindowsPath +getFullPathName path = + fromExtendedLengthPath <$> WS.getFullPathName (toExtendedLengthPath path) + +ioeAddLocation :: IOError -> String -> IOError +ioeAddLocation e loc = do + ioeSetLocation e newLoc + where + newLoc = loc <> if null oldLoc then "" else ":" <> oldLoc + oldLoc = ioeGetLocation e + +fromExtendedLengthPath :: WindowsPath -> WindowsPath +fromExtendedLengthPath ePath + | ws "\\\\?\\" `isPrefixOf'` ePath + , let eSubpath = drop' 4 ePath + = if | ws "UNC\\" `isPrefixOf'` eSubpath + -> ws "\\\\" <> drop' 4 eSubpath + | Just (drive, rest) <- uncons' eSubpath + , Just (col, subpath) <- uncons' rest + , WS.toChar col == ':' + , isDriveChar drive + , isPathRegular subpath + -> eSubpath + | otherwise + -> ePath + | otherwise = ePath + where + isDriveChar drive = isAlpha (WS.toChar drive) && isAscii (WS.toChar drive) + isPathRegular path = + not (WS.unsafeFromChar '/' `elem'` path || + any (\x -> x == ws ".." || x == ws ".") (WS.splitDirectories path)) + +elem' :: WindowsChar -> WindowsString -> Bool +elem' = coerce BC.elem + +isPrefixOf' :: WindowsString -> WindowsString -> Bool +isPrefixOf' = coerce BC.isPrefixOf + +drop' :: Int -> WindowsString -> WindowsString +drop' = coerce BC.drop + +uncons' :: WindowsString -> Maybe (WindowsChar, WindowsString) +uncons' = coerce BC.uncons + +#endif