From 06ba5178f8516e64e6d5574e79e584b7047a2382 Mon Sep 17 00:00:00 2001 From: Adithya Kumar Date: Mon, 14 Oct 2024 18:46:42 +0530 Subject: [PATCH 1/9] Add File internals that work directly with Path --- .../Internal/FileSystem/File/Utils.hs | 93 +++ .../Streamly/Internal/FileSystem/FileIO.hs | 679 ++++++++++++++++++ .../Internal/FileSystem/Windows/File.hs | 194 +++++ core/streamly-core.cabal | 3 + 4 files changed, 969 insertions(+) create mode 100644 core/src/Streamly/Internal/FileSystem/File/Utils.hs create mode 100644 core/src/Streamly/Internal/FileSystem/FileIO.hs create mode 100644 core/src/Streamly/Internal/FileSystem/Windows/File.hs diff --git a/core/src/Streamly/Internal/FileSystem/File/Utils.hs b/core/src/Streamly/Internal/FileSystem/File/Utils.hs new file mode 100644 index 0000000000..8365572bda --- /dev/null +++ b/core/src/Streamly/Internal/FileSystem/File/Utils.hs @@ -0,0 +1,93 @@ +module Streamly.Internal.FileSystem.File.Utils + ( openFile + , withFile + ) where + +------------------------------------------------------------------------------- +-- Imports +------------------------------------------------------------------------------- + +import Control.Exception (mask, onException, try) +import Control.Monad (when) +import GHC.IO (catchException, unsafePerformIO) +import GHC.IO.Exception (IOException(..)) +import GHC.IO.Handle.Internals (handleFinalizer) +import Streamly.Internal.FileSystem.Path (Path) +import System.IO (IOMode(..), Handle, hSetBinaryMode, hClose) + +#if defined(mingw32_HOST_OS) || defined(__MINGW32__) +import qualified Streamly.Internal.FileSystem.Windows.File as Platform +#else +import qualified Streamly.Internal.FileSystem.Posix.File as Platform +#endif + +import qualified Streamly.Internal.FileSystem.Path as Path + +#if MIN_VERSION_base(4,16,0) +import GHC.IO.Handle.Internals (addHandleFinalizer) +#else +import Control.Concurrent.MVar (MVar, addMVarFinalizer) +import GHC.IO.Handle.Internals (debugIO) +import GHC.IO.Handle.Types (Handle__, Handle(..)) +#endif + +------------------------------------------------------------------------------- +-- Utils +------------------------------------------------------------------------------- + +#if !(MIN_VERSION_base(4,16,0)) +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 handle finalizer = do + debugIO $ "Registering finalizer: " ++ show filepath + addMVarFinalizer mv (finalizer filepath mv) + where + !(filepath, !mv) = case handle of + FileHandle fp m -> (fp, m) + DuplexHandle fp _ write_m -> (fp, write_m) +#endif + +addFilePathToIOError :: String -> Path -> IOException -> IOException +addFilePathToIOError fun fp ioe = unsafePerformIO $ do + let fp' = Path.toString fp + -- XXX Why is this important? + -- deepseq will be introduced dependency because of this + -- fp'' <- evaluate $ force fp' + pure $ ioe{ ioe_location = fun, ioe_filename = Just fp' } + +augmentError :: String -> Path -> IO a -> IO a +augmentError str osfp = flip catchException (ioError . addFilePathToIOError str osfp) + +withOpenFile' + :: Path + -> IOMode -> Bool -> Bool -> Bool + -> (Handle -> IO r) -> Bool -> IO r +withOpenFile' fp iomode binary existing cloExec action close_finally = + mask $ \restore -> do + hndl <- case (existing, cloExec) of + (True, False) -> Platform.openExistingFile fp iomode + (False, False) -> Platform.openFile fp iomode + (True, True) -> Platform.openExistingFileWithCloseOnExec fp iomode + (False, True) -> Platform.openFileWithCloseOnExec fp iomode + addHandleFinalizer hndl handleFinalizer + when binary $ hSetBinaryMode hndl True + r <- restore (action hndl) `onException` hClose hndl + when close_finally $ hClose hndl + pure r + +-- | Open a file and return the 'Handle'. +openFile :: Path -> IOMode -> IO Handle +openFile osfp iomode = + augmentError "openFile" osfp $ withOpenFile' osfp iomode False False False pure False + +-- | Run an action on a file. +-- +-- The 'Handle' is automatically closed afther the action. +withFile :: Path -> IOMode -> (Handle -> IO r) -> IO r +withFile osfp iomode act = (augmentError "withFile" osfp + $ withOpenFile' osfp iomode False False False (try . act) True) + >>= either ioError pure diff --git a/core/src/Streamly/Internal/FileSystem/FileIO.hs b/core/src/Streamly/Internal/FileSystem/FileIO.hs new file mode 100644 index 0000000000..fb7456b9d7 --- /dev/null +++ b/core/src/Streamly/Internal/FileSystem/FileIO.hs @@ -0,0 +1,679 @@ +#include "inline.hs" + +-- | +-- Module : Streamly.Internal.FileSystem.FileIO +-- Copyright : (c) 2019 Composewell Technologies +-- +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Portability : GHC +-- +-- Read and write streams and arrays to and from files specified by their paths +-- in the file system. Unlike the handle based APIs which can have a read/write +-- session consisting of multiple reads and writes to the handle, these APIs +-- are one shot read or write APIs. These APIs open the file handle, perform +-- the requested operation and close the handle. Thease are safer compared to +-- the handle based APIs as there is no possibility of a file descriptor +-- leakage. +-- +-- > import qualified Streamly.Internal.FileSystem.FileIO as File +-- + +module Streamly.Internal.FileSystem.FileIO + ( + -- * Streaming IO + -- | Stream data to or from a file or device sequentially. When reading, + -- the stream is lazy and generated on-demand as the consumer consumes it. + -- Read IO requests to the IO device are performed in chunks limited to a + -- maximum size of 32KiB, this is referred to as @defaultChunkSize@ in the + -- documentation. One IO request may or may not read the full + -- chunk. If the whole stream is not consumed, it is possible that we may + -- read slightly more from the IO device than what the consumer needed. + -- Unless specified otherwise in the API, writes are collected into chunks + -- of @defaultChunkSize@ before they are written to the IO device. + + -- Streaming APIs work for all kind of devices, seekable or non-seekable; + -- including disks, files, memory devices, terminals, pipes, sockets and + -- fifos. While random access APIs work only for files or devices that have + -- random access or seek capability for example disks, memory devices. + -- Devices like terminals, pipes, sockets and fifos do not have random + -- access capability. + + -- ** File IO Using Handle + withFile + + -- ** Streams + , read + , readChunksWith + , readChunks + + -- ** Unfolds + , readerWith + , reader + -- , readShared + -- , readUtf8 + -- , readLines + -- , readFrames + , chunkReaderWith + , chunkReaderFromToWith + , chunkReader + + -- ** Write To File + , putChunk -- writeChunk? + + -- ** Folds + , write + -- , writeUtf8 + -- , writeUtf8ByLines + -- , writeByFrames + , writeWith + , writeChunks + + -- ** Writing Streams + , fromBytes -- putBytes? + , fromBytesWith + , fromChunks + + -- ** Append To File + , writeAppend + , writeAppendWith + -- , appendShared + , writeAppendArray + , writeAppendChunks + + -- * Deprecated + , readWithBufferOf + , readChunksWithBufferOf + , readChunksFromToWith + , toBytes + , toChunks + , toChunksWithBufferOf + , writeWithBufferOf + , fromBytesWithBufferOf + ) +where + +import Control.Monad.Catch (MonadCatch) +import Control.Monad.IO.Class (MonadIO(..)) +import Data.Word (Word8) +import System.IO (Handle, IOMode(..), hClose) +import Prelude hiding (read) + +import qualified Control.Monad.Catch as MC + +import Streamly.Data.Fold (groupsOf, drain) +import Streamly.Internal.Data.Array.Type (Array(..)) +import Streamly.Internal.Data.Fold.Type (Fold(..)) +import Streamly.Data.Stream (Stream) +import Streamly.Internal.Data.Unfold.Type (Unfold(..)) +-- import Streamly.String (encodeUtf8, decodeUtf8, foldLines) +import Streamly.Internal.System.IO (defaultChunkSize) +import Streamly.Internal.FileSystem.Path (Path) + +import qualified Streamly.Internal.Data.Array as A +import qualified Streamly.Data.Stream as S +import qualified Streamly.Data.Unfold as UF +import qualified Streamly.Internal.Data.Array.Type as IA (pinnedChunksOf) +import qualified Streamly.Internal.Data.Unfold as UF (bracketIO) +import qualified Streamly.Internal.Data.Fold.Type as FL + (Step(..), snoc, reduce) +import qualified Streamly.Internal.FileSystem.Handle as FH +import qualified Streamly.Internal.FileSystem.File.Utils as FU + +------------------------------------------------------------------------------- +-- References +------------------------------------------------------------------------------- +-- +-- The following references may be useful to build an understanding about the +-- file API design: +-- +-- http://www.linux-mag.com/id/308/ for blocking/non-blocking IO on linux. +-- https://lwn.net/Articles/612483/ Non-blocking buffered file read operations +-- https://en.wikipedia.org/wiki/C_file_input/output for C APIs. +-- https://docs.oracle.com/javase/tutorial/essential/io/file.html for Java API. +-- https://www.w3.org/TR/FileAPI/ for http file API. + +------------------------------------------------------------------------------- +-- Safe file reading +------------------------------------------------------------------------------- + +-- | @'withFile' name mode act@ opens a file using 'openFile' and passes +-- the resulting handle to the computation @act@. The handle will be +-- closed on exit from 'withFile', whether by normal termination or by +-- raising an exception. If closing the handle raises an exception, then +-- this exception will be raised by 'withFile' rather than any exception +-- raised by 'act'. +-- +-- /Pre-release/ +-- +{-# INLINE withFile #-} +withFile :: (MonadIO m, MonadCatch m) + => Path -> IOMode -> (Handle -> Stream m a) -> Stream m a +withFile file mode = S.bracketIO (FU.openFile file mode) hClose + +-- | Transform an 'Unfold' from a 'Handle' to an unfold from a 'Path'. The +-- resulting unfold opens a handle in 'ReadMode', uses it using the supplied +-- unfold and then makes sure that the handle is closed on normal termination +-- or in case of an exception. If closing the handle raises an exception, then +-- this exception will be raised by 'usingFile'. +-- +-- /Pre-release/ +-- +{-# INLINE usingFile #-} +usingFile :: (MonadIO m, MonadCatch m) + => Unfold m Handle a -> Unfold m Path a +usingFile = UF.bracketIO (`FU.openFile` ReadMode) hClose + +{-# INLINE usingFile2 #-} +usingFile2 :: (MonadIO m, MonadCatch m) + => Unfold m (x, Handle) a -> Unfold m (x, Path) a +usingFile2 = UF.bracketIO before after + + where + + before (x, file) = do + h <- FU.openFile file ReadMode + return (x, h) + + after (_, h) = hClose h + +{-# INLINE usingFile3 #-} +usingFile3 :: (MonadIO m, MonadCatch m) + => Unfold m (x, y, z, Handle) a -> Unfold m (x, y, z, Path) a +usingFile3 = UF.bracketIO before after + + where + + before (x, y, z, file) = do + h <- FU.openFile file ReadMode + return (x, y, z, h) + + after (_, _, _, h) = hClose h + +------------------------------------------------------------------------------- +-- Array IO (Input) +------------------------------------------------------------------------------- + +-- TODO readArrayOf + +------------------------------------------------------------------------------- +-- Array IO (output) +------------------------------------------------------------------------------- + +-- | Write an array to a file. Overwrites the file if it exists. +-- +-- /Pre-release/ +-- +{-# INLINABLE putChunk #-} +putChunk :: Path -> Array a -> IO () +putChunk file arr = FU.withFile file WriteMode (`FH.putChunk` arr) + +-- | append an array to a file. +-- +-- /Pre-release/ +-- +{-# INLINABLE writeAppendArray #-} +writeAppendArray :: Path -> Array a -> IO () +writeAppendArray file arr = FU.withFile file AppendMode (`FH.putChunk` arr) + +------------------------------------------------------------------------------- +-- Stream of Arrays IO +------------------------------------------------------------------------------- + +-- | @readChunksWith size file@ reads a stream of arrays from file @file@. +-- The maximum size of a single array is specified by @size@. The actual size +-- read may be less than or equal to @size@. +-- +-- /Pre-release/ +-- +{-# INLINE readChunksWith #-} +readChunksWith :: (MonadIO m, MonadCatch m) + => Int -> Path -> Stream m (Array Word8) +readChunksWith size file = + withFile file ReadMode (FH.readChunksWith size) + +{-# DEPRECATED toChunksWithBufferOf "Please use 'readChunksWith' instead" #-} +{-# INLINE toChunksWithBufferOf #-} +toChunksWithBufferOf :: (MonadIO m, MonadCatch m) + => Int -> Path -> Stream m (Array Word8) +toChunksWithBufferOf = readChunksWith + +-- XXX read 'Array a' instead of Word8 +-- +-- | @readChunks file@ reads a stream of arrays from file @file@. +-- The maximum size of a single array is limited to @defaultChunkSize@. The +-- actual size read may be less than @defaultChunkSize@. +-- +-- > readChunks = readChunksWith defaultChunkSize +-- +-- /Pre-release/ +-- +{-# INLINE readChunks #-} +readChunks :: (MonadIO m, MonadCatch m) + => Path -> Stream m (Array Word8) +readChunks = readChunksWith defaultChunkSize + +{-# DEPRECATED toChunks "Please use 'readChunks' instead" #-} +{-# INLINE toChunks #-} +toChunks :: (MonadIO m, MonadCatch m) => Path -> Stream m (Array Word8) +toChunks = readChunks + +------------------------------------------------------------------------------- +-- Read File to Stream +------------------------------------------------------------------------------- + +-- TODO for concurrent streams implement readahead IO. We can send multiple +-- read requests at the same time. For serial case we can use async IO. We can +-- also control the read throughput in mbps or IOPS. + +-- | Unfold the tuple @(bufsize, filepath)@ into a stream of 'Word8' arrays. +-- Read requests to the IO device are performed using a buffer of size +-- @bufsize@. The size of an array in the resulting stream is always less than +-- or equal to @bufsize@. +-- +-- /Pre-release/ +-- +{-# INLINE chunkReaderWith #-} +chunkReaderWith :: (MonadIO m, MonadCatch m) + => Unfold m (Int, Path) (Array Word8) +chunkReaderWith = usingFile2 FH.chunkReaderWith + +{-# DEPRECATED readChunksWithBufferOf + "Please use 'chunkReaderWith' instead" #-} +{-# INLINE readChunksWithBufferOf #-} +readChunksWithBufferOf :: (MonadIO m, MonadCatch m) + => Unfold m (Int, Path) (Array Word8) +readChunksWithBufferOf = chunkReaderWith + +-- | Unfold the tuple @(from, to, bufsize, filepath)@ into a stream +-- of 'Word8' arrays. +-- Read requests to the IO device are performed using a buffer of size +-- @bufsize@ starting from absolute offset of @from@ till the absolute +-- position of @to@. The size of an array in the resulting stream is always +-- less than or equal to @bufsize@. +-- +-- /Pre-release/ +{-# INLINE chunkReaderFromToWith #-} +chunkReaderFromToWith :: (MonadIO m, MonadCatch m) => + Unfold m (Int, Int, Int, Path) (Array Word8) +chunkReaderFromToWith = usingFile3 FH.chunkReaderFromToWith + +{-# DEPRECATED readChunksFromToWith + "Please use 'chunkReaderFromToWith' instead" #-} +{-# INLINE readChunksFromToWith #-} +readChunksFromToWith :: (MonadIO m, MonadCatch m) => + Unfold m (Int, Int, Int, Path) (Array Word8) +readChunksFromToWith = chunkReaderFromToWith + +-- | Unfolds a 'Path' into a stream of 'Word8' arrays. Requests to the IO +-- device are performed using a buffer of size +-- 'Streamly.Internal.Data.Array.Type.defaultChunkSize'. The +-- size of arrays in the resulting stream are therefore less than or equal to +-- 'Streamly.Internal.Data.Array.Type.defaultChunkSize'. +-- +-- /Pre-release/ +{-# INLINE chunkReader #-} +chunkReader :: (MonadIO m, MonadCatch m) => Unfold m Path (Array Word8) +chunkReader = usingFile FH.chunkReader + +-- | Unfolds the tuple @(bufsize, filepath)@ into a byte stream, read requests +-- to the IO device are performed using buffers of @bufsize@. +-- +-- /Pre-release/ +{-# INLINE readerWith #-} +readerWith :: (MonadIO m, MonadCatch m) => Unfold m (Int, Path) Word8 +readerWith = usingFile2 FH.readerWith + +{-# DEPRECATED readWithBufferOf "Please use 'readerWith' instead" #-} +{-# INLINE readWithBufferOf #-} +readWithBufferOf :: (MonadIO m, MonadCatch m) => + Unfold m (Int, Path) Word8 +readWithBufferOf = readerWith + +-- | Unfolds a file path into a byte stream. IO requests to the device are +-- performed in sizes of +-- 'Streamly.Internal.Data.Array.Type.defaultChunkSize'. +-- +-- /Pre-release/ +{-# INLINE reader #-} +reader :: (MonadIO m, MonadCatch m) => Unfold m Path Word8 +reader = UF.unfoldEach A.reader (usingFile FH.chunkReader) + +-- | Generate a stream of bytes from a file specified by path. The stream ends +-- when EOF is encountered. File is locked using multiple reader and single +-- writer locking mode. +-- +-- /Pre-release/ +-- +{-# INLINE read #-} +read :: (MonadIO m, MonadCatch m) => Path -> Stream m Word8 +read file = A.concat $ withFile file ReadMode FH.readChunks + +{-# DEPRECATED toBytes "Please use 'read' instead" #-} +{-# INLINE toBytes #-} +toBytes :: (MonadIO m, MonadCatch m) => Path -> Stream m Word8 +toBytes = read + +{- +-- | Generate a stream of elements of the given type from a file 'Handle'. The +-- stream ends when EOF is encountered. File is not locked for exclusive reads, +-- writers can keep writing to the file. +-- +-- @since 0.7.0 +{-# INLINE readShared #-} +readShared :: MonadIO m => Handle -> Stream m Word8 +readShared = undefined +-} + +------------------------------------------------------------------------------- +-- Writing +------------------------------------------------------------------------------- + +{-# INLINE fromChunksMode #-} +fromChunksMode :: (MonadIO m, MonadCatch m) + => IOMode -> Path -> Stream m (Array a) -> m () +fromChunksMode mode file xs = S.fold drain $ + withFile file mode (\h -> S.mapM (FH.putChunk h) xs) + +-- | Write a stream of arrays to a file. Overwrites the file if it exists. +-- +-- /Pre-release/ +-- +{-# INLINE fromChunks #-} +fromChunks :: (MonadIO m, MonadCatch m) + => Path -> Stream m (Array a) -> m () +fromChunks = fromChunksMode WriteMode + +-- GHC buffer size dEFAULT_FD_BUFFER_SIZE=8192 bytes. +-- +-- XXX test this +-- Note that if you use a chunk size less than 8K (GHC's default buffer +-- size) then you are advised to use 'NOBuffering' mode on the 'Handle' in case you +-- do not want buffering to occur at GHC level as well. Same thing applies to +-- writes as well. + +-- | Like 'write' but provides control over the write buffer. Output will +-- be written to the IO device as soon as we collect the specified number of +-- input elements. +-- +-- /Pre-release/ +-- +{-# INLINE fromBytesWith #-} +fromBytesWith :: (MonadIO m, MonadCatch m) + => Int -> Path -> Stream m Word8 -> m () +fromBytesWith n file xs = fromChunks file $ IA.pinnedChunksOf n xs + +{-# DEPRECATED fromBytesWithBufferOf "Please use 'fromBytesWith' instead" #-} +{-# INLINE fromBytesWithBufferOf #-} +fromBytesWithBufferOf :: (MonadIO m, MonadCatch m) + => Int -> Path -> Stream m Word8 -> m () +fromBytesWithBufferOf = fromBytesWith + +-- > write = 'writeWith' defaultChunkSize +-- +-- | Write a byte stream to a file. Combines the bytes in chunks of size +-- up to 'A.defaultChunkSize' before writing. If the file exists it is +-- truncated to zero size before writing. If the file does not exist it is +-- created. File is locked using single writer locking mode. +-- +-- /Pre-release/ +{-# INLINE fromBytes #-} +fromBytes :: (MonadIO m, MonadCatch m) => Path -> Stream m Word8 -> m () +fromBytes = fromBytesWith defaultChunkSize + +{- +{-# INLINE write #-} +write :: (MonadIO m, Storable a) => Handle -> Stream m a -> m () +write = toHandleWith A.defaultChunkSize +-} + +-- | Write a stream of chunks to a handle. Each chunk in the stream is written +-- to the device as a separate IO request. +-- +-- /Pre-release/ +{-# INLINE writeChunks #-} +writeChunks :: (MonadIO m, MonadCatch m) + => Path -> Fold m (Array a) () +writeChunks path = Fold step initial extract final + where + initial = do + h <- liftIO (FU.openFile path WriteMode) + fld <- FL.reduce (FH.writeChunks h) + `MC.onException` liftIO (hClose h) + return $ FL.Partial (fld, h) + step (fld, h) x = do + r <- FL.snoc fld x `MC.onException` liftIO (hClose h) + return $ FL.Partial (r, h) + + extract _ = return () + + final (Fold _ initial1 _ final1, h) = do + liftIO $ hClose h + res <- initial1 + case res of + FL.Partial fs -> final1 fs + FL.Done () -> return () + +-- | @writeWith chunkSize handle@ writes the input stream to @handle@. +-- Bytes in the input stream are collected into a buffer until we have a chunk +-- of size @chunkSize@ and then written to the IO device. +-- +-- /Pre-release/ +{-# INLINE writeWith #-} +writeWith :: (MonadIO m, MonadCatch m) + => Int -> Path -> Fold m Word8 () +writeWith n path = + groupsOf n (A.unsafePinnedCreateOf n) (writeChunks path) + +{-# DEPRECATED writeWithBufferOf "Please use 'writeWith' instead" #-} +{-# INLINE writeWithBufferOf #-} +writeWithBufferOf :: (MonadIO m, MonadCatch m) + => Int -> Path -> Fold m Word8 () +writeWithBufferOf = writeWith + +-- > write = 'writeWith' A.defaultChunkSize +-- +-- | Write a byte stream to a file. Accumulates the input in chunks of up to +-- 'Streamly.Internal.Data.Array.Type.defaultChunkSize' before writing to +-- the IO device. +-- +-- /Pre-release/ +-- +{-# INLINE write #-} +write :: (MonadIO m, MonadCatch m) => Path -> Fold m Word8 () +write = writeWith defaultChunkSize + +-- | Append a stream of arrays to a file. +-- +-- /Pre-release/ +-- +{-# INLINE writeAppendChunks #-} +writeAppendChunks :: (MonadIO m, MonadCatch m) + => Path -> Stream m (Array a) -> m () +writeAppendChunks = fromChunksMode AppendMode + +-- | Like 'append' but provides control over the write buffer. Output will +-- be written to the IO device as soon as we collect the specified number of +-- input elements. +-- +-- /Pre-release/ +-- +{-# INLINE writeAppendWith #-} +writeAppendWith :: (MonadIO m, MonadCatch m) + => Int -> Path -> Stream m Word8 -> m () +writeAppendWith n file xs = + writeAppendChunks file $ IA.pinnedChunksOf n xs + +-- | Append a byte stream to a file. Combines the bytes in chunks of size up to +-- 'A.defaultChunkSize' before writing. If the file exists then the new data +-- is appended to the file. If the file does not exist it is created. File is +-- locked using single writer locking mode. +-- +-- /Pre-release/ +-- +{-# INLINE writeAppend #-} +writeAppend :: (MonadIO m, MonadCatch m) => Path -> Stream m Word8 -> m () +writeAppend = writeAppendWith defaultChunkSize + +{- +-- | Like 'append' but the file is not locked for exclusive writes. +-- +-- @since 0.7.0 +{-# INLINE appendShared #-} +appendShared :: MonadIO m => Handle -> Stream m Word8 -> m () +appendShared = undefined +-} + +------------------------------------------------------------------------------- +-- IO with encoding/decoding Unicode characters +------------------------------------------------------------------------------- + +{- +-- | +-- > readUtf8 = decodeUtf8 . read +-- +-- Read a UTF8 encoded stream of unicode characters from a file handle. +-- +-- @since 0.7.0 +{-# INLINE readUtf8 #-} +readUtf8 :: MonadIO m => Handle -> Stream m Char +readUtf8 = decodeUtf8 . read + +-- | +-- > writeUtf8 h s = write h $ encodeUtf8 s +-- +-- Encode a stream of unicode characters to UTF8 and write it to the given file +-- handle. Default block buffering applies to the writes. +-- +-- @since 0.7.0 +{-# INLINE writeUtf8 #-} +writeUtf8 :: MonadIO m => Handle -> Stream m Char -> m () +writeUtf8 h s = write h $ encodeUtf8 s + +-- | Write a stream of unicode characters after encoding to UTF-8 in chunks +-- separated by a linefeed character @'\n'@. If the size of the buffer exceeds +-- @defaultChunkSize@ and a linefeed is not yet found, the buffer is written +-- anyway. This is similar to writing to a 'Handle' with the 'LineBuffering' +-- option. +-- +-- @since 0.7.0 +{-# INLINE writeUtf8ByLines #-} +writeUtf8ByLines :: MonadIO m => Handle -> Stream m Char -> m () +writeUtf8ByLines = undefined + +-- | Read UTF-8 lines from a file handle and apply the specified fold to each +-- line. This is similar to reading a 'Handle' with the 'LineBuffering' option. +-- +-- @since 0.7.0 +{-# INLINE readLines #-} +readLines :: MonadIO m => Handle -> Fold m Char b -> Stream m b +readLines h f = foldLines (readUtf8 h) f + +------------------------------------------------------------------------------- +-- Framing on a sequence +------------------------------------------------------------------------------- + +-- | Read a stream from a file handle and split it into frames delimited by +-- the specified sequence of elements. The supplied fold is applied on each +-- frame. +-- +-- @since 0.7.0 +{-# INLINE readFrames #-} +readFrames :: (MonadIO m, Storable a) + => Array a -> Handle -> Fold m a b -> Stream m b +readFrames = undefined -- foldFrames . read + +-- | Write a stream to the given file handle buffering up to frames separated +-- by the given sequence or up to a maximum of @defaultChunkSize@. +-- +-- @since 0.7.0 +{-# INLINE writeByFrames #-} +writeByFrames :: (MonadIO m, Storable a) + => Array a -> Handle -> Stream m a -> m () +writeByFrames = undefined + +------------------------------------------------------------------------------- +-- Random Access IO (Seek) +------------------------------------------------------------------------------- + +-- XXX handles could be shared, so we may not want to use the handle state at +-- all for these APIs. we can use pread and pwrite instead. On windows we will +-- need to use readFile/writeFile with an offset argument. + +------------------------------------------------------------------------------- + +-- | Read the element at the given index treating the file as an array. +-- +-- @since 0.7.0 +{-# INLINE readIndex #-} +readIndex :: Storable a => Handle -> Int -> Maybe a +readIndex arr i = undefined + +-- NOTE: To represent a range to read we have chosen (start, size) instead of +-- (start, end). This helps in removing the ambiguity of whether "end" is +-- included in the range or not. +-- +-- We could avoid specifying the range to be read and instead use "take size" +-- on the stream, but it may end up reading more and then consume it partially. + +-- | @readSliceWith chunkSize handle pos len@ reads up to @len@ bytes +-- from @handle@ starting at the offset @pos@ from the beginning of the file. +-- +-- Reads are performed in chunks of size @chunkSize@. For block devices, to +-- avoid reading partial blocks @chunkSize@ must align with the block size of +-- the underlying device. If the underlying block size is unknown, it is a good +-- idea to keep it a multiple 4KiB. This API ensures that the start of each +-- chunk is aligned with @chunkSize@ from second chunk onwards. +-- +{-# INLINE readSliceWith #-} +readSliceWith :: (MonadIO m, Storable a) + => Int -> Handle -> Int -> Int -> Stream m a +readSliceWith chunkSize h pos len = undefined + +-- | @readSlice h i count@ streams a slice from the file handle @h@ starting +-- at index @i@ and reading up to @count@ elements in the forward direction +-- ending at the index @i + count - 1@. +-- +-- @since 0.7.0 +{-# INLINE readSlice #-} +readSlice :: (MonadIO m, Storable a) + => Handle -> Int -> Int -> Stream m a +readSlice = readSliceWith defaultChunkSize + +-- | @readSliceRev h i count@ streams a slice from the file handle @h@ starting +-- at index @i@ and reading up to @count@ elements in the reverse direction +-- ending at the index @i - count + 1@. +-- +-- @since 0.7.0 +{-# INLINE readSliceRev #-} +readSliceRev :: (MonadIO m, Storable a) + => Handle -> Int -> Int -> Stream m a +readSliceRev h i count = undefined + +-- | Write the given element at the given index in the file. +-- +-- @since 0.7.0 +{-# INLINE writeIndex #-} +writeIndex :: (MonadIO m, Storable a) => Handle -> Int -> a -> m () +writeIndex h i a = undefined + +-- | @writeSlice h i count stream@ writes a stream to the file handle @h@ +-- starting at index @i@ and writing up to @count@ elements in the forward +-- direction ending at the index @i + count - 1@. +-- +-- @since 0.7.0 +{-# INLINE writeSlice #-} +writeSlice :: (Monad m, Storable a) + => Handle -> Int -> Int -> Stream m a -> m () +writeSlice h i len s = undefined + +-- | @writeSliceRev h i count stream@ writes a stream to the file handle @h@ +-- starting at index @i@ and writing up to @count@ elements in the reverse +-- direction ending at the index @i - count + 1@. +-- +-- @since 0.7.0 +{-# INLINE writeSliceRev #-} +writeSliceRev :: (Monad m, Storable a) + => Handle -> Int -> Int -> Stream m a -> m () +writeSliceRev arr i len s = undefined +-} diff --git a/core/src/Streamly/Internal/FileSystem/Windows/File.hs b/core/src/Streamly/Internal/FileSystem/Windows/File.hs new file mode 100644 index 0000000000..343a40c23b --- /dev/null +++ b/core/src/Streamly/Internal/FileSystem/Windows/File.hs @@ -0,0 +1,194 @@ +module Streamly.Internal.FileSystem.Windows.File + ( openExistingFile + , openFile + , openExistingFileWithCloseOnExec + , openFileWithCloseOnExec + ) where + +------------------------------------------------------------------------------- +-- Imports +------------------------------------------------------------------------------- + +import Control.Exception (bracketOnError, try, SomeException, onException) +import Data.Bits +import System.IO (IOMode(..), Handle) +import Foreign.C.Types +import System.Win32 as Win32 +import Control.Monad (when, void) +import Streamly.Internal.FileSystem.WindowsPath (WindowsPath) + +import System.Win32.Types + +#if defined(__IO_MANAGER_WINIO__) +import GHC.IO.SubSystem +#else +import GHC.IO.Handle.FD (fdToHandle') +#include +#endif + +import Foreign.C.String +import Foreign.Ptr +import Foreign.Marshal.Alloc +import Foreign.Storable + +import qualified Streamly.Internal.FileSystem.WindowsPath as Path + +#include "windows_cconv.h" + +------------------------------------------------------------------------------- +-- Windows +------------------------------------------------------------------------------- + +foreign import WINDOWS_CCONV unsafe "windows.h CreateFileW" + c_CreateFile :: LPCTSTR -> AccessMode -> ShareMode -> LPSECURITY_ATTRIBUTES -> CreateMode -> FileAttributeOrFlag -> HANDLE -> IO HANDLE + + +-- | like failIf, but retried on sharing violations. This is necessary for many +-- file operations; see +-- https://www.betaarchive.com/wiki/index.php/Microsoft_KB_Archive/316609 +-- +failIfWithRetry :: (a -> Bool) -> String -> IO a -> IO a +failIfWithRetry cond msg action = retryOrFail retries + where + delay = 100*1000 -- in ms, we use threadDelay + + retries = 20 :: Int + -- KB article recommends 250/5 + + + -- retryOrFail :: Int -> IO a + + retryOrFail times + | times <= 0 = errorWin msg + | otherwise = do + ret <- action + if not (cond ret) + then return ret + else do + err_code <- getLastError + if err_code == (32) + then do threadDelay delay; retryOrFail (times - 1) + else errorWin msg + +withFilePath :: WindowsPath -> (LPTSTR -> IO a) -> IO a +withFilePath p act = + Array.unsafePinnedAsPtr (Path.toChunk p) $ \ptr _ -> act (castPtr ptr) + +createFile :: WindowsPath -> AccessMode -> ShareMode -> Maybe LPSECURITY_ATTRIBUTES -> CreateMode -> FileAttributeOrFlag -> Maybe HANDLE -> IO HANDLE +createFile name access share mb_attr mode flag mb_h = + withFilePath name $ \ c_name -> + failIfWithRetry (==iNVALID_HANDLE_VALUE) (unwords ["CreateFile",show name]) $ + c_CreateFile c_name access share (maybePtr mb_attr) mode flag (maybePtr mb_h) + +-- | Open a file and return the 'Handle'. +openFile :: WindowsPath -> IOMode -> IO Handle +openFile fp iomode = bracketOnError + (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 fp iomode) + where + 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 + (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 fp iomode) + where + 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 + +openFileWithCloseOnExec :: WindowsPath -> IOMode -> IO Handle +openFileWithCloseOnExec = openFile + +openExistingFileWithCloseOnExec :: WindowsPath -> IOMode -> IO Handle +openExistingFileWithCloseOnExec = openExistingFile + +toHandle :: WindowsPath -> IOMode -> Win32.HANDLE -> IO Handle +#if defined(__IO_MANAGER_WINIO__) +toHandle _ iomode h = (`onException` Win32.closeHandle h) $ do + when (iomode == AppendMode ) $ void $ Win32.setFilePointerEx h 0 Win32.fILE_END + Win32.hANDLEToHandle h +#else +toHandle fp iomode 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) + fdToHandle' fd Nothing False (Path.toString fp) iomode True +#endif diff --git a/core/streamly-core.cabal b/core/streamly-core.cabal index f014276b4a..fa5446ac15 100644 --- a/core/streamly-core.cabal +++ b/core/streamly-core.cabal @@ -426,6 +426,8 @@ library , Streamly.Internal.FileSystem.Handle , Streamly.Internal.FileSystem.File + , Streamly.Internal.FileSystem.FileIO + , Streamly.Internal.FileSystem.File.Utils , Streamly.Internal.FileSystem.DirIO , Streamly.Internal.FileSystem.Posix.Errno , Streamly.Internal.FileSystem.Posix.File @@ -596,3 +598,4 @@ library if os(windows) build-depends: Win32 >= 2.6 && < 2.14 + exposed-modules: Streamly.Internal.FileSystem.Windows.File From ec693575bc301a60801ddae9c2c9cdbd9f3c7bf0 Mon Sep 17 00:00:00 2001 From: Adithya Kumar Date: Mon, 4 Nov 2024 17:00:24 +0530 Subject: [PATCH 2/9] Use the new File functions with Path in the Handle testsuite --- test/Streamly/Test/FileSystem/Handle.hs | 19 +++++++++++++------ 1 file changed, 13 insertions(+), 6 deletions(-) diff --git a/test/Streamly/Test/FileSystem/Handle.hs b/test/Streamly/Test/FileSystem/Handle.hs index 3209baa946..fb0efd4fc8 100644 --- a/test/Streamly/Test/FileSystem/Handle.hs +++ b/test/Streamly/Test/FileSystem/Handle.hs @@ -20,21 +20,28 @@ import System.IO , hClose , hFlush , hSeek - , openFile + , hPutStr ) import System.IO.Temp (withSystemTempDirectory) +import Streamly.Internal.FileSystem.File.Utils (openFile, withFile) import Test.QuickCheck (Property, forAll, Gen, vectorOf, choose) import Test.QuickCheck.Monadic (monadicIO, assert, run) +import Streamly.Internal.FileSystem.Path (Path) import qualified Streamly.Data.Fold as Fold import qualified Streamly.Internal.FileSystem.Handle as Handle import qualified Streamly.Internal.Data.Stream as Stream import qualified Streamly.Internal.Data.Array as Array import qualified Streamly.Internal.Unicode.Stream as Unicode +import qualified Streamly.Internal.FileSystem.Path as Path +import Prelude hiding (writeFile) import Test.Hspec as H import Test.Hspec.QuickCheck +writeFile :: Path -> String -> IO () +writeFile fpath val = withFile fpath WriteMode (`hPutStr` val) + maxArrLen :: Int maxArrLen = defaultChunkSize * 8 @@ -63,7 +70,7 @@ testBinData = "01234567890123456789012345678901234567890123456789" executor :: (Handle -> Stream IO Char) -> IO (Stream IO Char) executor f = withSystemTempDirectory "fs_handle" $ \fp -> do - let fpath = fp "tmp_read.txt" + fpath <- Path.fromString $ fp "tmp_read.txt" writeFile fpath testDataLarge h <- openFile fpath ReadMode return $ f h @@ -115,7 +122,7 @@ testWrite hfold = go list = withSystemTempDirectory "fs_handle" $ \fp -> do - let fpathWrite = fp "tmp_write.txt" + fpathWrite <- Path.fromString $ fp "tmp_write.txt" writeFile fpathWrite "" h <- openFile fpathWrite ReadWriteMode hSeek h AbsoluteSeek 0 @@ -136,8 +143,8 @@ testWriteWithChunk = go = withSystemTempDirectory "fs_handle" $ \fp -> do - let fpathRead = fp "tmp_read.txt" - fpathWrite = fp "tmp_write.txt" + fpathRead <- Path.fromString $ fp "tmp_read.txt" + fpathWrite <- Path.fromString $ fp "tmp_write.txt" writeFile fpathRead testDataLarge writeFile fpathWrite "" hr <- openFile fpathRead ReadMode @@ -158,7 +165,7 @@ testReadChunksFromToWith from to buffSize res = monadicIO $ run go go = withSystemTempDirectory "fs_handle" $ \fp -> do - let fpathRead = fp "tmp_read.txt" + fpathRead <- Path.fromString $ fp "tmp_read.txt" writeFile fpathRead testBinData h <- openFile fpathRead ReadMode ls <- From 7b8bf7d0dcd41cc9f690d51c489308ea92a73979 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Mon, 20 Jan 2025 10:18:48 +0530 Subject: [PATCH 3/9] Fix deprecated APIs in FileIO --- core/src/Streamly/Internal/FileSystem/FileIO.hs | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/core/src/Streamly/Internal/FileSystem/FileIO.hs b/core/src/Streamly/Internal/FileSystem/FileIO.hs index fb7456b9d7..106c50859c 100644 --- a/core/src/Streamly/Internal/FileSystem/FileIO.hs +++ b/core/src/Streamly/Internal/FileSystem/FileIO.hs @@ -1,5 +1,3 @@ -#include "inline.hs" - -- | -- Module : Streamly.Internal.FileSystem.FileIO -- Copyright : (c) 2019 Composewell Technologies @@ -113,13 +111,14 @@ import Streamly.Internal.FileSystem.Path (Path) import qualified Streamly.Internal.Data.Array as A import qualified Streamly.Data.Stream as S import qualified Streamly.Data.Unfold as UF -import qualified Streamly.Internal.Data.Array.Type as IA (pinnedChunksOf) import qualified Streamly.Internal.Data.Unfold as UF (bracketIO) import qualified Streamly.Internal.Data.Fold.Type as FL (Step(..), snoc, reduce) import qualified Streamly.Internal.FileSystem.Handle as FH import qualified Streamly.Internal.FileSystem.File.Utils as FU +#include "inline.hs" + ------------------------------------------------------------------------------- -- References ------------------------------------------------------------------------------- @@ -401,7 +400,7 @@ fromChunks = fromChunksMode WriteMode {-# INLINE fromBytesWith #-} fromBytesWith :: (MonadIO m, MonadCatch m) => Int -> Path -> Stream m Word8 -> m () -fromBytesWith n file xs = fromChunks file $ IA.pinnedChunksOf n xs +fromBytesWith n file xs = fromChunks file $ A.chunksOf' n xs {-# DEPRECATED fromBytesWithBufferOf "Please use 'fromBytesWith' instead" #-} {-# INLINE fromBytesWithBufferOf #-} @@ -463,7 +462,7 @@ writeChunks path = Fold step initial extract final writeWith :: (MonadIO m, MonadCatch m) => Int -> Path -> Fold m Word8 () writeWith n path = - groupsOf n (A.unsafePinnedCreateOf n) (writeChunks path) + groupsOf n (A.unsafeCreateOf' n) (writeChunks path) {-# DEPRECATED writeWithBufferOf "Please use 'writeWith' instead" #-} {-# INLINE writeWithBufferOf #-} @@ -502,7 +501,7 @@ writeAppendChunks = fromChunksMode AppendMode writeAppendWith :: (MonadIO m, MonadCatch m) => Int -> Path -> Stream m Word8 -> m () writeAppendWith n file xs = - writeAppendChunks file $ IA.pinnedChunksOf n xs + writeAppendChunks file $ A.chunksOf' n xs -- | Append a byte stream to a file. Combines the bytes in chunks of size up to -- 'A.defaultChunkSize' before writing. If the file exists then the new data From b60c43f07d3c83061ef6cbed70331e1feae6ad18 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Wed, 13 Nov 2024 19:04:27 +0530 Subject: [PATCH 4/9] Move Windows/File.hs to File.hsc --- .../Streamly/Internal/FileSystem/Windows/{File.hs => File.hsc} | 0 core/streamly-core.cabal | 2 +- 2 files changed, 1 insertion(+), 1 deletion(-) rename core/src/Streamly/Internal/FileSystem/Windows/{File.hs => File.hsc} (100%) diff --git a/core/src/Streamly/Internal/FileSystem/Windows/File.hs b/core/src/Streamly/Internal/FileSystem/Windows/File.hsc similarity index 100% rename from core/src/Streamly/Internal/FileSystem/Windows/File.hs rename to core/src/Streamly/Internal/FileSystem/Windows/File.hsc diff --git a/core/streamly-core.cabal b/core/streamly-core.cabal index fa5446ac15..f3beba92f5 100644 --- a/core/streamly-core.cabal +++ b/core/streamly-core.cabal @@ -433,6 +433,7 @@ library , Streamly.Internal.FileSystem.Posix.File , Streamly.Internal.FileSystem.Posix.ReadDir , Streamly.Internal.FileSystem.Windows.ReadDir + , Streamly.Internal.FileSystem.Windows.File -- RingArray Arrays , Streamly.Internal.Data.RingArray @@ -598,4 +599,3 @@ library if os(windows) build-depends: Win32 >= 2.6 && < 2.14 - exposed-modules: Streamly.Internal.FileSystem.Windows.File From 944b4c73bf496ffdbaa3d379cf7b2a5c0979dfd3 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Wed, 13 Nov 2024 15:18:40 +0530 Subject: [PATCH 5/9] Fix a bug, cleanup the Posix,Windows File modules Use asCWStringUnsafe to create a null terminated C string in windows module. Export openFile functions directly from the platform specific module and reverse the dependency on Utils module. --- .../Internal/FileSystem/File/Utils.hs | 98 +++--- .../Streamly/Internal/FileSystem/FileIO.hs | 20 +- .../Internal/FileSystem/Posix/File.hs | 134 +++++--- .../Internal/FileSystem/Posix/ReadDir.hsc | 15 +- .../Internal/FileSystem/Windows/File.hsc | 288 +++++++++--------- test/Streamly/Test/FileSystem/Handle.hs | 6 +- 6 files changed, 318 insertions(+), 243 deletions(-) diff --git a/core/src/Streamly/Internal/FileSystem/File/Utils.hs b/core/src/Streamly/Internal/FileSystem/File/Utils.hs index 8365572bda..89d7f3ab8a 100644 --- a/core/src/Streamly/Internal/FileSystem/File/Utils.hs +++ b/core/src/Streamly/Internal/FileSystem/File/Utils.hs @@ -1,6 +1,6 @@ module Streamly.Internal.FileSystem.File.Utils - ( openFile - , withFile + ( withFile + , openFile ) where ------------------------------------------------------------------------------- @@ -9,25 +9,18 @@ module Streamly.Internal.FileSystem.File.Utils import Control.Exception (mask, onException, try) import Control.Monad (when) -import GHC.IO (catchException, unsafePerformIO) +import GHC.IO (catchException) import GHC.IO.Exception (IOException(..)) import GHC.IO.Handle.Internals (handleFinalizer) import Streamly.Internal.FileSystem.Path (Path) import System.IO (IOMode(..), Handle, hSetBinaryMode, hClose) -#if defined(mingw32_HOST_OS) || defined(__MINGW32__) -import qualified Streamly.Internal.FileSystem.Windows.File as Platform -#else -import qualified Streamly.Internal.FileSystem.Posix.File as Platform -#endif - import qualified Streamly.Internal.FileSystem.Path as Path #if MIN_VERSION_base(4,16,0) import GHC.IO.Handle.Internals (addHandleFinalizer) #else import Control.Concurrent.MVar (MVar, addMVarFinalizer) -import GHC.IO.Handle.Internals (debugIO) import GHC.IO.Handle.Types (Handle__, Handle(..)) #endif @@ -43,7 +36,6 @@ type HandleFinalizer = FilePath -> MVar Handle__ -> IO () -- 'MVar' of a duplex handle. See Handle Finalizers for details. addHandleFinalizer :: Handle -> HandleFinalizer -> IO () addHandleFinalizer handle finalizer = do - debugIO $ "Registering finalizer: " ++ show filepath addMVarFinalizer mv (finalizer filepath mv) where !(filepath, !mv) = case handle of @@ -51,43 +43,55 @@ addHandleFinalizer handle finalizer = do DuplexHandle fp _ write_m -> (fp, write_m) #endif -addFilePathToIOError :: String -> Path -> IOException -> IOException -addFilePathToIOError fun fp ioe = unsafePerformIO $ do - let fp' = Path.toString fp - -- XXX Why is this important? - -- deepseq will be introduced dependency because of this - -- fp'' <- evaluate $ force fp' - pure $ ioe{ ioe_location = fun, ioe_filename = Just fp' } - -augmentError :: String -> Path -> IO a -> IO a -augmentError str osfp = flip catchException (ioError . addFilePathToIOError str osfp) - -withOpenFile' - :: Path - -> IOMode -> Bool -> Bool -> Bool - -> (Handle -> IO r) -> Bool -> IO r -withOpenFile' fp iomode binary existing cloExec action close_finally = +{-# INLINE withOpenFile #-} +withOpenFile + :: Bool + -> Bool + -> (Path -> IOMode -> IO Handle) + -> Path + -> IOMode + -> (Handle -> IO r) + -> IO r +withOpenFile binary close_finally f fp iomode action = mask $ \restore -> do - hndl <- case (existing, cloExec) of - (True, False) -> Platform.openExistingFile fp iomode - (False, False) -> Platform.openFile fp iomode - (True, True) -> Platform.openExistingFileWithCloseOnExec fp iomode - (False, True) -> Platform.openFileWithCloseOnExec fp iomode - addHandleFinalizer hndl handleFinalizer - when binary $ hSetBinaryMode hndl True - r <- restore (action hndl) `onException` hClose hndl - when close_finally $ hClose hndl + h <- f fp iomode + -- XXX In case of withFile it will be closed anyway, so do we even need + -- this? + addHandleFinalizer h handleFinalizer + when binary $ hSetBinaryMode h True + r <- restore (action h) `onException` hClose h + when close_finally $ hClose h pure r --- | Open a file and return the 'Handle'. -openFile :: Path -> IOMode -> IO Handle -openFile osfp iomode = - augmentError "openFile" osfp $ withOpenFile' osfp iomode False False False pure False +addFilePathToIOError :: String -> Path -> IOException -> IOException +addFilePathToIOError fun fp ioe = + let !str = Path.toString fp + in ioe + { ioe_location = fun + , ioe_filename = Just str + } + +{-# INLINE catchWith #-} +catchWith :: String -> Path -> IO a -> IO a +catchWith str path io = + catchException io (ioError . addFilePathToIOError str path) + +{-# INLINE withFile #-} +withFile :: + Bool + -> (Path -> IOMode -> IO Handle) + -> Path + -> IOMode + -> (Handle -> IO r) + -> IO r +withFile binary f path iomode act = + catchWith "withFile" path + (withOpenFile binary True f path iomode (try . act)) + >>= either ioError pure --- | Run an action on a file. --- --- The 'Handle' is automatically closed afther the action. -withFile :: Path -> IOMode -> (Handle -> IO r) -> IO r -withFile osfp iomode act = (augmentError "withFile" osfp - $ withOpenFile' osfp iomode False False False (try . act) True) - >>= either ioError pure +{-# INLINE openFile #-} +openFile :: + Bool -> (Path -> IOMode -> IO Handle) -> Path -> IOMode -> IO Handle +openFile binary f path iomode = + catchWith "openFile" path + $ withOpenFile binary False f path iomode pure diff --git a/core/src/Streamly/Internal/FileSystem/FileIO.hs b/core/src/Streamly/Internal/FileSystem/FileIO.hs index 106c50859c..816911ed7e 100644 --- a/core/src/Streamly/Internal/FileSystem/FileIO.hs +++ b/core/src/Streamly/Internal/FileSystem/FileIO.hs @@ -115,7 +115,11 @@ import qualified Streamly.Internal.Data.Unfold as UF (bracketIO) import qualified Streamly.Internal.Data.Fold.Type as FL (Step(..), snoc, reduce) import qualified Streamly.Internal.FileSystem.Handle as FH -import qualified Streamly.Internal.FileSystem.File.Utils as FU +#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) +import qualified Streamly.Internal.FileSystem.Posix.File as File +#else +import qualified Streamly.Internal.FileSystem.Windows.File as File +#endif #include "inline.hs" @@ -148,7 +152,7 @@ import qualified Streamly.Internal.FileSystem.File.Utils as FU {-# INLINE withFile #-} withFile :: (MonadIO m, MonadCatch m) => Path -> IOMode -> (Handle -> Stream m a) -> Stream m a -withFile file mode = S.bracketIO (FU.openFile file mode) hClose +withFile file mode = S.bracketIO (File.openFile file mode) hClose -- | Transform an 'Unfold' from a 'Handle' to an unfold from a 'Path'. The -- resulting unfold opens a handle in 'ReadMode', uses it using the supplied @@ -161,7 +165,7 @@ withFile file mode = S.bracketIO (FU.openFile file mode) hClose {-# INLINE usingFile #-} usingFile :: (MonadIO m, MonadCatch m) => Unfold m Handle a -> Unfold m Path a -usingFile = UF.bracketIO (`FU.openFile` ReadMode) hClose +usingFile = UF.bracketIO (`File.openFile` ReadMode) hClose {-# INLINE usingFile2 #-} usingFile2 :: (MonadIO m, MonadCatch m) @@ -171,7 +175,7 @@ usingFile2 = UF.bracketIO before after where before (x, file) = do - h <- FU.openFile file ReadMode + h <- File.openFile file ReadMode return (x, h) after (_, h) = hClose h @@ -184,7 +188,7 @@ usingFile3 = UF.bracketIO before after where before (x, y, z, file) = do - h <- FU.openFile file ReadMode + h <- File.openFile file ReadMode return (x, y, z, h) after (_, _, _, h) = hClose h @@ -205,7 +209,7 @@ usingFile3 = UF.bracketIO before after -- {-# INLINABLE putChunk #-} putChunk :: Path -> Array a -> IO () -putChunk file arr = FU.withFile file WriteMode (`FH.putChunk` arr) +putChunk file arr = File.withFile file WriteMode (`FH.putChunk` arr) -- | append an array to a file. -- @@ -213,7 +217,7 @@ putChunk file arr = FU.withFile file WriteMode (`FH.putChunk` arr) -- {-# INLINABLE writeAppendArray #-} writeAppendArray :: Path -> Array a -> IO () -writeAppendArray file arr = FU.withFile file AppendMode (`FH.putChunk` arr) +writeAppendArray file arr = File.withFile file AppendMode (`FH.putChunk` arr) ------------------------------------------------------------------------------- -- Stream of Arrays IO @@ -436,7 +440,7 @@ writeChunks :: (MonadIO m, MonadCatch m) writeChunks path = Fold step initial extract final where initial = do - h <- liftIO (FU.openFile path WriteMode) + h <- liftIO (File.openFile path WriteMode) fld <- FL.reduce (FH.writeChunks h) `MC.onException` liftIO (hClose h) return $ FL.Partial (fld, h) diff --git a/core/src/Streamly/Internal/FileSystem/Posix/File.hs b/core/src/Streamly/Internal/FileSystem/Posix/File.hs index 9ca6a6a491..ee05c5f316 100644 --- a/core/src/Streamly/Internal/FileSystem/Posix/File.hs +++ b/core/src/Streamly/Internal/FileSystem/Posix/File.hs @@ -4,13 +4,22 @@ module Streamly.Internal.FileSystem.Posix.File OpenFlags (..) , OpenMode (..) , defaultOpenFlags - , openFileWith - , openFile - , openFdAtWith - , openFdAt - , openFd - , closeFd + -- * Fd based Low Level + , openAtWith + , openAt + , open + , close + + -- -- * Posix Fd based openFile + -- , openFileFdWith + -- , openFileFd + + -- * Handle based + , openFile + , withFile + -- , openBinaryFile + -- , withBinaryFile -- Re-exported , Fd @@ -27,27 +36,27 @@ import Data.Bits ((.|.)) import Foreign.C.Error (throwErrnoIfMinus1_) import Foreign.C.String (CString) import Foreign.C.Types (CInt(..)) +import GHC.IO.Handle.FD (fdToHandle) +import Streamly.Internal.FileSystem.Posix.Errno (throwErrnoPathIfMinus1Retry) import Streamly.Internal.FileSystem.PosixPath (PosixPath) import System.IO (IOMode(..), Handle) -import GHC.IO.Handle.FD (fdToHandle) import System.Posix.Types (Fd(..), CMode(..), FileMode) -import Streamly.Internal.FileSystem.Posix.Errno (throwErrnoPathIfMinus1Retry) +import qualified Streamly.Internal.FileSystem.File.Utils as File import qualified Streamly.Internal.FileSystem.PosixPath as Path --- import qualified GHC.IO.FD as FD ------------------------------------------------------------------------------- -- Flags ------------------------------------------------------------------------------- --- XXX use oRDONLY, oWRONLY etc? +-- | Open mode, see Posix open system call man page. data OpenMode = ReadOnly -- ^ O_RDONLY | WriteOnly -- ^ O_WRONLY | ReadWrite -- ^ O_RDWR deriving (Read, Show, Eq, Ord) --- XXX use oAPPEND, oEXCL, oNOCTTY etc? +-- | Open flags, see posix open system call man page. data OpenFlags = OpenFlags { append :: Bool, -- ^ O_APPEND @@ -70,8 +79,8 @@ defaultOpenFlags = OpenFlags { append = False , exclusive = False - , noctty = True -- XXX ? - , nonBlock = True -- XXX ? + , noctty = True + , nonBlock = True , trunc = False , nofollow = False , creat = Nothing @@ -80,19 +89,23 @@ defaultOpenFlags = , sync = False } +------------------------------------------------------------------------------- +-- Low level (fd returning) file opening APIs +------------------------------------------------------------------------------- + foreign import capi unsafe "fcntl.h openat" c_openat :: CInt -> CString -> CInt -> CMode -> IO CInt -- | Open and optionally create a file relative to an optional -- directory file descriptor. -- {-# INLINE openFdAtWith_ #-} -openFdAtWith_ :: +openAtWith_ :: OpenFlags -- ^ Append, exclusive, etc. -> Maybe Fd -- ^ Optional directory file descriptor -> CString -- ^ Pathname to open -> OpenMode -- ^ Read-only, read-write or write-only -> IO Fd -openFdAtWith_ OpenFlags{..} fdMay path how = +openAtWith_ OpenFlags{..} fdMay path how = Fd <$> c_openat c_fd path all_flags mode_w where @@ -125,48 +138,81 @@ openFdAtWith_ OpenFlags{..} fdMay path how = -- | Open a file relative to an optional directory file descriptor. -- --- {-# INLINE openFdAtWith #-} -openFdAtWith :: +-- {-# INLINE openAtWith #-} +openAtWith :: OpenFlags -- ^ Append, exclusive, truncate, etc. -> Maybe Fd -- ^ Optional directory file descriptor -> PosixPath -- ^ Pathname to open -> OpenMode -- ^ Read-only, read-write or write-only -> IO Fd -openFdAtWith flags fdMay name how = +openAtWith flags fdMay name how = Path.asCString name $ \str -> do - throwErrnoPathIfMinus1Retry "openFdAt" name - $ openFdAtWith_ flags fdMay str how - -{-# INLINE openFdAt #-} -openFdAt :: Maybe Fd -> PosixPath -> OpenMode -> IO Fd -openFdAt = openFdAtWith defaultOpenFlags - -{-# INLINE openFd #-} -openFd :: PosixPath -> OpenMode -> IO Fd -openFd = openFdAt Nothing - -openFileWith :: OpenFlags -> PosixPath -> IOMode -> IO Handle -openFileWith df fp iomode = do - r <- - 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} - ReadWriteMode -> open ReadWrite df {creat = Just 0o666} - -- XXX Note we did not use mkFD here, are we locking the file? - fdToHandle $ fromIntegral r + throwErrnoPathIfMinus1Retry "openAtWith" name + $ openAtWith_ flags fdMay str how + +{-# INLINE openAt #-} +openAt :: Maybe Fd -> PosixPath -> OpenMode -> IO Fd +openAt = openAtWith defaultOpenFlags + +-- Note using an fd directly for IO may be problematic as direct blocking file +-- system operations on the file might block the capability and GC for "unsafe" +-- calls. "safe" calls may be more expensive. Also, you may have to synchronize +-- concurrent access via multiple threads. +{-# INLINE open #-} +open :: PosixPath -> OpenMode -> IO Fd +open = openAt Nothing + +-- | Open a regular file, return an Fd. +openFileFdWith :: OpenFlags -> PosixPath -> IOMode -> IO Fd +openFileFdWith oflags fp iomode = do + case iomode of + ReadMode -> open1 ReadOnly oflags + WriteMode -> open1 WriteOnly oflags {trunc = True, creat = cflag} + AppendMode -> open1 WriteOnly oflags {append = True, creat = cflag} + ReadWriteMode -> open1 ReadWrite oflags {creat = cflag} where - open mode flags = openFdAtWith flags Nothing fp mode + -- Use Nothing to open existing file only + cflag = Just 0o666 + open1 mode flags = openAtWith flags Nothing fp mode -openFile :: PosixPath -> IOMode -> IO Handle -openFile = openFileWith defaultOpenFlags +openFileFd :: PosixPath -> IOMode -> IO Fd +openFileFd = openFileFdWith defaultOpenFlags foreign import ccall unsafe "unistd.h close" c_close :: CInt -> IO CInt -closeFd :: Fd -> IO () -closeFd (Fd fd) = throwErrnoIfMinus1_ ("closeFd " ++ show fd) (c_close fd) +close :: Fd -> IO () +close (Fd fd) = throwErrnoIfMinus1_ ("close " ++ show fd) (c_close fd) + +------------------------------------------------------------------------------- +-- base openFile compatible, Handle returning, APIs +------------------------------------------------------------------------------- +-- | Open a regular file, return a Handle. The file is locked, the Handle is +-- NOT set up to close the file on garbage collection. +{-# INLINE openFileHandle #-} +openFileHandle :: PosixPath -> IOMode -> IO Handle +openFileHandle p x = openFileFd p x >>= fdToHandle . fromIntegral + +-- | Like openFile in base package but using Path instead of FilePath. +-- Use hSetBinaryMode on the handle if you want to use binary mode. +openFile :: PosixPath -> IOMode -> IO Handle +openFile = File.openFile False openFileHandle + +-- | Like withFile in base package but using Path instead of FilePath. +-- Use hSetBinaryMode on the handle if you want to use binary mode. +withFile :: PosixPath -> IOMode -> (Handle -> IO r) -> IO r +withFile = File.withFile False openFileHandle + +{- +-- | Like openBinaryFile in base package but using Path instead of FilePath. +openBinaryFile :: PosixPath -> IOMode -> IO Handle +openBinaryFile = File.openFile True openFileHandle + +-- | Like withBinaryFile in base package but using Path instead of FilePath. +withBinaryFile :: PosixPath -> IOMode -> (Handle -> IO r) -> IO r +withBinaryFile = File.withFile True openFileHandle +-} #endif diff --git a/core/src/Streamly/Internal/FileSystem/Posix/ReadDir.hsc b/core/src/Streamly/Internal/FileSystem/Posix/ReadDir.hsc index 7f9e7c24ab..ea5fd77c95 100644 --- a/core/src/Streamly/Internal/FileSystem/Posix/ReadDir.hsc +++ b/core/src/Streamly/Internal/FileSystem/Posix/ReadDir.hsc @@ -58,7 +58,7 @@ import Streamly.Internal.Data.Unfold.Type (Unfold(..)) import Streamly.Internal.FileSystem.Path (Path) import Streamly.Internal.FileSystem.Posix.Errno (throwErrnoPathIfNullRetry) import Streamly.Internal.FileSystem.Posix.File - (OpenMode(..), openFd, openFdAt, closeFd) + (OpenMode(..), open, openAt, close) import Streamly.Internal.FileSystem.PosixPath (PosixPath(..)) import System.Posix.Types (Fd(..), CMode) @@ -146,6 +146,13 @@ readPlusScanWith = undefined -- readdir operations ------------------------------------------------------------------------------- +-- XXX Marking the calls "safe" has significant perf impact because it runs on +-- a separate OS thread. "unsafe" is faster but can block the GC if the system +-- call blocks. The effect could be signifcant if the file system is on NFS. Is +-- it possible to have a faster safe - where we know the function is safe but +-- we run it on the current thread, and if it blocks for longer we can snatch +-- the capability and enable GC? +-- -- IMPORTANT NOTE: Use capi FFI for all readdir APIs. This is required at -- least on macOS for correctness. We saw random directory entries when ccall -- was used on macOS 15.3. Looks like it was picking the wrong version of @@ -237,7 +244,7 @@ openDirStream p = -- DirStream the fd will be closed. openDirStreamAt :: Fd -> PosixPath -> IO DirStream openDirStreamAt fd p = do - fd1 <- openFdAt (Just fd) p ReadOnly + fd1 <- openAt (Just fd) p ReadOnly -- liftIO $ putStrLn $ "opened: " ++ show fd1 dirp <- throwErrnoPathIfNullRetry "openDirStreamAt" p $ c_fdopendir (fromIntegral fd1) @@ -854,7 +861,7 @@ readEitherByteChunksAt confMod (ppath, alldirs) = else return Nothing step _ ByteChunksAtInit0 = do - pfd <- liftIO $ openFd ppath ReadOnly + pfd <- liftIO $ open ppath ReadOnly mbarr <- liftIO $ MutByteArray.new' bufSize return $ Skip (ByteChunksAtInit pfd alldirs mbarr 0) @@ -863,7 +870,7 @@ readEitherByteChunksAt confMod (ppath, alldirs) = return $ Skip (ByteChunksAtLoop ph dirp x xs [] 0 mbarr pos) step _ (ByteChunksAtInit pfd [] _ 0) = do - liftIO $ closeFd (pfd) + liftIO $ close (pfd) return Stop step _ (ByteChunksAtInit pfd [] mbarr pos) = do diff --git a/core/src/Streamly/Internal/FileSystem/Windows/File.hsc b/core/src/Streamly/Internal/FileSystem/Windows/File.hsc index 343a40c23b..ba9b5cfd10 100644 --- a/core/src/Streamly/Internal/FileSystem/Windows/File.hsc +++ b/core/src/Streamly/Internal/FileSystem/Windows/File.hsc @@ -1,23 +1,27 @@ +-- XXX When introducing platform specifc API, see Posix/File.hsc and design in +-- the same consistent way. module Streamly.Internal.FileSystem.Windows.File - ( openExistingFile - , openFile - , openExistingFileWithCloseOnExec - , openFileWithCloseOnExec + ( +#if defined(mingw32_HOST_OS) || defined(__MINGW32__) + -- * Handle based + openFile + , withFile + -- , openBinaryFile + -- , withBinaryFile +#endif ) where +#if defined(mingw32_HOST_OS) || defined(__MINGW32__) + ------------------------------------------------------------------------------- -- Imports ------------------------------------------------------------------------------- -import Control.Exception (bracketOnError, try, SomeException, onException) -import Data.Bits -import System.IO (IOMode(..), Handle) -import Foreign.C.Types -import System.Win32 as Win32 +import Control.Concurrent (threadDelay) +import Control.Exception (onException) import Control.Monad (when, void) import Streamly.Internal.FileSystem.WindowsPath (WindowsPath) - -import System.Win32.Types +import System.IO (IOMode(..), Handle) #if defined(__IO_MANAGER_WINIO__) import GHC.IO.SubSystem @@ -26,120 +30,139 @@ import GHC.IO.Handle.FD (fdToHandle') #include #endif -import Foreign.C.String -import Foreign.Ptr -import Foreign.Marshal.Alloc -import Foreign.Storable - +import qualified Streamly.Internal.FileSystem.File.Utils as File import qualified Streamly.Internal.FileSystem.WindowsPath as Path -#include "windows_cconv.h" +import Data.Bits +import Foreign.Ptr +import System.Win32 as Win32 hiding (createFile, failIfWithRetry) + +#include ------------------------------------------------------------------------------- --- Windows +-- Low level (fd returning) file opening APIs ------------------------------------------------------------------------------- -foreign import WINDOWS_CCONV unsafe "windows.h CreateFileW" +-- XXX Note for i386, stdcall is needed instead of ccall, see Win32 +-- package/windows_cconv.h. We support only x86_64 for now. +foreign import ccall unsafe "windows.h CreateFileW" c_CreateFile :: LPCTSTR -> AccessMode -> ShareMode -> LPSECURITY_ATTRIBUTES -> CreateMode -> FileAttributeOrFlag -> HANDLE -> IO HANDLE - -- | like failIf, but retried on sharing violations. This is necessary for many -- file operations; see -- https://www.betaarchive.com/wiki/index.php/Microsoft_KB_Archive/316609 -- failIfWithRetry :: (a -> Bool) -> String -> IO a -> IO a -failIfWithRetry cond msg action = retryOrFail retries - where - delay = 100*1000 -- in ms, we use threadDelay +failIfWithRetry needRetry msg action = retryOrFail retries - retries = 20 :: Int - -- KB article recommends 250/5 + where + delay = 100 * 1000 -- 100 ms - -- retryOrFail :: Int -> IO a + -- KB article recommends 250/5 + retries = 20 :: Int + -- retryOrFail :: Int -> IO a retryOrFail times - | times <= 0 = errorWin msg - | otherwise = do - ret <- action - if not (cond ret) + | times <= 0 = errorWin msg + | otherwise = do + ret <- action + if not (needRetry ret) then return ret else do - err_code <- getLastError - if err_code == (32) - then do threadDelay delay; retryOrFail (times - 1) + err_code <- getLastError + if err_code == 32 + then do + threadDelay delay + retryOrFail (times - 1) else errorWin msg -withFilePath :: WindowsPath -> (LPTSTR -> IO a) -> IO a -withFilePath p act = - Array.unsafePinnedAsPtr (Path.toChunk p) $ \ptr _ -> act (castPtr ptr) - -createFile :: WindowsPath -> AccessMode -> ShareMode -> Maybe LPSECURITY_ATTRIBUTES -> CreateMode -> FileAttributeOrFlag -> Maybe HANDLE -> IO HANDLE +createFile :: + WindowsPath + -> AccessMode + -> ShareMode + -> Maybe LPSECURITY_ATTRIBUTES + -> CreateMode + -> FileAttributeOrFlag + -> Maybe Win32.HANDLE + -> IO Win32.HANDLE createFile name access share mb_attr mode flag mb_h = - withFilePath name $ \ c_name -> - failIfWithRetry (==iNVALID_HANDLE_VALUE) (unwords ["CreateFile",show name]) $ - c_CreateFile c_name access share (maybePtr mb_attr) mode flag (maybePtr mb_h) - --- | Open a file and return the 'Handle'. -openFile :: WindowsPath -> IOMode -> IO Handle -openFile fp iomode = bracketOnError - (createFile - fp - accessMode - shareMode - Nothing - createMode + Path.asCWString name $ \c_name -> + failIfWithRetry + (== iNVALID_HANDLE_VALUE) + (unwords ["CreateFile", Path.toString name]) + $ c_CreateFile + c_name access share (maybePtr mb_attr) mode flag (maybePtr mb_h) + +win2HsHandle :: WindowsPath -> IOMode -> Win32.HANDLE -> IO Handle +win2HsHandle _fp _iomode h = do #if defined(__IO_MANAGER_WINIO__) - (case ioSubSystem of - IoPOSIX -> Win32.fILE_ATTRIBUTE_NORMAL - IoNative -> Win32.fILE_ATTRIBUTE_NORMAL .|. Win32.fILE_FLAG_OVERLAPPED - ) + Win32.hANDLEToHandle h #else - Win32.fILE_ATTRIBUTE_NORMAL + fd <- _open_osfhandle (fromIntegral (ptrToIntPtr h)) (#const _O_BINARY) + fdToHandle' fd Nothing False (Path.toString _fp) _iomode True #endif - Nothing) - Win32.closeHandle - (toHandle fp iomode) - where - 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 - (createFile - fp - accessMode - shareMode - Nothing - createMode + +fdToHandle :: WindowsPath -> IOMode -> Win32.HANDLE -> IO Handle +fdToHandle fp iomode h = + win2HsHandle fp iomode h `onException` Win32.closeHandle h + +openFileFd :: Bool -> WindowsPath -> IOMode -> IO Win32.HANDLE +openFileFd existing fp iomode = do + h <- createFile + fp + accessMode + shareMode + Nothing + (if existing then createModeExisting else createMode) + fileAttr + Nothing + when (iomode == AppendMode ) + $ void $ Win32.setFilePointerEx h 0 Win32.fILE_END + return h + + where + + 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 + + writeShareMode :: ShareMode + writeShareMode = + Win32.fILE_SHARE_DELETE + .|. Win32.fILE_SHARE_READ + + maxShareMode :: ShareMode + maxShareMode = + Win32.fILE_SHARE_DELETE + .|. Win32.fILE_SHARE_READ + .|. Win32.fILE_SHARE_WRITE + + shareMode = + case iomode of + ReadMode -> Win32.fILE_SHARE_READ + WriteMode -> writeShareMode + AppendMode -> writeShareMode + ReadWriteMode -> maxShareMode + + createMode = + case iomode of + ReadMode -> Win32.oPEN_EXISTING + WriteMode -> Win32.cREATE_ALWAYS + AppendMode -> Win32.oPEN_ALWAYS + ReadWriteMode -> Win32.oPEN_ALWAYS + + createModeExisting = + case iomode of + ReadMode -> Win32.oPEN_EXISTING + WriteMode -> Win32.tRUNCATE_EXISTING + AppendMode -> Win32.oPEN_EXISTING + ReadWriteMode -> Win32.oPEN_EXISTING + + fileAttr = #if defined(__IO_MANAGER_WINIO__) (case ioSubSystem of IoPOSIX -> Win32.fILE_ATTRIBUTE_NORMAL @@ -148,47 +171,34 @@ openExistingFile fp iomode = bracketOnError #else Win32.fILE_ATTRIBUTE_NORMAL #endif - Nothing) - Win32.closeHandle - (toHandle fp iomode) - where - 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 -openFileWithCloseOnExec :: WindowsPath -> IOMode -> IO Handle -openFileWithCloseOnExec = openFile +------------------------------------------------------------------------------- +-- base openFile compatible, Handle returning, APIs +------------------------------------------------------------------------------- -openExistingFileWithCloseOnExec :: WindowsPath -> IOMode -> IO Handle -openExistingFileWithCloseOnExec = openExistingFile +-- | Open a regular file, return a Handle. The file is locked, the Handle is +-- NOT set up to close the file on garbage collection. +{-# INLINE openFileHandle #-} +openFileHandle :: WindowsPath -> IOMode -> IO Handle +openFileHandle p x = openFileFd False p x >>= fdToHandle p x -toHandle :: WindowsPath -> IOMode -> Win32.HANDLE -> IO Handle -#if defined(__IO_MANAGER_WINIO__) -toHandle _ iomode h = (`onException` Win32.closeHandle h) $ do - when (iomode == AppendMode ) $ void $ Win32.setFilePointerEx h 0 Win32.fILE_END - Win32.hANDLEToHandle h -#else -toHandle fp iomode 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) - fdToHandle' fd Nothing False (Path.toString fp) iomode True +-- | Like withFile in base package but using Path instead of FilePath. +-- Use hSetBinaryMode on the handle if you want to use binary mode. +withFile :: WindowsPath -> IOMode -> (Handle -> IO r) -> IO r +withFile = File.withFile False openFileHandle + +-- | Like openFile in base package but using Path instead of FilePath. +-- Use hSetBinaryMode on the handle if you want to use binary mode. +openFile :: WindowsPath -> IOMode -> IO Handle +openFile = File.openFile False openFileHandle + +{- +-- | Like withBinaryFile in base package but using Path instead of FilePath. +withBinaryFile :: WindowsPath -> IOMode -> (Handle -> IO r) -> IO r +withBinaryFile = File.withFile True openFileHandle + +-- | Like openBinaryFile in base package but using Path instead of FilePath. +openBinaryFile :: WindowsPath -> IOMode -> IO Handle +openBinaryFile = File.openFile True openFileHandle +-} #endif diff --git a/test/Streamly/Test/FileSystem/Handle.hs b/test/Streamly/Test/FileSystem/Handle.hs index fb0efd4fc8..86c817f78b 100644 --- a/test/Streamly/Test/FileSystem/Handle.hs +++ b/test/Streamly/Test/FileSystem/Handle.hs @@ -23,7 +23,11 @@ import System.IO , hPutStr ) import System.IO.Temp (withSystemTempDirectory) -import Streamly.Internal.FileSystem.File.Utils (openFile, withFile) +#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) +import Streamly.Internal.FileSystem.Posix.File (openFile, withFile) +#else +import Streamly.Internal.FileSystem.Windows.File (openFile, withFile) +#endif import Test.QuickCheck (Property, forAll, Gen, vectorOf, choose) import Test.QuickCheck.Monadic (monadicIO, assert, run) import Streamly.Internal.FileSystem.Path (Path) From 210cde668f9ab402b2a90d5a4b38b52a5ddee369 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Tue, 22 Apr 2025 18:15:13 +0530 Subject: [PATCH 6/9] Move Posix/File.hs to Posix/File.hsc --- core/src/Streamly/Internal/FileSystem/Posix/{File.hs => File.hsc} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename core/src/Streamly/Internal/FileSystem/Posix/{File.hs => File.hsc} (100%) diff --git a/core/src/Streamly/Internal/FileSystem/Posix/File.hs b/core/src/Streamly/Internal/FileSystem/Posix/File.hsc similarity index 100% rename from core/src/Streamly/Internal/FileSystem/Posix/File.hs rename to core/src/Streamly/Internal/FileSystem/Posix/File.hsc From 0d571c0a7ebb28c36eec5bc3324c46ad0802c108 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Tue, 22 Apr 2025 17:18:32 +0530 Subject: [PATCH 7/9] Change openAt API Now we can set and clear open flags and create mode using function based API. --- .../Internal/FileSystem/Posix/File.hsc | 319 ++++++++++++------ .../Internal/FileSystem/Posix/ReadDir.hsc | 11 +- 2 files changed, 222 insertions(+), 108 deletions(-) diff --git a/core/src/Streamly/Internal/FileSystem/Posix/File.hsc b/core/src/Streamly/Internal/FileSystem/Posix/File.hsc index ee05c5f316..70ad008552 100644 --- a/core/src/Streamly/Internal/FileSystem/Posix/File.hsc +++ b/core/src/Streamly/Internal/FileSystem/Posix/File.hsc @@ -1,20 +1,68 @@ module Streamly.Internal.FileSystem.Posix.File ( #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) + + -- * File open flags OpenFlags (..) - , OpenMode (..) , defaultOpenFlags + -- * File status flags + , setAppend + , setNonBlock + , setSync + + -- * File creation flags + , setCloExec + , setDirectory + , setExcl + , setNoCtty + , setNoFollow + -- setTmpFile + , setTrunc + + -- * File create mode + , defaultCreateMode + + -- ** User Permissions + , setUr + , setUw + , setUx + + , clrUr + , clrUw + , clrUx + + -- ** Group Permissions + , setGr + , setGw + , setGx + + , clrGr + , clrGw + , clrGx + + -- ** Other Permissions + , setOr + , setOw + , setOx + + , clrOr + , clrOw + , clrOx + + -- ** Status bits + , setSuid + , setSgid + , setSticky + + , clrSuid + , clrSgid + , clrSticky + -- * Fd based Low Level - , openAtWith , openAt - , open , close - -- -- * Posix Fd based openFile - -- , openFileFdWith - -- , openFileFd - -- * Handle based , openFile , withFile @@ -32,7 +80,7 @@ module Streamly.Internal.FileSystem.Posix.File -- Imports ------------------------------------------------------------------------------- -import Data.Bits ((.|.)) +import Data.Bits ((.|.), (.&.), complement) import Foreign.C.Error (throwErrnoIfMinus1_) import Foreign.C.String (CString) import Foreign.C.Types (CInt(..)) @@ -40,142 +88,203 @@ import GHC.IO.Handle.FD (fdToHandle) import Streamly.Internal.FileSystem.Posix.Errno (throwErrnoPathIfMinus1Retry) import Streamly.Internal.FileSystem.PosixPath (PosixPath) import System.IO (IOMode(..), Handle) -import System.Posix.Types (Fd(..), CMode(..), FileMode) +import System.Posix.Types (Fd(..), CMode(..)) import qualified Streamly.Internal.FileSystem.File.Utils as File import qualified Streamly.Internal.FileSystem.PosixPath as Path +-- We want to remain close to the Posix C API. A function based API to set and +-- clear the modes is simple, type safe and directly mirrors the C API. It does +-- not require explicit mapping from Haskell ADT to C types, we can dirctly +-- manipulate the C type. + ------------------------------------------------------------------------------- --- Flags +-- Create mode ------------------------------------------------------------------------------- --- | Open mode, see Posix open system call man page. -data OpenMode = - ReadOnly -- ^ O_RDONLY - | WriteOnly -- ^ O_WRONLY - | ReadWrite -- ^ O_RDWR - deriving (Read, Show, Eq, Ord) +-- | Open flags, see posix open system call man page. +newtype FileMode = FileMode CMode + +#define MK_MODE_API(name1,name2,x) \ +{-# INLINE name1 #-}; \ +name1 :: FileMode -> FileMode; \ +name1 (FileMode mode) = FileMode (x .|. mode); \ +{-# INLINE name2 #-}; \ +name2 :: FileMode -> FileMode; \ +name2 (FileMode mode) = FileMode (x .&. complement mode) + +-- XXX Linux man page says, posix leaves them unspecified +-- XXX ensure compatibility across BSD and Mac +#define S_ISUID 0004000 +#define S_ISGID 0002000 +#define S_ISVTX 0001000 + +#define S_IRWXU 00700 +#define S_IRUSR 00400 +#define S_IWUSR 00200 +#define S_IXUSR 00100 + +#define S_IRWXG 00070 +#define S_IRGRP 00040 +#define S_IWGRP 00020 +#define S_IXGRP 00010 + +#define S_IRWXO 00007 +#define S_IROTH 00004 +#define S_IWOTH 00002 +#define S_IXOTH 00001 + +-- XXX Use definitions from headers, though these are standard for posix +-- s_IRWXU :: CMode +-- s_IRWXU = #{const S_IRWXU} + +MK_MODE_API(setSuid,clrSuid,S_ISUID) +MK_MODE_API(setSgid,clrSgid,S_ISGID) +MK_MODE_API(setSticky,clrSticky,S_ISVTX) + +-- MK_MODE_API(setUrwx,clrUrwx,S_IRWXU) +MK_MODE_API(setUr,clrUr,S_IRUSR) +MK_MODE_API(setUw,clrUw,S_IWUSR) +MK_MODE_API(setUx,clrUx,S_IXUSR) + +-- MK_MODE_API(setGrwx,clrGrwx,S_IRWXU) +MK_MODE_API(setGr,clrGr,S_IRUSR) +MK_MODE_API(setGw,clrGw,S_IWUSR) +MK_MODE_API(setGx,clrGx,S_IXUSR) + +-- MK_MODE_API(setOrwx,clrOrwx,S_IRWXU) +MK_MODE_API(setOr,clrOr,S_IRUSR) +MK_MODE_API(setOw,clrOw,S_IWUSR) +MK_MODE_API(setOx,clrOx,S_IXUSR) + +-- Uses the same default mode as openFileWith in base +defaultCreateMode :: FileMode +defaultCreateMode = FileMode 0o666 + +------------------------------------------------------------------------------- +-- Open Flags +------------------------------------------------------------------------------- -- | Open flags, see posix open system call man page. -data OpenFlags = - OpenFlags { - append :: Bool, -- ^ O_APPEND - exclusive :: Bool, -- ^ O_EXCL, Result is undefined if 'creat' is 'Nothing'. - noctty :: Bool, -- ^ O_NOCTTY - nonBlock :: Bool, -- ^ O_NONBLOCK - trunc :: Bool, -- ^ O_TRUNC - nofollow :: Bool, -- ^ O_NOFOLLOW - creat :: Maybe FileMode, -- ^ O_CREAT - cloexec :: Bool, -- ^ O_CLOEXEC - directory :: Bool, -- ^ O_DIRECTORY - sync :: Bool -- ^ O_SYNC - } - deriving (Read, Show, Eq, Ord) +newtype OpenFlags = OpenFlags CInt + +#define MK_FLAG_API(name,x) \ +{-# INLINE name #-}; \ +name :: OpenFlags -> OpenFlags; \ +name (OpenFlags flags) = OpenFlags (flags .|. x) + +-- XXX Use definitions from headers or base? +{- +-- foreign import ccall unsafe "HsBase.h __hscore_o_rdonly" o_RDONLY :: CInt +o_APPEND :: CInt +s_APPEND = #{const O_APPEND} +-} + +-- These affect the first two bits in flags. +MK_FLAG_API(setReadOnly,0) +MK_FLAG_API(setWriteOnly,1) +MK_FLAG_API(setReadWrite,2) + +#define MK_BOOL_FLAG_API(name,x) \ +{-# INLINE name #-}; \ +name :: Bool -> OpenFlags -> OpenFlags; \ +name True (OpenFlags flags) = OpenFlags (flags .|. x); \ +name False (OpenFlags flags) = OpenFlags (flags .&. complement x) + +-- setCreat is internal only, do not export this. This is automatically set +-- when create mode is passed, otherwise cleared. +MK_BOOL_FLAG_API(setCreat,64) + +MK_BOOL_FLAG_API(setExcl,128) +MK_BOOL_FLAG_API(setNoCtty,256) +MK_BOOL_FLAG_API(setTrunc,512) +MK_BOOL_FLAG_API(setAppend,1024) +MK_BOOL_FLAG_API(setNonBlock,2048) +MK_BOOL_FLAG_API(setDirectory,65536) +MK_BOOL_FLAG_API(setNoFollow,131072) +MK_BOOL_FLAG_API(setCloExec,524288) +MK_BOOL_FLAG_API(setSync,1052672) -- | Default values for the 'OpenFlags'. -- +-- By default a 0 value is used, no flag is set. See the open system call man +-- page. defaultOpenFlags :: OpenFlags -defaultOpenFlags = - OpenFlags - { append = False - , exclusive = False - , noctty = True - , nonBlock = True - , trunc = False - , nofollow = False - , creat = Nothing - , cloexec = False - , directory = False - , sync = False - } +defaultOpenFlags = OpenFlags 0 ------------------------------------------------------------------------------- -- Low level (fd returning) file opening APIs ------------------------------------------------------------------------------- +-- XXX Should we use interruptible open as in base openFile? foreign import capi unsafe "fcntl.h openat" c_openat :: CInt -> CString -> CInt -> CMode -> IO CInt --- | Open and optionally create a file relative to an optional --- directory file descriptor. --- {-# INLINE openFdAtWith_ #-} -openAtWith_ :: - OpenFlags -- ^ Append, exclusive, etc. - -> Maybe Fd -- ^ Optional directory file descriptor +#define AT_FDCWD (-100) +-- atFdCwd = #(const AT_FDCWD) + +-- | Open and optionally create (when create mode is specified) a file relative +-- to an optional directory file descriptor. If directory fd is not specified +-- then opens relative to the current directory. +-- {-# INLINE openAtCString #-} +openAtCString :: + Maybe Fd -- ^ Optional directory file descriptor -> CString -- ^ Pathname to open - -> OpenMode -- ^ Read-only, read-write or write-only + -> OpenFlags -- ^ Append, exclusive, etc. + -> Maybe FileMode -- ^ Create mode -> IO Fd -openAtWith_ OpenFlags{..} fdMay path how = - Fd <$> c_openat c_fd path all_flags mode_w +openAtCString fdMay path flags cmode = + Fd <$> c_openat c_fd path flags1 mode where - c_fd = maybe (-100) (\ (Fd fd) -> fd) fdMay - - flags = - (if append then 1024 else 0) .|. - (if exclusive then 128 else 0) .|. - (if noctty then 256 else 0) .|. - (if nonBlock then 2048 else 0) .|. - (if trunc then 512 else 0) .|. - (if nofollow then 131072 else 0) .|. - (if cloexec then 524288 else 0) .|. - (if directory then 65536 else 0) .|. - (if sync then 1052672 else 0) - - open_mode = - case how of - ReadOnly -> 0 - WriteOnly -> 1 - ReadWrite -> 2 - - (creat_f, mode_w) = - case creat of - Nothing -> (0, 0) - Just x -> (64, x) - - all_flags = creat_f .|. flags .|. open_mode + c_fd = maybe AT_FDCWD (\ (Fd fd) -> fd) fdMay + FileMode mode = maybe defaultCreateMode id cmode + OpenFlags flags1 = maybe flags (\_ -> setCreat True flags) cmode -- | Open a file relative to an optional directory file descriptor. -- --- {-# INLINE openAtWith #-} -openAtWith :: - OpenFlags -- ^ Append, exclusive, truncate, etc. - -> Maybe Fd -- ^ Optional directory file descriptor +-- Note: In Haskell, using an fd directly for IO may be problematic as blocking +-- file system operations on the file might block the capability and GC for +-- "unsafe" calls. "safe" calls may be more expensive. Also, you may have to +-- synchronize concurrent access via multiple threads. +-- +{-# INLINE openAt #-} +openAt :: + Maybe Fd -- ^ Optional directory file descriptor -> PosixPath -- ^ Pathname to open - -> OpenMode -- ^ Read-only, read-write or write-only + -> OpenFlags -- ^ Append, exclusive, truncate, etc. + -> Maybe FileMode -- ^ Create mode -> IO Fd -openAtWith flags fdMay name how = - Path.asCString name $ \str -> do - throwErrnoPathIfMinus1Retry "openAtWith" name - $ openAtWith_ flags fdMay str how - -{-# INLINE openAt #-} -openAt :: Maybe Fd -> PosixPath -> OpenMode -> IO Fd -openAt = openAtWith defaultOpenFlags +openAt fdMay path flags cmode = + Path.asCString path $ \cstr -> do + throwErrnoPathIfMinus1Retry "openAt" path + $ openAtCString fdMay cstr flags cmode --- Note using an fd directly for IO may be problematic as direct blocking file --- system operations on the file might block the capability and GC for "unsafe" --- calls. "safe" calls may be more expensive. Also, you may have to synchronize --- concurrent access via multiple threads. -{-# INLINE open #-} -open :: PosixPath -> OpenMode -> IO Fd -open = openAt Nothing -- | Open a regular file, return an Fd. +-- +-- Sets O_NOCTTY, O_NONBLOCK flags to be compatible with the base openFile +-- behavior. O_NOCTTY affects opening of terminal special files and O_NONBLOCK +-- affects fifo special files, and mandatory locking. +-- openFileFdWith :: OpenFlags -> PosixPath -> IOMode -> IO Fd -openFileFdWith oflags fp iomode = do +openFileFdWith oflags path iomode = do case iomode of - ReadMode -> open1 ReadOnly oflags - WriteMode -> open1 WriteOnly oflags {trunc = True, creat = cflag} - AppendMode -> open1 WriteOnly oflags {append = True, creat = cflag} - ReadWriteMode -> open1 ReadWrite oflags {creat = cflag} + ReadMode -> open1 (setReadOnly oflags1) Nothing + WriteMode -> + open1 (setWriteOnly oflags1) (Just defaultCreateMode) + AppendMode -> + open1 + ((setAppend True . setWriteOnly) oflags1) + (Just defaultCreateMode) + ReadWriteMode -> + open1 (setReadWrite oflags) (Just defaultCreateMode) where - -- Use Nothing to open existing file only - cflag = Just 0o666 - open1 mode flags = openAtWith flags Nothing fp mode + oflags1 = setNoCtty True $ setNonBlock True oflags + open1 = openAt Nothing path openFileFd :: PosixPath -> IOMode -> IO Fd openFileFd = openFileFdWith defaultOpenFlags diff --git a/core/src/Streamly/Internal/FileSystem/Posix/ReadDir.hsc b/core/src/Streamly/Internal/FileSystem/Posix/ReadDir.hsc index ea5fd77c95..ad2daafa5a 100644 --- a/core/src/Streamly/Internal/FileSystem/Posix/ReadDir.hsc +++ b/core/src/Streamly/Internal/FileSystem/Posix/ReadDir.hsc @@ -58,7 +58,7 @@ import Streamly.Internal.Data.Unfold.Type (Unfold(..)) import Streamly.Internal.FileSystem.Path (Path) import Streamly.Internal.FileSystem.Posix.Errno (throwErrnoPathIfNullRetry) import Streamly.Internal.FileSystem.Posix.File - (OpenMode(..), open, openAt, close) + (defaultOpenFlags, openAt, close) import Streamly.Internal.FileSystem.PosixPath (PosixPath(..)) import System.Posix.Types (Fd(..), CMode) @@ -244,7 +244,10 @@ openDirStream p = -- DirStream the fd will be closed. openDirStreamAt :: Fd -> PosixPath -> IO DirStream openDirStreamAt fd p = do - fd1 <- openAt (Just fd) p ReadOnly + -- XXX can pass O_DIRECTORY here, is O_NONBLOCK useful for dirs? + -- Note this fd is not automatically closed, we have to take care of + -- exceptions and closing the fd. + fd1 <- openAt (Just fd) p defaultOpenFlags Nothing -- liftIO $ putStrLn $ "opened: " ++ show fd1 dirp <- throwErrnoPathIfNullRetry "openDirStreamAt" p $ c_fdopendir (fromIntegral fd1) @@ -861,7 +864,9 @@ readEitherByteChunksAt confMod (ppath, alldirs) = else return Nothing step _ ByteChunksAtInit0 = do - pfd <- liftIO $ open ppath ReadOnly + -- Note this fd is not automatically closed, we have to take care of + -- exceptions and closing the fd. + pfd <- liftIO $ openAt Nothing ppath defaultOpenFlags Nothing mbarr <- liftIO $ MutByteArray.new' bufSize return $ Skip (ByteChunksAtInit pfd alldirs mbarr 0) From b23c9c24d22f40f2c9d69ec83b9a5ae76df43f6b Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Tue, 22 Apr 2025 18:16:07 +0530 Subject: [PATCH 8/9] Use defs from OS header files in Posix/File.hsc --- .../Internal/FileSystem/Posix/File.hsc | 55 ++++++++----------- 1 file changed, 23 insertions(+), 32 deletions(-) diff --git a/core/src/Streamly/Internal/FileSystem/Posix/File.hsc b/core/src/Streamly/Internal/FileSystem/Posix/File.hsc index 70ad008552..8dfc16773b 100644 --- a/core/src/Streamly/Internal/FileSystem/Posix/File.hsc +++ b/core/src/Streamly/Internal/FileSystem/Posix/File.hsc @@ -98,6 +98,8 @@ import qualified Streamly.Internal.FileSystem.PosixPath as Path -- not require explicit mapping from Haskell ADT to C types, we can dirctly -- manipulate the C type. +#include + ------------------------------------------------------------------------------- -- Create mode ------------------------------------------------------------------------------- @@ -105,7 +107,7 @@ import qualified Streamly.Internal.FileSystem.PosixPath as Path -- | Open flags, see posix open system call man page. newtype FileMode = FileMode CMode -#define MK_MODE_API(name1,name2,x) \ +##define MK_MODE_API(name1,name2,x) \ {-# INLINE name1 #-}; \ name1 :: FileMode -> FileMode; \ name1 (FileMode mode) = FileMode (x .|. mode); \ @@ -113,8 +115,7 @@ name1 (FileMode mode) = FileMode (x .|. mode); \ name2 :: FileMode -> FileMode; \ name2 (FileMode mode) = FileMode (x .&. complement mode) --- XXX Linux man page says, posix leaves them unspecified --- XXX ensure compatibility across BSD and Mac +{- #define S_ISUID 0004000 #define S_ISGID 0002000 #define S_ISVTX 0001000 @@ -134,9 +135,8 @@ name2 (FileMode mode) = FileMode (x .&. complement mode) #define S_IWOTH 00002 #define S_IXOTH 00001 --- XXX Use definitions from headers, though these are standard for posix --- s_IRWXU :: CMode --- s_IRWXU = #{const S_IRWXU} +#define AT_FDCWD (-100) +-} MK_MODE_API(setSuid,clrSuid,S_ISUID) MK_MODE_API(setSgid,clrSgid,S_ISGID) @@ -168,24 +168,18 @@ defaultCreateMode = FileMode 0o666 -- | Open flags, see posix open system call man page. newtype OpenFlags = OpenFlags CInt -#define MK_FLAG_API(name,x) \ +##define MK_FLAG_API(name,x) \ {-# INLINE name #-}; \ name :: OpenFlags -> OpenFlags; \ name (OpenFlags flags) = OpenFlags (flags .|. x) --- XXX Use definitions from headers or base? -{- -- foreign import ccall unsafe "HsBase.h __hscore_o_rdonly" o_RDONLY :: CInt -o_APPEND :: CInt -s_APPEND = #{const O_APPEND} --} - -- These affect the first two bits in flags. -MK_FLAG_API(setReadOnly,0) -MK_FLAG_API(setWriteOnly,1) -MK_FLAG_API(setReadWrite,2) +MK_FLAG_API(setReadOnly,#{const O_RDONLY}) +MK_FLAG_API(setWriteOnly,#{const O_WRONLY}) +MK_FLAG_API(setReadWrite,#{const O_RDWR}) -#define MK_BOOL_FLAG_API(name,x) \ +##define MK_BOOL_FLAG_API(name,x) \ {-# INLINE name #-}; \ name :: Bool -> OpenFlags -> OpenFlags; \ name True (OpenFlags flags) = OpenFlags (flags .|. x); \ @@ -193,17 +187,17 @@ name False (OpenFlags flags) = OpenFlags (flags .&. complement x) -- setCreat is internal only, do not export this. This is automatically set -- when create mode is passed, otherwise cleared. -MK_BOOL_FLAG_API(setCreat,64) - -MK_BOOL_FLAG_API(setExcl,128) -MK_BOOL_FLAG_API(setNoCtty,256) -MK_BOOL_FLAG_API(setTrunc,512) -MK_BOOL_FLAG_API(setAppend,1024) -MK_BOOL_FLAG_API(setNonBlock,2048) -MK_BOOL_FLAG_API(setDirectory,65536) -MK_BOOL_FLAG_API(setNoFollow,131072) -MK_BOOL_FLAG_API(setCloExec,524288) -MK_BOOL_FLAG_API(setSync,1052672) +MK_BOOL_FLAG_API(setCreat,#{const O_CREAT}) + +MK_BOOL_FLAG_API(setExcl,#{const O_EXCL}) +MK_BOOL_FLAG_API(setNoCtty,#{const O_NOCTTY}) +MK_BOOL_FLAG_API(setTrunc,#{const O_TRUNC}) +MK_BOOL_FLAG_API(setAppend,#{const O_APPEND}) +MK_BOOL_FLAG_API(setNonBlock,#{const O_NONBLOCK}) +MK_BOOL_FLAG_API(setDirectory,#{const O_DIRECTORY}) +MK_BOOL_FLAG_API(setNoFollow,#{const O_NOFOLLOW}) +MK_BOOL_FLAG_API(setCloExec,#{const O_CLOEXEC}) +MK_BOOL_FLAG_API(setSync,#{const O_SYNC}) -- | Default values for the 'OpenFlags'. -- @@ -220,9 +214,6 @@ defaultOpenFlags = OpenFlags 0 foreign import capi unsafe "fcntl.h openat" c_openat :: CInt -> CString -> CInt -> CMode -> IO CInt -#define AT_FDCWD (-100) --- atFdCwd = #(const AT_FDCWD) - -- | Open and optionally create (when create mode is specified) a file relative -- to an optional directory file descriptor. If directory fd is not specified -- then opens relative to the current directory. @@ -238,7 +229,7 @@ openAtCString fdMay path flags cmode = where - c_fd = maybe AT_FDCWD (\ (Fd fd) -> fd) fdMay + c_fd = maybe (#{const AT_FDCWD}) (\ (Fd fd) -> fd) fdMay FileMode mode = maybe defaultCreateMode id cmode OpenFlags flags1 = maybe flags (\_ -> setCreat True flags) cmode From c3cb5225f73a311029f6de7d43cae7af966d6f4a Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Tue, 22 Apr 2025 19:03:35 +0530 Subject: [PATCH 9/9] Move File.Utils to File.Common --- .../Internal/FileSystem/File/{Utils.hs => Common.hs} | 2 +- core/src/Streamly/Internal/FileSystem/Posix/File.hsc | 2 +- core/src/Streamly/Internal/FileSystem/Windows/File.hsc | 2 +- core/streamly-core.cabal | 8 ++++---- 4 files changed, 7 insertions(+), 7 deletions(-) rename core/src/Streamly/Internal/FileSystem/File/{Utils.hs => Common.hs} (98%) diff --git a/core/src/Streamly/Internal/FileSystem/File/Utils.hs b/core/src/Streamly/Internal/FileSystem/File/Common.hs similarity index 98% rename from core/src/Streamly/Internal/FileSystem/File/Utils.hs rename to core/src/Streamly/Internal/FileSystem/File/Common.hs index 89d7f3ab8a..c8b19d49ab 100644 --- a/core/src/Streamly/Internal/FileSystem/File/Utils.hs +++ b/core/src/Streamly/Internal/FileSystem/File/Common.hs @@ -1,4 +1,4 @@ -module Streamly.Internal.FileSystem.File.Utils +module Streamly.Internal.FileSystem.File.Common ( withFile , openFile ) where diff --git a/core/src/Streamly/Internal/FileSystem/Posix/File.hsc b/core/src/Streamly/Internal/FileSystem/Posix/File.hsc index 8dfc16773b..f341c25474 100644 --- a/core/src/Streamly/Internal/FileSystem/Posix/File.hsc +++ b/core/src/Streamly/Internal/FileSystem/Posix/File.hsc @@ -90,7 +90,7 @@ import Streamly.Internal.FileSystem.PosixPath (PosixPath) import System.IO (IOMode(..), Handle) import System.Posix.Types (Fd(..), CMode(..)) -import qualified Streamly.Internal.FileSystem.File.Utils as File +import qualified Streamly.Internal.FileSystem.File.Common as File import qualified Streamly.Internal.FileSystem.PosixPath as Path -- We want to remain close to the Posix C API. A function based API to set and diff --git a/core/src/Streamly/Internal/FileSystem/Windows/File.hsc b/core/src/Streamly/Internal/FileSystem/Windows/File.hsc index ba9b5cfd10..06062ad12b 100644 --- a/core/src/Streamly/Internal/FileSystem/Windows/File.hsc +++ b/core/src/Streamly/Internal/FileSystem/Windows/File.hsc @@ -30,7 +30,7 @@ import GHC.IO.Handle.FD (fdToHandle') #include #endif -import qualified Streamly.Internal.FileSystem.File.Utils as File +import qualified Streamly.Internal.FileSystem.File.Common as File import qualified Streamly.Internal.FileSystem.WindowsPath as Path import Data.Bits diff --git a/core/streamly-core.cabal b/core/streamly-core.cabal index f3beba92f5..8887775b4d 100644 --- a/core/streamly-core.cabal +++ b/core/streamly-core.cabal @@ -425,15 +425,14 @@ library , Streamly.Internal.FileSystem.WindowsPath.SegNode , Streamly.Internal.FileSystem.Handle - , Streamly.Internal.FileSystem.File - , Streamly.Internal.FileSystem.FileIO - , Streamly.Internal.FileSystem.File.Utils - , Streamly.Internal.FileSystem.DirIO + , Streamly.Internal.FileSystem.File.Common , Streamly.Internal.FileSystem.Posix.Errno , Streamly.Internal.FileSystem.Posix.File , Streamly.Internal.FileSystem.Posix.ReadDir , Streamly.Internal.FileSystem.Windows.ReadDir , Streamly.Internal.FileSystem.Windows.File + , Streamly.Internal.FileSystem.FileIO + , Streamly.Internal.FileSystem.DirIO -- RingArray Arrays , Streamly.Internal.Data.RingArray @@ -490,6 +489,7 @@ library , Streamly.Unicode.String -- Deprecated in 0.3.0 + , Streamly.Internal.FileSystem.File , Streamly.Internal.FileSystem.Dir , Streamly.FileSystem.Dir