diff --git a/core/src/Streamly/Internal/FileSystem/File/Common.hs b/core/src/Streamly/Internal/FileSystem/File/Common.hs new file mode 100644 index 0000000000..c8b19d49ab --- /dev/null +++ b/core/src/Streamly/Internal/FileSystem/File/Common.hs @@ -0,0 +1,97 @@ +module Streamly.Internal.FileSystem.File.Common + ( withFile + , openFile + ) where + +------------------------------------------------------------------------------- +-- Imports +------------------------------------------------------------------------------- + +import Control.Exception (mask, onException, try) +import Control.Monad (when) +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) + +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.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 + addMVarFinalizer mv (finalizer filepath mv) + where + !(filepath, !mv) = case handle of + FileHandle fp m -> (fp, m) + DuplexHandle fp _ write_m -> (fp, write_m) +#endif + +{-# 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 + 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 + +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 + +{-# 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 new file mode 100644 index 0000000000..816911ed7e --- /dev/null +++ b/core/src/Streamly/Internal/FileSystem/FileIO.hs @@ -0,0 +1,682 @@ +-- | +-- 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.Unfold as UF (bracketIO) +import qualified Streamly.Internal.Data.Fold.Type as FL + (Step(..), snoc, reduce) +import qualified Streamly.Internal.FileSystem.Handle as FH +#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" + +------------------------------------------------------------------------------- +-- 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 (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 +-- 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 (`File.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 <- File.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 <- File.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 = File.withFile file WriteMode (`FH.putChunk` arr) + +-- | append an array to a file. +-- +-- /Pre-release/ +-- +{-# INLINABLE writeAppendArray #-} +writeAppendArray :: Path -> Array a -> IO () +writeAppendArray file arr = File.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 $ A.chunksOf' 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 (File.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.unsafeCreateOf' 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 $ 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 +-- 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/Posix/File.hs b/core/src/Streamly/Internal/FileSystem/Posix/File.hs deleted file mode 100644 index 9ca6a6a491..0000000000 --- a/core/src/Streamly/Internal/FileSystem/Posix/File.hs +++ /dev/null @@ -1,172 +0,0 @@ -module Streamly.Internal.FileSystem.Posix.File - ( -#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) - OpenFlags (..) - , OpenMode (..) - , defaultOpenFlags - , openFileWith - , openFile - - , openFdAtWith - , openFdAt - , openFd - , closeFd - - -- Re-exported - , Fd -#endif - ) where - -#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) - -------------------------------------------------------------------------------- --- Imports -------------------------------------------------------------------------------- - -import Data.Bits ((.|.)) -import Foreign.C.Error (throwErrnoIfMinus1_) -import Foreign.C.String (CString) -import Foreign.C.Types (CInt(..)) -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.PosixPath as Path --- import qualified GHC.IO.FD as FD - -------------------------------------------------------------------------------- --- Flags -------------------------------------------------------------------------------- - --- XXX use oRDONLY, oWRONLY etc? -data OpenMode = - ReadOnly -- ^ O_RDONLY - | WriteOnly -- ^ O_WRONLY - | ReadWrite -- ^ O_RDWR - deriving (Read, Show, Eq, Ord) - --- XXX use oAPPEND, oEXCL, oNOCTTY etc? -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) - --- | Default values for the 'OpenFlags'. --- -defaultOpenFlags :: OpenFlags -defaultOpenFlags = - OpenFlags - { append = False - , exclusive = False - , noctty = True -- XXX ? - , nonBlock = True -- XXX ? - , trunc = False - , nofollow = False - , creat = Nothing - , cloexec = False - , directory = False - , sync = False - } - -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_ :: - 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 = - Fd <$> c_openat c_fd path all_flags mode_w - - 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 - --- | Open a file relative to an optional directory file descriptor. --- --- {-# INLINE openFdAtWith #-} -openFdAtWith :: - 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 = - 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 - - where - - open mode flags = openFdAtWith flags Nothing fp mode - -openFile :: PosixPath -> IOMode -> IO Handle -openFile = openFileWith 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) - -#endif diff --git a/core/src/Streamly/Internal/FileSystem/Posix/File.hsc b/core/src/Streamly/Internal/FileSystem/Posix/File.hsc new file mode 100644 index 0000000000..f341c25474 --- /dev/null +++ b/core/src/Streamly/Internal/FileSystem/Posix/File.hsc @@ -0,0 +1,318 @@ +module Streamly.Internal.FileSystem.Posix.File + ( +#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) + + -- * File open flags + OpenFlags (..) + , 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 + , openAt + , close + + -- * Handle based + , openFile + , withFile + -- , openBinaryFile + -- , withBinaryFile + + -- Re-exported + , Fd +#endif + ) where + +#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) + +------------------------------------------------------------------------------- +-- Imports +------------------------------------------------------------------------------- + +import Data.Bits ((.|.), (.&.), complement) +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 System.Posix.Types (Fd(..), CMode(..)) + +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 +-- 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. + +#include + +------------------------------------------------------------------------------- +-- Create mode +------------------------------------------------------------------------------- + +-- | 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) + +{- +#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 + +#define AT_FDCWD (-100) +-} + +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. +newtype OpenFlags = OpenFlags CInt + +##define MK_FLAG_API(name,x) \ +{-# INLINE name #-}; \ +name :: OpenFlags -> OpenFlags; \ +name (OpenFlags flags) = OpenFlags (flags .|. x) + +-- foreign import ccall unsafe "HsBase.h __hscore_o_rdonly" o_RDONLY :: CInt +-- These affect the first two bits in flags. +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) \ +{-# 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,#{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'. +-- +-- By default a 0 value is used, no flag is set. See the open system call man +-- page. +defaultOpenFlags :: OpenFlags +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 (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 + -> OpenFlags -- ^ Append, exclusive, etc. + -> Maybe FileMode -- ^ Create mode + -> IO Fd +openAtCString fdMay path flags cmode = + Fd <$> c_openat c_fd path flags1 mode + + where + + c_fd = maybe (#{const 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. +-- +-- 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 + -> OpenFlags -- ^ Append, exclusive, truncate, etc. + -> Maybe FileMode -- ^ Create mode + -> IO Fd +openAt fdMay path flags cmode = + Path.asCString path $ \cstr -> do + throwErrnoPathIfMinus1Retry "openAt" path + $ openAtCString fdMay cstr flags cmode + + +-- | 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 path iomode = do + case iomode of + 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 + + oflags1 = setNoCtty True $ setNonBlock True oflags + open1 = openAt Nothing path + +openFileFd :: PosixPath -> IOMode -> IO Fd +openFileFd = openFileFdWith defaultOpenFlags + +foreign import ccall unsafe "unistd.h close" + c_close :: CInt -> IO CInt + +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..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(..), openFd, openFdAt, closeFd) + (defaultOpenFlags, 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,10 @@ openDirStream p = -- DirStream the fd will be closed. openDirStreamAt :: Fd -> PosixPath -> IO DirStream openDirStreamAt fd p = do - fd1 <- openFdAt (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) @@ -854,7 +864,9 @@ readEitherByteChunksAt confMod (ppath, alldirs) = else return Nothing step _ ByteChunksAtInit0 = do - pfd <- liftIO $ openFd 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) @@ -863,7 +875,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 new file mode 100644 index 0000000000..06062ad12b --- /dev/null +++ b/core/src/Streamly/Internal/FileSystem/Windows/File.hsc @@ -0,0 +1,204 @@ +-- XXX When introducing platform specifc API, see Posix/File.hsc and design in +-- the same consistent way. +module Streamly.Internal.FileSystem.Windows.File + ( +#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.Concurrent (threadDelay) +import Control.Exception (onException) +import Control.Monad (when, void) +import Streamly.Internal.FileSystem.WindowsPath (WindowsPath) +import System.IO (IOMode(..), Handle) + +#if defined(__IO_MANAGER_WINIO__) +import GHC.IO.SubSystem +#else +import GHC.IO.Handle.FD (fdToHandle') +#include +#endif + +import qualified Streamly.Internal.FileSystem.File.Common as File +import qualified Streamly.Internal.FileSystem.WindowsPath as Path + +import Data.Bits +import Foreign.Ptr +import System.Win32 as Win32 hiding (createFile, failIfWithRetry) + +#include + +------------------------------------------------------------------------------- +-- Low level (fd returning) file opening APIs +------------------------------------------------------------------------------- + +-- 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 needRetry msg action = retryOrFail retries + + where + + delay = 100 * 1000 -- 100 ms + + -- KB article recommends 250/5 + retries = 20 :: Int + + -- retryOrFail :: Int -> IO a + retryOrFail times + | 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) + else errorWin msg + +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 = + 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__) + Win32.hANDLEToHandle h +#else + fd <- _open_osfhandle (fromIntegral (ptrToIntPtr h)) (#const _O_BINARY) + fdToHandle' fd Nothing False (Path.toString _fp) _iomode True +#endif + +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 + IoNative -> Win32.fILE_ATTRIBUTE_NORMAL .|. Win32.fILE_FLAG_OVERLAPPED + ) +#else + Win32.fILE_ATTRIBUTE_NORMAL +#endif + +------------------------------------------------------------------------------- +-- 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 :: WindowsPath -> IOMode -> IO Handle +openFileHandle p x = openFileFd False p x >>= fdToHandle p x + +-- | 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/core/streamly-core.cabal b/core/streamly-core.cabal index f014276b4a..8887775b4d 100644 --- a/core/streamly-core.cabal +++ b/core/streamly-core.cabal @@ -425,12 +425,14 @@ library , Streamly.Internal.FileSystem.WindowsPath.SegNode , Streamly.Internal.FileSystem.Handle - , Streamly.Internal.FileSystem.File - , 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 @@ -487,6 +489,7 @@ library , Streamly.Unicode.String -- Deprecated in 0.3.0 + , Streamly.Internal.FileSystem.File , Streamly.Internal.FileSystem.Dir , Streamly.FileSystem.Dir diff --git a/test/Streamly/Test/FileSystem/Handle.hs b/test/Streamly/Test/FileSystem/Handle.hs index 3209baa946..86c817f78b 100644 --- a/test/Streamly/Test/FileSystem/Handle.hs +++ b/test/Streamly/Test/FileSystem/Handle.hs @@ -20,21 +20,32 @@ import System.IO , hClose , hFlush , hSeek - , openFile + , hPutStr ) import System.IO.Temp (withSystemTempDirectory) +#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) 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 +74,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 +126,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 +147,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 +169,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 <-