file-io 0.1.5 → 0.2.0
raw patch · 7 files changed
Files
- CHANGELOG.md +9/−0
- System/File/OsPath/Internal.hs +7/−7
- file-io.cabal +12/−2
- posix/System/File/Platform.hs +8/−4
- tests/Properties.hs +45/−1
- tests/T15Win.hs +1/−2
- windows/System/File/Platform.hsc +195/−15
CHANGELOG.md view
@@ -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
System/File/OsPath/Internal.hs view
@@ -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
file-io.cabal view
@@ -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
posix/System/File/Platform.hs view
@@ -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
tests/Properties.hs view
@@ -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)
tests/T15Win.hs view
@@ -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
windows/System/File/Platform.hsc view
@@ -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