diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,12 @@ # Revision history for file-io +## 0.1.1 -- 2024-01-20 + +* fix a severe bug on windows, where `readFile` may create a missing file, wrt [#14](https://github.com/hasufell/file-io/issues/14) +* fix a concurrency bug on windows with `readFile`, wrt [#15](https://github.com/hasufell/file-io/issues/15) +* make sure to set `ioe_filename` in `IOException` wrt [#17](https://github.com/hasufell/file-io/issues/17) +* Make `openFile` and friends exception safe wrt [#8](https://github.com/hasufell/file-io/issues/8) + ## 0.1.0.2 -- 2023-12-11 * support `os-string` package and newer `filepath` diff --git a/System/File/OsPath.hs b/System/File/OsPath.hs --- a/System/File/OsPath.hs +++ b/System/File/OsPath.hs @@ -1,10 +1,38 @@ -module System.File.OsPath where +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE BangPatterns #-} +module System.File.OsPath ( + openBinaryFile +, withFile +, withBinaryFile +, withFile' +, withBinaryFile' +, readFile +, readFile' +, writeFile +, writeFile' +, appendFile +, appendFile' +, openFile +, openExistingFile +) where + + import qualified System.File.Platform as P -import Control.Exception (bracket) -import System.IO (IOMode(..), Handle, hSetBinaryMode, hClose) -import System.OsPath +import Prelude ((.), ($), String, IO, ioError, pure, either, const, flip, Maybe(..), fmap, (<$>), id, Bool(..), FilePath, (++), return, show, (>>=)) +import GHC.IO (catchException) +import GHC.IO.Exception (IOException(..)) +import GHC.IO.Handle (hClose_help) +import GHC.IO.Handle.Internals (debugIO) +import GHC.IO.Handle.Types (Handle__, Handle(..)) +import Control.Concurrent.MVar +import Control.Monad (void, when) +import Control.DeepSeq (force) +import Control.Exception (SomeException, try, evaluate, mask, onException) +import System.IO (IOMode(..), hSetBinaryMode, hClose) +import System.IO.Unsafe (unsafePerformIO) +import System.OsPath as OSP import System.OsString.Internal.Types import qualified Data.ByteString as BS @@ -22,25 +50,21 @@ -- On POSIX systems, 'openBinaryFile' is an /interruptible operation/ as -- described in "Control.Exception". openBinaryFile :: OsPath -> IOMode -> IO Handle -openBinaryFile fp iomode = do - h <- openFile fp iomode - hSetBinaryMode h True - pure h +openBinaryFile osfp iomode = augmentError "openBinaryFile" osfp $ withOpenFile' osfp iomode True False pure False + -- | Run an action on a file. -- -- The 'Handle' is automatically closed afther the action. withFile :: OsPath -> IOMode -> (Handle -> IO r) -> IO r -withFile fp iomode action = bracket - (openFile fp iomode) - hClose - action +withFile osfp iomode act = (augmentError "withFile" osfp + $ withOpenFile' osfp iomode False False (try . act) True) + >>= either ioError pure withBinaryFile :: OsPath -> IOMode -> (Handle -> IO r) -> IO r -withBinaryFile fp iomode action = bracket - (openBinaryFile fp iomode) - hClose - action +withBinaryFile osfp iomode act = (augmentError "withBinaryFile" osfp + $ withOpenFile' osfp iomode True False (try . act) True) + >>= either ioError pure -- | Run an action on a file. -- @@ -48,15 +72,15 @@ -- with caution. withFile' :: OsPath -> IOMode -> (Handle -> IO r) -> IO r -withFile' fp iomode action = do - h <- openFile fp iomode - action h +withFile' osfp iomode act = (augmentError "withFile'" osfp + $ withOpenFile' osfp iomode False False (try . act) False) + >>= either ioError pure withBinaryFile' :: OsPath -> IOMode -> (Handle -> IO r) -> IO r -withBinaryFile' fp iomode action = do - h <- openBinaryFile fp iomode - action h +withBinaryFile' osfp iomode act = (augmentError "withBinaryFile'" osfp + $ withOpenFile' osfp iomode True False (try . act) False) + >>= either ioError pure -- | The 'readFile' function reads a file and returns the contents of the file -- as a 'ByteString'. The file is read lazily, on demand. @@ -93,8 +117,55 @@ -- | Open a file and return the 'Handle'. openFile :: OsPath -> IOMode -> IO Handle -openFile (OsString fp) = P.openFile fp +openFile osfp iomode = augmentError "openFile" osfp $ withOpenFile' osfp iomode False False pure False + -- | Open an existing file and return the 'Handle'. openExistingFile :: OsPath -> IOMode -> IO Handle -openExistingFile (OsString fp) = P.openExistingFile fp +openExistingFile osfp iomode = augmentError "openExistingFile" osfp $ withOpenFile' osfp iomode False True pure False + + +-- --------------------------------------------------------------------------- +-- Internals + +handleFinalizer :: FilePath -> MVar Handle__ -> IO () +handleFinalizer _fp m = do + handle_ <- takeMVar m + (handle_', _) <- hClose_help handle_ + putMVar m handle_' + return () + +type HandleFinalizer = FilePath -> MVar Handle__ -> IO () + +-- | Add a finalizer to a 'Handle'. Specifically, the finalizer +-- will be added to the 'MVar' of a file handle or the write-side +-- 'MVar' of a duplex handle. See Handle Finalizers for details. +addHandleFinalizer :: Handle -> HandleFinalizer -> IO () +addHandleFinalizer hndl finalizer = do + debugIO $ "Registering finalizer: " ++ show filepath + void $ mkWeakMVar mv (finalizer filepath mv) + where + !(filepath, !mv) = case hndl of + FileHandle fp m -> (fp, m) + DuplexHandle fp _ write_m -> (fp, write_m) + +withOpenFile' :: OsPath -> IOMode -> Bool -> Bool -> (Handle -> IO r) -> Bool -> IO r +withOpenFile' (OsString fp) iomode binary existing action close_finally = mask $ \restore -> do + hndl <- if existing + then P.openExistingFile fp iomode + else P.openFile fp iomode + addHandleFinalizer hndl handleFinalizer + when binary $ hSetBinaryMode hndl True + r <- restore (action hndl) `onException` hClose hndl + when close_finally $ hClose hndl + pure r + +addFilePathToIOError :: String -> OsPath -> IOException -> IOException +addFilePathToIOError fun fp ioe = unsafePerformIO $ do + fp' <- either (const (fmap OSP.toChar . OSP.unpack $ fp)) id <$> try @SomeException (OSP.decodeFS fp) + fp'' <- evaluate $ force fp' + pure $ ioe{ ioe_location = fun, ioe_filename = Just fp'' } + +augmentError :: String -> OsPath -> IO a -> IO a +augmentError str osfp = flip catchException (ioError . addFilePathToIOError str osfp) + 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.0.2 +version: 0.1.1 synopsis: Basic file IO operations via 'OsPath' description: Basic file IO operations like Prelude, but for 'OsPath'. homepage: https://github.com/hasufell/file-io @@ -12,6 +12,13 @@ category: System extra-source-files: CHANGELOG.md +tested-with: GHC==9.8.1, + GHC==9.4.8, + GHC==9.2.8, + GHC==9.0.2, + GHC==8.10.7, + GHC==8.8.4, + GHC==8.6.5 source-repository head type: git @@ -35,8 +42,9 @@ hs-source-dirs: . build-depends: - , base >=4.10 && <5 + , base >=4.12 && <5 , bytestring >=0.11.3.0 + , deepseq if flag(os-string) build-depends: filepath >= 1.5.0.0, os-string >= 2.0.0 @@ -50,3 +58,57 @@ other-modules: System.File.Platform ghc-options: -Wall + +test-suite T15 + hs-source-dirs: tests + main-is: T15.hs + type: exitcode-stdio-1.0 + default-language: Haskell2010 + build-depends: base, tasty, tasty-hunit, file-io, filepath, temporary + ghc-options: -Wall -threaded -rtsopts "-with-rtsopts=-N10" + if os(windows) + build-depends: Win32 >=2.13.3.0 + +test-suite T15Win + hs-source-dirs: tests + main-is: T15Win.hs + type: exitcode-stdio-1.0 + default-language: Haskell2010 + if os(windows) + build-depends: base, tasty, tasty-hunit, file-io, filepath, temporary, Win32 >=2.13.3.0 + else + build-depends: base + ghc-options: -Wall -threaded -rtsopts "-with-rtsopts=-N10" + +test-suite T14 + hs-source-dirs: tests + main-is: T14.hs + type: exitcode-stdio-1.0 + default-language: Haskell2010 + build-depends: base, file-io, filepath, temporary + ghc-options: -Wall + +test-suite T8 + hs-source-dirs: tests + main-is: T8.hs + type: exitcode-stdio-1.0 + default-language: Haskell2010 + build-depends: base, bytestring, file-io, filepath, temporary + ghc-options: -Wall -threaded + +test-suite CLC237 + hs-source-dirs: tests + main-is: CLC237.hs + type: exitcode-stdio-1.0 + default-language: Haskell2010 + build-depends: base, file-io, filepath, temporary + ghc-options: -Wall + +test-suite Properties + hs-source-dirs: tests + main-is: Properties.hs + type: exitcode-stdio-1.0 + default-language: Haskell2010 + build-depends: base, bytestring, tasty, tasty-hunit, file-io, filepath, temporary + ghc-options: -Wall -threaded -rtsopts "-with-rtsopts=-N10" + 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 @@ -1,17 +1,23 @@ +{-# LANGUAGE TypeApplications #-} + module System.File.Platform where +import Control.Exception (try, onException, SomeException) +import GHC.IO.Handle.FD (fdToHandle') import System.IO (IOMode(..), Handle) +import System.Posix.Types (Fd(..)) import System.Posix.IO.PosixString ( defaultFileFlags, - fdToHandle, openFd, + closeFd, OpenFileFlags(noctty, nonBlock, creat, append, trunc), OpenMode(ReadWrite, ReadOnly, WriteOnly) ) import System.OsPath.Posix ( PosixPath ) +import qualified System.OsPath.Posix as PS -- | Open a file and return the 'Handle'. openFile :: PosixPath -> IOMode -> IO Handle -openFile fp iomode = fdToHandle =<< case iomode of +openFile fp iomode = fdToHandle_ iomode fp =<< case iomode of ReadMode -> open ReadOnly df WriteMode -> open WriteOnly df { trunc = True, creat = Just 0o666 } AppendMode -> open WriteOnly df { append = True, creat = Just 0o666 } @@ -22,7 +28,7 @@ -- | Open an existing file and return the 'Handle'. openExistingFile :: PosixPath -> IOMode -> IO Handle -openExistingFile fp iomode = fdToHandle =<< case iomode of +openExistingFile fp iomode = fdToHandle_ iomode fp =<< case iomode of ReadMode -> open ReadOnly df WriteMode -> open WriteOnly df { trunc = True } AppendMode -> open WriteOnly df { append = True } @@ -30,3 +36,9 @@ where open = openFd fp df = defaultFileFlags { noctty = True, nonBlock = True, creat = Nothing } + +fdToHandle_ :: IOMode -> PosixPath -> Fd -> IO Handle +fdToHandle_ iomode fp (Fd fd) = (`onException` closeFd (Fd fd)) $ do + fp' <- either (const (fmap PS.toChar . PS.unpack $ fp)) id <$> try @SomeException (PS.decodeFS fp) + fdToHandle' fd Nothing False fp' iomode True + diff --git a/tests/CLC237.hs b/tests/CLC237.hs new file mode 100644 --- /dev/null +++ b/tests/CLC237.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Main where + +import Control.Exception +import System.OsPath ((), osp) +import qualified System.OsPath as OSP +import qualified System.File.OsPath as OSP +import GHC.IO.Exception (IOErrorType(..), IOException(..)) +import System.IO +import System.IO.Temp + +-- Test that the action in 'withFile' does not inherit the filepath annotation +-- See https://github.com/haskell/core-libraries-committee/issues/237 +main :: IO () +main = withSystemTempDirectory "tar-test" $ \baseDir' -> do + baseDir <- OSP.encodeFS baseDir' + res <- try @IOException $ OSP.withFile (baseDir [osp|foo|]) WriteMode $ \_ -> fail "test" + case res of + Left (IOError Nothing UserError "" "test" Nothing Nothing) -> pure () + Left e -> print e >> fail "Unexpected error" + Right _ -> fail "Unexpected success" + diff --git a/tests/Properties.hs b/tests/Properties.hs new file mode 100644 --- /dev/null +++ b/tests/Properties.hs @@ -0,0 +1,251 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import Control.Exception +import qualified System.FilePath as FP +import Test.Tasty +import Test.Tasty.HUnit +import System.OsPath ((), osp) +import qualified System.OsPath as OSP +import qualified System.File.OsPath as OSP +import GHC.IO.Exception (IOErrorType(..), IOException(..)) +import System.IO +import System.IO.Temp +import qualified Data.ByteString as BS + + +main :: IO () +main = defaultMain $ testGroup "All" + [ testGroup "System.File.OsPath" + [ testCase "readFile . writeFile" writeFileReadFile + , testCase "readFile . writeFile . writeFile" writeWriteFileReadFile + , testCase "readFile . appendFile . writeFile" appendFileReadFile + , testCase "iomode: ReadFile does not allow write" iomodeReadFile + , testCase "iomode: WriteFile does not allow read" iomodeWriteFile + , testCase "iomode: AppendMode does not allow read" iomodeAppendFile + , testCase "iomode: ReadWriteMode does allow everything" iomodeAppendFile + , testCase "concurrency: open multiple handles (read and write)" concFile + , testCase "concurrency: open multiple handles (read and read)" concFile2 + , testCase "concurrency: open multiple handles (write and write)" concFile3 + , testCase "openExistingFile no (Read)" existingFile + , testCase "openExistingFile no (Write)" existingFile2 + , testCase "openExistingFile no (Append)" existingFile3 + , testCase "openExistingFile no (ReadWrite)" existingFile4 + , testCase "openExistingFile yes (Read)" existingFile' + , testCase "openExistingFile yes (Write)" existingFile2' + , testCase "openExistingFile yes (Append)" existingFile3' + , testCase "openExistingFile yes (ReadWrite)" existingFile4' + ] + ] + +writeFileReadFile :: Assertion +writeFileReadFile = do + withSystemTempDirectory "test" $ \baseDir' -> do + baseDir <- OSP.encodeFS baseDir' + OSP.writeFile (baseDir [osp|foo|]) "test" + contents <- OSP.readFile (baseDir [osp|foo|]) + "test" @=? contents + +writeWriteFileReadFile :: Assertion +writeWriteFileReadFile = do + withSystemTempDirectory "test" $ \baseDir' -> do + baseDir <- OSP.encodeFS baseDir' + OSP.writeFile (baseDir [osp|foo|]) "lol" + OSP.writeFile (baseDir [osp|foo|]) "test" + contents <- OSP.readFile (baseDir [osp|foo|]) + "test" @=? contents + +appendFileReadFile :: Assertion +appendFileReadFile = do + withSystemTempDirectory "test" $ \baseDir' -> do + baseDir <- OSP.encodeFS baseDir' + OSP.writeFile (baseDir [osp|foo|]) "test" + OSP.appendFile (baseDir [osp|foo|]) "test" + contents <- OSP.readFile (baseDir [osp|foo|]) + "testtest" @=? contents + +iomodeReadFile :: Assertion +iomodeReadFile = do + withSystemTempDirectory "test" $ \baseDir' -> do + baseDir <- OSP.encodeFS baseDir' + OSP.writeFile (baseDir [osp|foo|]) "" + r <- try @IOException $ OSP.withFile (baseDir [osp|foo|]) ReadMode $ \h -> BS.hPut h "test" + IOError Nothing IllegalOperation "hPutBuf" "handle is not open for writing" Nothing (Just $ baseDir' FP. "foo") + @==? r + +iomodeWriteFile :: Assertion +iomodeWriteFile = do + withSystemTempDirectory "test" $ \baseDir' -> do + baseDir <- OSP.encodeFS baseDir' + OSP.writeFile (baseDir [osp|foo|]) "" + r <- try @IOException $ OSP.withFile (baseDir [osp|foo|]) WriteMode $ \h -> BS.hGetContents h + IOError Nothing IllegalOperation "hGetBuf" "handle is not open for reading" Nothing (Just $ baseDir' FP. "foo") + @==? r + +iomodeAppendFile :: Assertion +iomodeAppendFile = do + withSystemTempDirectory "test" $ \baseDir' -> do + baseDir <- OSP.encodeFS baseDir' + OSP.writeFile (baseDir [osp|foo|]) "" + r <- try @IOException $ OSP.withFile (baseDir [osp|foo|]) AppendMode $ \h -> BS.hGetContents h + IOError Nothing IllegalOperation "hGetBuf" "handle is not open for reading" Nothing (Just $ baseDir' FP. "foo") + @==? r + +iomodeReadWriteFile :: Assertion +iomodeReadWriteFile = do + withSystemTempDirectory "test" $ \baseDir' -> do + baseDir <- OSP.encodeFS baseDir' + OSP.writeFile (baseDir [osp|foo|]) "" + r <- try @IOException $ OSP.withFile (baseDir [osp|foo|]) ReadWriteMode $ \h -> do + BS.hPut h "test" + BS.hGetContents h + Right "testtest" @=? r + +concFile :: Assertion +concFile = do + withSystemTempDirectory "test" $ \baseDir' -> do + baseDir <- OSP.encodeFS baseDir' + let fp = baseDir [osp|foo|] + OSP.writeFile fp "" + _ <- OSP.openFile fp ReadMode + r <- try @IOException $ OSP.withFile fp WriteMode $ \h' -> do BS.hPut h' "test" + IOError Nothing fileLockedType "withFile" fileLockedMsg Nothing (Just $ baseDir' FP. "foo") @==? r + +concFile2 :: Assertion +concFile2 = do + withSystemTempDirectory "test" $ \baseDir' -> do + baseDir <- OSP.encodeFS baseDir' + let fp = baseDir [osp|foo|] + OSP.writeFile fp "h" + _ <- OSP.openFile fp ReadMode + r <- try @IOException $ OSP.withFile fp ReadMode BS.hGetContents + Right "h" @=? r + +concFile3 :: Assertion +concFile3 = do + withSystemTempDirectory "test" $ \baseDir' -> do + baseDir <- OSP.encodeFS baseDir' + let fp = baseDir [osp|foo|] + OSP.writeFile fp "" + _ <- OSP.openFile fp WriteMode + r <- try @IOException $ OSP.withFile fp WriteMode (flip BS.hPut "test") + IOError Nothing fileLockedType "withFile" fileLockedMsg Nothing (Just $ baseDir' FP. "foo") @==? r + +existingFile :: Assertion +existingFile = do + withSystemTempDirectory "test" $ \baseDir' -> do + baseDir <- OSP.encodeFS baseDir' + let fp = baseDir [osp|foo|] + r <- try @IOException $ OSP.openExistingFile fp ReadMode + IOError Nothing NoSuchThing "openExistingFile" noSuchFileMsg Nothing (Just $ baseDir' FP. "foo") @==? r + +existingFile2 :: Assertion +existingFile2 = do + withSystemTempDirectory "test" $ \baseDir' -> do + baseDir <- OSP.encodeFS baseDir' + let fp = baseDir [osp|foo|] + r <- try @IOException $ OSP.openExistingFile fp WriteMode + IOError Nothing NoSuchThing "openExistingFile" noSuchFileMsg Nothing (Just $ baseDir' FP. "foo") @==? r + +existingFile3 :: Assertion +existingFile3 = do + withSystemTempDirectory "test" $ \baseDir' -> do + baseDir <- OSP.encodeFS baseDir' + let fp = baseDir [osp|foo|] + r <- try @IOException $ OSP.openExistingFile fp AppendMode + IOError Nothing NoSuchThing "openExistingFile" noSuchFileMsg Nothing (Just $ baseDir' FP. "foo") @==? r + +existingFile4 :: Assertion +existingFile4 = do + withSystemTempDirectory "test" $ \baseDir' -> do + baseDir <- OSP.encodeFS baseDir' + let fp = baseDir [osp|foo|] + r <- try @IOException $ OSP.openExistingFile fp AppendMode + IOError Nothing NoSuchThing "openExistingFile" noSuchFileMsg Nothing (Just $ baseDir' FP. "foo") @==? r + +existingFile' :: Assertion +existingFile' = do + withSystemTempDirectory "test" $ \baseDir' -> do + baseDir <- OSP.encodeFS baseDir' + let fp = baseDir [osp|foo|] + OSP.writeFile fp "test" + r <- try @IOException $ (OSP.openExistingFile fp ReadMode >>= BS.hGetContents) + Right "test" @=? r + +existingFile2' :: Assertion +existingFile2' = do + withSystemTempDirectory "test" $ \baseDir' -> do + baseDir <- OSP.encodeFS baseDir' + let fp = baseDir [osp|foo|] + OSP.writeFile fp "test" + r <- try @IOException $ do + OSP.openExistingFile fp WriteMode >>= \h -> BS.hPut h "boo" >> hClose h + OSP.readFile (baseDir [osp|foo|]) + Right "boo" @=? r + +existingFile3' :: Assertion +existingFile3' = do + withSystemTempDirectory "test" $ \baseDir' -> do + baseDir <- OSP.encodeFS baseDir' + let fp = baseDir [osp|foo|] + OSP.writeFile fp "test" + r <- try @IOException $ do + OSP.openExistingFile fp AppendMode >>= \h -> BS.hPut h "boo" >> hClose h + OSP.readFile (baseDir [osp|foo|]) + Right "testboo" @=? r + +existingFile4' :: Assertion +existingFile4' = do + withSystemTempDirectory "test" $ \baseDir' -> do + baseDir <- OSP.encodeFS baseDir' + let fp = baseDir [osp|foo|] + OSP.writeFile fp "testx" + r <- try @IOException $ + OSP.openExistingFile fp ReadWriteMode >>= \h -> do + hSetBuffering h NoBuffering + BS.hPut h "boo" + c <- BS.hGetSome h 5 + hSeek h AbsoluteSeek 0 + c' <- BS.hGetSome h 5 + pure (c, c') + Right ("tx", "bootx") @=? r + + +compareIOError :: forall a . (Eq a, Show a, HasCallStack) => IOException -> Either IOException a -> Assertion +compareIOError el (Left lel) = lel { ioe_handle = Nothing + , ioe_errno = Nothing + } @?= + el { ioe_handle = Nothing + , ioe_errno = Nothing + } +compareIOError el (Right rel) = Right rel @?= (Left el :: Either IOException a) + +(@==?) :: forall a . (Eq a, Show a, HasCallStack) => IOException -> Either IOException a -> Assertion +(@==?) = compareIOError + +noSuchFileMsg :: String +#if defined(mingw32_HOST_OS) || defined(__MINGW32__) +noSuchFileMsg = "The system cannot find the file specified." +#else +noSuchFileMsg = "No such file or directory" +#endif + +fileLockedMsg :: String +#if defined(mingw32_HOST_OS) || defined(__MINGW32__) +fileLockedMsg = "The process cannot access the file because it is being used by another process." +#else +fileLockedMsg = "file is locked" +#endif + +fileLockedType :: IOErrorType +#if defined(mingw32_HOST_OS) || defined(__MINGW32__) +fileLockedType = PermissionDenied +#else +fileLockedType = ResourceBusy +#endif + diff --git a/tests/T14.hs b/tests/T14.hs new file mode 100644 --- /dev/null +++ b/tests/T14.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Main where + +import Control.Exception +import System.OsPath ((), osp) +import qualified System.OsPath as OSP +import qualified System.File.OsPath as OSP +import System.IO.Temp + +-- Test that 'readFile' does not create a file +-- https://github.com/hasufell/file-io/issues/14 +main :: IO () +main = withSystemTempDirectory "tar-test" $ \baseDir' -> do + baseDir <- OSP.encodeFS baseDir' + res <- try @SomeException $ OSP.readFile (baseDir [osp|foo|]) + case res of + Left e -> print e >> return () + Right _ -> fail "Unexpectedly found file 'foo'" + diff --git a/tests/T15.hs b/tests/T15.hs new file mode 100644 --- /dev/null +++ b/tests/T15.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Test.Tasty +import Test.Tasty.HUnit +import System.OsPath ((), osp) +import qualified System.OsPath as OSP +import qualified System.File.OsPath as OSP +import System.IO +import System.IO.Temp + +-- Test that we can read concurrently without file lock +-- https://github.com/hasufell/file-io/issues/15 +main :: IO () +main = withSystemTempDirectory "tar-test" $ \baseDir' -> do + baseDir <- OSP.encodeFS baseDir' + OSP.writeFile (baseDir [osp|foo|]) "" + defaultMain $ testGroup "All" + [ testGroup "System.File.OsPath" + $ map (\i -> testCase ("foo " <> show i) (OSP.openFile (baseDir [osp|foo|]) ReadMode >>= hClose)) ([0..99] :: [Int]) + ] + diff --git a/tests/T15Win.hs b/tests/T15Win.hs new file mode 100644 --- /dev/null +++ b/tests/T15Win.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +#if defined(mingw32_HOST_OS) || defined(__MINGW32__) + +import Test.Tasty +import Test.Tasty.HUnit +import qualified System.File.PlatformPath as PFP +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 + +import qualified System.Win32 as Win32 +import qualified System.Win32.WindowsString.File as WS +import Control.Monad (when, void) +#if defined(__IO_MANAGER_WINIO__) +import GHC.IO.SubSystem +#endif + +-- Test that we can read concurrently without file lock +-- https://github.com/hasufell/file-io/issues/15 +main :: IO () +main = withSystemTempDirectory "tar-test" $ \baseDir' -> do + baseDir <- WS.encodeFS baseDir' + PFP.writeFile (baseDir WS. [pstr|foo|]) "" + defaultMain $ testGroup "All" + [ testGroup "System.File.OsPath (Windows)" $ + (map (\i -> testCase ("foo (Win32 API) " <> show i) (openFile32 (baseDir WS. [pstr|foo|]) ReadMode >>= Win32.closeHandle)) ([0..99] :: [Int])) + ] + +openFile32 :: WindowsPath -> IOMode -> IO Win32.HANDLE +openFile32 fp iomode = + WS.createFile + fp + Win32.gENERIC_READ + Win32.fILE_SHARE_READ + Nothing + Win32.oPEN_EXISTING +#if defined(__IO_MANAGER_WINIO__) + (case ioSubSystem of + IoPOSIX -> Win32.fILE_ATTRIBUTE_NORMAL + IoNative -> Win32.fILE_ATTRIBUTE_NORMAL .|. Win32.fILE_FLAG_OVERLAPPED + ) +#else + Win32.fILE_ATTRIBUTE_NORMAL +#endif + Nothing + +#else + +main :: IO () +main = putStrLn "Skipping test on windows" + +#endif + diff --git a/tests/T8.hs b/tests/T8.hs new file mode 100644 --- /dev/null +++ b/tests/T8.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Main where + +import Control.Concurrent +import Control.Monad +import System.File.OsPath +import System.OsPath +import System.IO.Temp + +import qualified Data.ByteString.Lazy as BL +import qualified System.OsPath as OSP +import qualified System.File.OsPath as OSP + +main :: IO () +main = withSystemTempDirectory "test" $ \baseDir' -> do + let fn = [osp|test.txt|] + baseDir <- OSP.encodeFS baseDir' + let fp = baseDir OSP. fn + OSP.writeFile fp "" + + replicateM_ 100000 $ do + thr <- forkIO (System.File.OsPath.readFile fp >>= BL.putStr) + threadDelay 1 + void $ killThread thr diff --git a/windows/System/File/Platform.hs b/windows/System/File/Platform.hs deleted file mode 100644 --- a/windows/System/File/Platform.hs +++ /dev/null @@ -1,111 +0,0 @@ -{-# LANGUAGE CPP #-} - -module System.File.Platform where - -import Control.Exception (bracketOnError) -import Data.Bits -import System.IO (IOMode(..), Handle) -import System.OsPath.Windows ( WindowsPath ) - -import qualified System.Win32 as Win32 -import qualified System.Win32.WindowsString.File as WS -import Control.Monad (when, void) -#if defined(__IO_MANAGER_WINIO__) -import GHC.IO.SubSystem -#endif - --- | Open a file and return the 'Handle'. -openFile :: WindowsPath -> IOMode -> IO Handle -openFile fp iomode = bracketOnError - (WS.createFile - fp - accessMode - shareMode - Nothing - createMode -#if defined(__IO_MANAGER_WINIO__) - (case ioSubSystem of - IoPOSIX -> Win32.fILE_ATTRIBUTE_NORMAL - IoNative -> Win32.fILE_ATTRIBUTE_NORMAL .|. Win32.fILE_FLAG_OVERLAPPED - ) -#else - Win32.fILE_ATTRIBUTE_NORMAL -#endif - Nothing) - Win32.closeHandle - toHandle - where - toHandle h = do - when (iomode == AppendMode ) $ void $ Win32.setFilePointerEx h 0 Win32.fILE_END - Win32.hANDLEToHandle h - accessMode = case iomode of - ReadMode -> Win32.gENERIC_READ - WriteMode -> Win32.gENERIC_WRITE - AppendMode -> Win32.gENERIC_WRITE .|. Win32.fILE_APPEND_DATA - ReadWriteMode -> Win32.gENERIC_READ .|. Win32.gENERIC_WRITE - - createMode = case iomode of - ReadMode -> Win32.oPEN_ALWAYS - WriteMode -> Win32.cREATE_ALWAYS - AppendMode -> Win32.oPEN_ALWAYS - ReadWriteMode -> Win32.oPEN_ALWAYS - - shareMode = case iomode of - ReadMode -> maxShareMode - WriteMode -> writeShareMode - AppendMode -> writeShareMode - ReadWriteMode -> maxShareMode - -maxShareMode :: Win32.ShareMode -maxShareMode = - Win32.fILE_SHARE_DELETE .|. - Win32.fILE_SHARE_READ .|. - Win32.fILE_SHARE_WRITE - -writeShareMode :: Win32.ShareMode -writeShareMode = - Win32.fILE_SHARE_DELETE .|. - Win32.fILE_SHARE_READ - - -- | Open an existing file and return the 'Handle'. -openExistingFile :: WindowsPath -> IOMode -> IO Handle -openExistingFile fp iomode = bracketOnError - (WS.createFile - fp - accessMode - shareMode - Nothing - createMode -#if defined(__IO_MANAGER_WINIO__) - (case ioSubSystem of - IoPOSIX -> Win32.fILE_ATTRIBUTE_NORMAL - IoNative -> Win32.fILE_ATTRIBUTE_NORMAL .|. Win32.fILE_FLAG_OVERLAPPED - ) -#else - Win32.fILE_ATTRIBUTE_NORMAL -#endif - Nothing) - Win32.closeHandle - toHandle - where - toHandle h = do - when (iomode == AppendMode ) $ void $ Win32.setFilePointerEx h 0 Win32.fILE_END - Win32.hANDLEToHandle h - accessMode = case iomode of - ReadMode -> Win32.gENERIC_READ - WriteMode -> Win32.gENERIC_WRITE - AppendMode -> Win32.gENERIC_WRITE .|. Win32.fILE_APPEND_DATA - ReadWriteMode -> Win32.gENERIC_READ .|. Win32.gENERIC_WRITE - - createMode = case iomode of - ReadMode -> Win32.oPEN_EXISTING - WriteMode -> Win32.tRUNCATE_EXISTING - AppendMode -> Win32.oPEN_EXISTING - ReadWriteMode -> Win32.oPEN_EXISTING - - shareMode = case iomode of - ReadMode -> maxShareMode - WriteMode -> writeShareMode - AppendMode -> writeShareMode - ReadWriteMode -> maxShareMode - diff --git a/windows/System/File/Platform.hsc b/windows/System/File/Platform.hsc new file mode 100644 --- /dev/null +++ b/windows/System/File/Platform.hsc @@ -0,0 +1,131 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeApplications #-} + +module System.File.Platform where + +import Control.Exception (bracketOnError, try, SomeException, onException) +import Data.Bits +import System.IO (IOMode(..), Handle) +import System.OsPath.Windows ( WindowsPath ) +import qualified System.OsPath.Windows as WS +import Foreign.C.Types +import Foreign.Ptr (ptrToIntPtr) + +import qualified System.Win32 as Win32 +import qualified System.Win32.WindowsString.File as WS +import Control.Monad (when, void) +#if defined(__IO_MANAGER_WINIO__) +import GHC.IO.SubSystem +#else +import GHC.IO.Handle.FD (fdToHandle') +#include +#endif + +-- | Open a file and return the 'Handle'. +openFile :: WindowsPath -> IOMode -> IO Handle +openFile fp iomode = bracketOnError + (WS.createFile + fp + accessMode + shareMode + Nothing + createMode +#if defined(__IO_MANAGER_WINIO__) + (case ioSubSystem of + IoPOSIX -> Win32.fILE_ATTRIBUTE_NORMAL + IoNative -> Win32.fILE_ATTRIBUTE_NORMAL .|. Win32.fILE_FLAG_OVERLAPPED + ) +#else + Win32.fILE_ATTRIBUTE_NORMAL +#endif + Nothing) + Win32.closeHandle + toHandle + where +#if defined(__IO_MANAGER_WINIO__) + toHandle h = (`onException` Win32.closeHandle h) $ do + when (iomode == AppendMode ) $ void $ Win32.setFilePointerEx h 0 Win32.fILE_END + Win32.hANDLEToHandle h +#else + toHandle h = (`onException` Win32.closeHandle h) $ do + 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 +#endif + accessMode = case iomode of + ReadMode -> Win32.gENERIC_READ + WriteMode -> Win32.gENERIC_WRITE + AppendMode -> Win32.gENERIC_WRITE .|. Win32.fILE_APPEND_DATA + ReadWriteMode -> Win32.gENERIC_READ .|. Win32.gENERIC_WRITE + + createMode = case iomode of + ReadMode -> Win32.oPEN_EXISTING + WriteMode -> Win32.cREATE_ALWAYS + AppendMode -> Win32.oPEN_ALWAYS + ReadWriteMode -> Win32.oPEN_ALWAYS + + shareMode = case iomode of + ReadMode -> Win32.fILE_SHARE_READ + WriteMode -> writeShareMode + AppendMode -> writeShareMode + ReadWriteMode -> maxShareMode + +maxShareMode :: Win32.ShareMode +maxShareMode = + Win32.fILE_SHARE_DELETE .|. + Win32.fILE_SHARE_READ .|. + Win32.fILE_SHARE_WRITE + +writeShareMode :: Win32.ShareMode +writeShareMode = + Win32.fILE_SHARE_DELETE .|. + Win32.fILE_SHARE_READ + + -- | Open an existing file and return the 'Handle'. +openExistingFile :: WindowsPath -> IOMode -> IO Handle +openExistingFile fp iomode = bracketOnError + (WS.createFile + fp + accessMode + shareMode + Nothing + createMode +#if defined(__IO_MANAGER_WINIO__) + (case ioSubSystem of + IoPOSIX -> Win32.fILE_ATTRIBUTE_NORMAL + IoNative -> Win32.fILE_ATTRIBUTE_NORMAL .|. Win32.fILE_FLAG_OVERLAPPED + ) +#else + Win32.fILE_ATTRIBUTE_NORMAL +#endif + Nothing) + Win32.closeHandle + toHandle + where + toHandle h = do + when (iomode == AppendMode ) $ void $ Win32.setFilePointerEx h 0 Win32.fILE_END + Win32.hANDLEToHandle h + accessMode = case iomode of + ReadMode -> Win32.gENERIC_READ + WriteMode -> Win32.gENERIC_WRITE + AppendMode -> Win32.gENERIC_WRITE .|. Win32.fILE_APPEND_DATA + ReadWriteMode -> Win32.gENERIC_READ .|. Win32.gENERIC_WRITE + + createMode = case iomode of + ReadMode -> Win32.oPEN_EXISTING + WriteMode -> Win32.tRUNCATE_EXISTING + AppendMode -> Win32.oPEN_EXISTING + ReadWriteMode -> Win32.oPEN_EXISTING + + shareMode = case iomode of + ReadMode -> Win32.fILE_SHARE_READ + WriteMode -> writeShareMode + AppendMode -> writeShareMode + ReadWriteMode -> maxShareMode + +#if !defined(__IO_MANAGER_WINIO__) +foreign import ccall "_open_osfhandle" + _open_osfhandle :: CIntPtr -> CInt -> IO CInt +#endif +