Skip to content

Commit

Permalink
Merge branch 'issue-8'
Browse files Browse the repository at this point in the history
  • Loading branch information
hasufell committed Jan 20, 2024
2 parents b176eb5 + 01c64df commit d67931c
Show file tree
Hide file tree
Showing 5 changed files with 102 additions and 31 deletions.
88 changes: 62 additions & 26 deletions System/File/OsPath.hs
Original file line number Diff line number Diff line change
@@ -1,4 +1,5 @@
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE BangPatterns #-}

module System.File.OsPath (
openBinaryFile
Expand All @@ -16,16 +17,21 @@ module System.File.OsPath (
, openExistingFile
) where


import qualified System.File.Platform as P

import Prelude ((.), ($), String, IO, pure, either, const, flip, Maybe(..), fmap, (<$>), id, ioError, (=<<), Bool(..))
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, bracket)
import System.IO (IOMode(..), Handle)
import Control.Exception (SomeException, try, evaluate, mask, onException)
import System.IO (IOMode(..), hSetBinaryMode, hClose)
import System.IO.Unsafe (unsafePerformIO)
import System.IO (hSetBinaryMode, hClose)
import System.OsPath as OSP
import System.OsString.Internal.Types

Expand All @@ -44,44 +50,37 @@ import qualified Data.ByteString.Lazy as BSL
-- On POSIX systems, 'openBinaryFile' is an /interruptible operation/ as
-- described in "Control.Exception".
openBinaryFile :: OsPath -> IOMode -> IO Handle
openBinaryFile osfp iomode = augmentError "openBinaryFile" osfp $ openBinaryFile' osfp iomode
openBinaryFile osfp iomode = augmentError "openBinaryFile" osfp $ withOpenFile' osfp iomode True False pure False

openBinaryFile' :: OsPath -> IOMode -> IO Handle
openBinaryFile' (OsString fp) iomode =do
h <- P.openFile fp iomode
hSetBinaryMode h True
pure h

-- | Run an action on a file.
--
-- The 'Handle' is automatically closed afther the action.
withFile :: OsPath -> IOMode -> (Handle -> IO r) -> IO r
withFile osfp@(OsString fp) iomode action = either ioError pure =<< (augmentError "withFile" osfp $ bracket
(P.openFile fp iomode)
hClose
(try . 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 osfp iomode action = either ioError pure =<< (augmentError "withBinaryFile" osfp $ bracket
(openBinaryFile' osfp iomode)
hClose
(try . 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.
--
-- The 'Handle' is not automatically closed to allow lazy IO. Use this
-- with caution.
withFile'
:: OsPath -> IOMode -> (Handle -> IO r) -> IO r
withFile' osfp@(OsString fp) iomode action = either ioError pure =<< (augmentError "withFile'" osfp $ do
h <- P.openFile fp iomode
try . 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 = either ioError pure =<< (augmentError "withBinaryFile'" fp $ do
h <- openBinaryFile' fp iomode
try . 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.
Expand Down Expand Up @@ -118,11 +117,48 @@ appendFile' fp contents = withFile fp AppendMode (`BS.hPut` contents)

-- | Open a file and return the 'Handle'.
openFile :: OsPath -> IOMode -> IO Handle
openFile osfp@(OsString fp) = augmentError "openFile" osfp . 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 osfp@(OsString fp) = augmentError "openExistingFile" osfp . 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
Expand Down
8 changes: 8 additions & 0 deletions file-io.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -88,6 +88,14 @@ test-suite T14
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
Expand Down
5 changes: 3 additions & 2 deletions posix/System/File/Platform.hs
Original file line number Diff line number Diff line change
Expand Up @@ -2,13 +2,14 @@

module System.File.Platform where

import Control.Exception (try, SomeException)
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,
openFd,
closeFd,
OpenFileFlags(noctty, nonBlock, creat, append, trunc),
OpenMode(ReadWrite, ReadOnly, WriteOnly) )
import System.OsPath.Posix ( PosixPath )
Expand Down Expand Up @@ -37,7 +38,7 @@ openExistingFile fp iomode = fdToHandle_ iomode fp =<< case iomode of
df = defaultFileFlags { noctty = True, nonBlock = True, creat = Nothing }

fdToHandle_ :: IOMode -> PosixPath -> Fd -> IO Handle
fdToHandle_ iomode fp (Fd fd) = do
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

26 changes: 26 additions & 0 deletions tests/T8.hs
Original file line number Diff line number Diff line change
@@ -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
6 changes: 3 additions & 3 deletions windows/System/File/Platform.hsc
Original file line number Diff line number Diff line change
Expand Up @@ -3,7 +3,7 @@

module System.File.Platform where

import Control.Exception (bracketOnError, try, SomeException)
import Control.Exception (bracketOnError, try, SomeException, onException)
import Data.Bits
import System.IO (IOMode(..), Handle)
import System.OsPath.Windows ( WindowsPath )
Expand Down Expand Up @@ -43,11 +43,11 @@ openFile fp iomode = bracketOnError
toHandle
where
#if defined(__IO_MANAGER_WINIO__)
toHandle h = do
toHandle h = (`onException` Win32.closeHandle h) $ do
when (iomode == AppendMode ) $ void $ Win32.setFilePointerEx h 0 Win32.fILE_END
Win32.hANDLEToHandle h
#else
toHandle h = do
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)
Expand Down

0 comments on commit d67931c

Please sign in to comment.