From 8fc511af72f532ad5d78988e288d94e2882fe26e Mon Sep 17 00:00:00 2001 From: Adithya Kumar Date: Mon, 14 Oct 2024 18:46:42 +0530 Subject: [PATCH 01/23] Add File internals that work directly with Path --- .../Internal/FileSystem/File/Utils.hs | 93 +++ .../Streamly/Internal/FileSystem/FileIO.hs | 679 ++++++++++++++++++ .../Internal/FileSystem/Posix/File.hs | 196 +++++ .../Internal/FileSystem/Windows/File.hs | 194 +++++ core/streamly-core.cabal | 4 + 5 files changed, 1166 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/Posix/File.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/Posix/File.hs b/core/src/Streamly/Internal/FileSystem/Posix/File.hs new file mode 100644 index 0000000000..9a6336079f --- /dev/null +++ b/core/src/Streamly/Internal/FileSystem/Posix/File.hs @@ -0,0 +1,196 @@ +module Streamly.Internal.FileSystem.Posix.File + ( openExistingFile + , openFile + , openExistingFileWithCloseOnExec + , openFileWithCloseOnExec + ) where + +------------------------------------------------------------------------------- +-- Imports +------------------------------------------------------------------------------- + +import Data.Bits ((.|.)) +import Foreign.C.Error (getErrno, eINTR, errnoToIOError) +import Foreign.C.String (CString) +import Foreign.C.Types (CInt(..)) +import Streamly.Internal.FileSystem.PosixPath (PosixPath) +import System.IO (IOMode(..), Handle) +import System.Posix.IO (fdToHandle) +import System.Posix.Types (Fd(..), CMode(..), FileMode) + +import qualified Streamly.Internal.Data.Array as Array +import qualified Streamly.Internal.FileSystem.PosixPath as Path + +------------------------------------------------------------------------------- +-- Posix +------------------------------------------------------------------------------- + +data OpenMode = ReadOnly | WriteOnly | ReadWrite + deriving (Read, Show, Eq, Ord) + +-- |Correspond to some of the int flags from C's fcntl.h. +data OpenFileFlags = + OpenFileFlags { + append :: Bool, -- ^ O_APPEND + exclusive :: Bool, -- ^ O_EXCL, result is undefined if O_CREAT is False + -- + -- __NOTE__: 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 'OpenFileFlags' type. +-- +-- Each field of 'OpenFileFlags' is either 'False' or 'Nothing' +-- respectively. +defaultFileFlags :: OpenFileFlags +defaultFileFlags = + OpenFileFlags { + append = False, + exclusive = False, + noctty = False, + nonBlock = False, + trunc = False, + nofollow = False, + creat = Nothing, + cloexec = False, + directory = False, + sync = False + } + +defaultExistingFileFlags :: OpenFileFlags +defaultExistingFileFlags = defaultFileFlags { noctty = True, nonBlock = True, creat = Nothing } + +defaultFileFlags' :: OpenFileFlags +defaultFileFlags' = defaultFileFlags { noctty = True, nonBlock = True } + +withFilePath :: PosixPath -> (CString -> IO a) -> IO a +withFilePath p = Array.asCStringUnsafe (Path.toChunk p) + + +-- |Open and optionally create a file relative to an optional +-- directory file descriptor. +openat_ :: Maybe Fd -- ^ Optional directory file descriptor + -> CString -- ^ Pathname to open + -> OpenMode -- ^ Read-only, read-write or write-only + -> OpenFileFlags -- ^ Append, exclusive, etc. + -> IO Fd +openat_ fdMay str how (OpenFileFlags appendFlag exclusiveFlag nocttyFlag + nonBlockFlag truncateFlag nofollowFlag + creatFlag cloexecFlag directoryFlag + syncFlag) = + Fd <$> c_openat c_fd str all_flags mode_w + where + c_fd = maybe (-100) (\ (Fd fd) -> fd) fdMay + all_flags = creat .|. flags .|. open_mode + + flags = + (if appendFlag then (1024) else 0) .|. + (if exclusiveFlag then (128) else 0) .|. + (if nocttyFlag then (256) else 0) .|. + (if nonBlockFlag then (2048) else 0) .|. + (if truncateFlag then (512) else 0) .|. + (if nofollowFlag then (131072) else 0) .|. + (if cloexecFlag then (524288) else 0) .|. + (if directoryFlag then (65536) else 0) .|. + (if syncFlag then (1052672) else 0) + + (creat, mode_w) = case creatFlag of + Nothing -> (0,0) + Just x -> ((64), x) + + open_mode = case how of + ReadOnly -> (0) + WriteOnly -> (1) + ReadWrite -> (2) + +foreign import capi unsafe "HsUnix.h openat" + c_openat :: CInt -> CString -> CInt -> CMode -> IO CInt + +-- |Open and optionally create this file. See 'System.Posix.Files' +-- for information on how to use the 'FileMode' type. +openFd :: PosixPath + -> OpenMode + -> OpenFileFlags + -> IO Fd +openFd = openFdAt Nothing + +throwErrnoPathIfMinus1Retry :: (Eq a, Num a) + => String -> PosixPath -> IO a -> IO a +throwErrnoPathIfMinus1Retry loc path f = do + throwErrnoPathIfRetry (== -1) loc path f + +throwErrnoPathIfRetry :: (a -> Bool) -> String -> PosixPath -> IO a -> IO a +throwErrnoPathIfRetry pr loc rpath f = + do + res <- f + if pr res + then do + err <- getErrno + if err == eINTR + then throwErrnoPathIfRetry pr loc rpath f + else throwErrnoPath loc rpath + else return res + +throwErrnoPath :: String -> PosixPath -> IO a +throwErrnoPath loc path = + do + errno <- getErrno + -- XXX What if this decode fails? + -- The unix package catches this kind of an error + let path' = Path.toString path + ioError (errnoToIOError loc errno Nothing (Just path')) + +-- | Open a file relative to an optional directory file descriptor. +-- +-- Directory file descriptors can be used to avoid some race conditions when +-- navigating changing directory trees, or to retain access to a portion of the +-- directory tree that would otherwise become inaccessible after dropping +-- privileges. +openFdAt :: Maybe Fd -- ^ Optional directory file descriptor + -> PosixPath -- ^ Pathname to open + -> OpenMode -- ^ Read-only, read-write or write-only + -> OpenFileFlags -- ^ Append, exclusive, truncate, etc. + -> IO Fd +openFdAt fdMay name how flags = + withFilePath name $ \str -> + throwErrnoPathIfMinus1Retry "openFdAt" name $ openat_ fdMay str how flags + +openExistingFile_ :: OpenFileFlags -> PosixPath -> IOMode -> IO Handle +openExistingFile_ df fp iomode = fdToHandle =<< case iomode of + ReadMode -> open ReadOnly df + WriteMode -> open WriteOnly df { trunc = True } + AppendMode -> open WriteOnly df { append = True } + ReadWriteMode -> open ReadWrite df + where + open = openFd fp + +-- | Open an existing file and return the 'Handle'. +openExistingFile :: PosixPath -> IOMode -> IO Handle +openExistingFile = openExistingFile_ defaultExistingFileFlags + +openExistingFileWithCloseOnExec :: PosixPath -> IOMode -> IO Handle +openExistingFileWithCloseOnExec = openExistingFile_ defaultExistingFileFlags { cloexec = True } + +openFile_ :: OpenFileFlags -> PosixPath -> IOMode -> IO Handle +openFile_ df fp iomode = fdToHandle =<< 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 } + where + open = openFd fp + +-- | Open a file and return the 'Handle'. +openFile :: PosixPath -> IOMode -> IO Handle +openFile = openFile_ defaultFileFlags' + +openFileWithCloseOnExec :: PosixPath -> IOMode -> IO Handle +openFileWithCloseOnExec = openFile_ defaultFileFlags' { cloexec = True } 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 ec3a35e8fc..cbe143b10a 100644 --- a/core/streamly-core.cabal +++ b/core/streamly-core.cabal @@ -387,6 +387,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.ReadDir , Streamly.Internal.FileSystem.Windows.ReadDir @@ -561,6 +563,8 @@ library if os(linux) || os (darwin) || os(freebsd) build-depends: unix >= 2.7.0 && < 2.9 + exposed-modules: Streamly.Internal.FileSystem.Posix.File if os(windows) build-depends: Win32 >= 2.6 && < 2.14 + exposed-modules: Streamly.Internal.FileSystem.Windows.File From 24350d97c557cae02acf83446c733e5a55b36e30 Mon Sep 17 00:00:00 2001 From: Adithya Kumar Date: Mon, 4 Nov 2024 17:00:24 +0530 Subject: [PATCH 02/23] 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..d7b696f163 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 (flip 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 de903c3739c4d08df13e5864cdd6e8ff68506fff Mon Sep 17 00:00:00 2001 From: Adithya Kumar Date: Mon, 28 Oct 2024 17:02:16 +0530 Subject: [PATCH 03/23] Temporarily remove the hard stop on the CIs --- .github/workflows/haskell.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 807c5a3951..149c977639 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -62,7 +62,7 @@ jobs: SUBDIR: ${{ matrix.subdir }} runs-on: ${{ matrix.runner }} - continue-on-error: ${{ matrix.ignore_error }} + continue-on-error: true strategy: fail-fast: true matrix: From 8c4256c71d57de383a19ed81806f4d8ae49a3ccc Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Wed, 13 Nov 2024 15:18:40 +0530 Subject: [PATCH 04/23] Fix the imports in windows module --- core/src/Streamly/Internal/FileSystem/Windows/File.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/core/src/Streamly/Internal/FileSystem/Windows/File.hs b/core/src/Streamly/Internal/FileSystem/Windows/File.hs index 343a40c23b..4c01a621ad 100644 --- a/core/src/Streamly/Internal/FileSystem/Windows/File.hs +++ b/core/src/Streamly/Internal/FileSystem/Windows/File.hs @@ -13,7 +13,7 @@ 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 qualified System.Win32 as Win32 import Control.Monad (when, void) import Streamly.Internal.FileSystem.WindowsPath (WindowsPath) @@ -32,6 +32,7 @@ import Foreign.Marshal.Alloc import Foreign.Storable import qualified Streamly.Internal.FileSystem.WindowsPath as Path +import qualified Streamly.Internal.Data.Array as Array #include "windows_cconv.h" From 45e350f77e998c3a6a977533b24d0238fa92c978 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Wed, 13 Nov 2024 15:19:42 +0530 Subject: [PATCH 05/23] Temp: Remove all CIs other than Windows --- .circleci/config.yml | 220 ------------------ .cirrus.yml | 74 ------ .github/workflows/haskell.yml | 305 ------------------------- .github/workflows/packdiff.yml | 39 ---- .github/workflows/regression-check.yml | 174 -------------- 5 files changed, 812 deletions(-) delete mode 100644 .circleci/config.yml delete mode 100644 .cirrus.yml delete mode 100644 .github/workflows/haskell.yml delete mode 100644 .github/workflows/packdiff.yml delete mode 100644 .github/workflows/regression-check.yml diff --git a/.circleci/config.yml b/.circleci/config.yml deleted file mode 100644 index 675bc7c936..0000000000 --- a/.circleci/config.yml +++ /dev/null @@ -1,220 +0,0 @@ -version: 2.1 - -#----------------------------------------------------------------------------- -# packcheck-0.7.0 -# Packcheck global environment variables -#----------------------------------------------------------------------------- - -env: &env - environment: - # ------------------------------------------------------------------------ - # Common options - # ------------------------------------------------------------------------ - # GHC_OPTIONS: "-Werror" - # For updating see: https://downloads.haskell.org/~ghcup/ - GHCUP_VERSION: 0.1.20.0 - CABAL_REINIT_CONFIG: "y" - LC_ALL: "C.UTF-8" - - # ------------------------------------------------------------------------ - # What to build - # ------------------------------------------------------------------------ - # DISABLE_TEST: "y" - # DISABLE_BENCH: "y" - # DISABLE_DOCS: "y" - # DISABLE_SDIST_BUILD: "y" - # DISABLE_DIST_CHECKS: "y" - - # ------------------------------------------------------------------------ - # stack options - # ------------------------------------------------------------------------ - # Note requiring a specific version of stack using STACKVER may fail due to - # github API limit while checking and upgrading/downgrading to the specific - # version. - #STACKVER: "1.6.5" - STACK_UPGRADE: "y" - #RESOLVER: "lts-12" - - # ------------------------------------------------------------------------ - # cabal options - # ------------------------------------------------------------------------ - CABAL_CHECK_RELAX: "y" - CABAL_BUILD_OPTIONS: "-j1 --flag limit-build-mem" - - # ------------------------------------------------------------------------ - # Where to find the required tools - # ------------------------------------------------------------------------ - PATH: /sbin:/usr/sbin:/bin:/usr/bin - - # ------------------------------------------------------------------------ - # Location of packcheck.sh (the shell script invoked to perform CI tests ). - # ------------------------------------------------------------------------ - # You can either commit the packcheck.sh script at this path in your repo or - # you can use it by specifying the PACKCHECK_REPO_URL option below in which - # case it will be automatically copied from the packcheck repo to this path - # during CI tests. In any case it is finally invoked from this path. - PACKCHECK: "./packcheck.sh" - # If you have not committed packcheck.sh in your repo at PACKCHECK - # then it is automatically pulled from this URL. - PACKCHECK_GITHUB_URL: "https://raw.githubusercontent.com/composewell/packcheck" - PACKCHECK_GITHUB_COMMIT: "e575ff318c93add2a6d3f9107a52c5e37c666a98" - -executors: - amd64-executor: - docker: - - image: ubuntu:latest - x86-executor: - docker: - - image: i386/ubuntu:focal - -#----------------------------------------------------------------------------- -# Common utility stuff, not to be modified usually -#----------------------------------------------------------------------------- - -preinstall: &preinstall - run: | - apt-get update - # required for https/cache save and restore - apt-get install -y ca-certificates - - # Alternative way of installing ghc and cabal, directly from - # haskell.org instead of using ghcup. NOTE: this is for Debian - # only and is debian release specific. - # gnupg is required for apt-key to work - #apt-get install -y gnupg - #apt-key adv --keyserver keyserver.ubuntu.com --recv-keys BA3CBA3FFE22B574 - #echo "deb http://downloads.haskell.org/debian buster main" >> /etc/apt/sources.list - #apt-get update - - # required for outbound https for stack and for stack setup - apt-get install -y netbase xz-utils make - apt-get install -y zlib1g-dev - - # For ghcup to install ghc - if test -n "$GHCUP_VERSION" - then - apt-get install -y gcc - apt-get install -y g++ - fi - - # libgmp required by ghc for linking - apt-get install -y libgmp-dev - apt-get install -y libtinfo-dev - - # Required by cabal when git URL is specified in project file - apt-get install -y git - - # Required for and by packcheck - apt-get install -y curl - - # Get packcheck if needed - if test ! -e "$PACKCHECK" - then - if test -z "$PACKCHECK_GITHUB_COMMIT" - then - die "PACKCHECK_GITHUB_COMMIT is not specified." - fi - PACKCHECK_URL=${PACKCHECK_GITHUB_URL}/${PACKCHECK_GITHUB_COMMIT}/packcheck.sh - curl --fail -sL -o "$PACKCHECK" $PACKCHECK_URL || exit 1 - chmod +x $PACKCHECK - elif test ! -x "$PACKCHECK" - then - chmod +x $PACKCHECK - fi - -restore: &restore - # Needs to happen after installing ca-certificates - restore_cache: - keys: - - v1-{{ .Environment.CIRCLE_JOB }}-{{ .Branch }} - # Fallback to master branch's cache. - - v1-{{ .Environment.CIRCLE_JOB }}-master - # Fallback to any branch's cache. - - v1-{{ .Environment.CIRCLE_JOB }}- - -save: &save - save_cache: - key: v1-{{ .Environment.CIRCLE_JOB }}-{{ .Branch }} - paths: - - ~/.local - - ~/.cabal - - ~/.stack - - ~/.ghcup - -#----------------------------------------------------------------------------- -# Build matrix -#----------------------------------------------------------------------------- - -jobs: - cabal-ghc-8_6_5: - <<: *env - executor: amd64-executor - steps: - - checkout - - *restore - - *preinstall - - run: - environment: - GHCVER: "8.6.5" - CABALVER: "3.6.2.0" - CABAL_PROJECT: "cabal.project" - DISABLE_SDIST_BUILD: "yes" - CABAL_BUILD_OPTIONS: "--flag debug --flag -opt" - command: | - bash -c "$PACKCHECK cabal" - - *save - cabal-ghc-9_8_1-docspec: - <<: *env - executor: amd64-executor - steps: - - checkout - - *restore - - *preinstall - - run: - environment: - GHCVER: "9.8.1" - CABALVER: "3.10.1.0" - CABAL_PROJECT: "cabal.project.doctest" - DISABLE_SDIST_BUILD: "y" - DISABLE_TEST: "y" - DISABLE_BENCH: "y" - DISABLE_DOCS: "y" - ENABLE_DOCSPEC: "y" - DOCSPEC_URL: https://github.com/phadej/cabal-extras/releases/download/cabal-docspec-0.0.0.20210111/cabal-docspec-0.0.0.20210111.xz - DOCSPEC_OPTIONS: "--timeout 60 --check-properties --property-variables xs" - command: | - sed -i 's/other-modules:/exposed-modules:/g' streamly.cabal - sed -i 's/other-modules:/exposed-modules:/g' core/streamly-core.cabal - bash -c "$PACKCHECK cabal" - - *save - hlint-trailing-spaces: - <<: *env - executor: amd64-executor - steps: - - checkout - - *restore - - *preinstall - - run: - name: hlint and trailing spaces - environment: - DISABLE_SDIST_BUILD: "yes" - HLINT_VERSION: 3.6.1 - HLINT_OPTIONS: lint - HLINT_TARGETS: core/src src test benchmark - command: | - bash -c "$PACKCHECK hlint" || exit 1 - echo "Checking trailing spaces..." - count=$(find . -name "*.hs" -exec grep -H '\ $' {} \; | tee /dev/tty | wc -l) - exit $count - - *save - -workflows: - version: 2 - build: - jobs: - #- cabal-ghc-8_6_5: - # name: 8.6.5-debug-unoptimized - - cabal-ghc-9_8_1-docspec: - name: ghc-9.8.1-docspec - - hlint-trailing-spaces: - name: hlint and trailing spaces diff --git a/.cirrus.yml b/.cirrus.yml deleted file mode 100644 index 9e592fe1f3..0000000000 --- a/.cirrus.yml +++ /dev/null @@ -1,74 +0,0 @@ -freebsd_instance: - image_family: freebsd-14-0 - -task: - name: FreeBSD+packcheck+ghc-9.6.3+cabal-v2 - env: - LC_ALL: C.UTF-8 - BUILD: cabal-v2 - GHCUP_VERSION: 0.1.20.0 - DOCSPEC_URL: https://github.com/phadej/cabal-extras/releases/download/cabal-docspec-0.0.0.20210111/cabal-docspec-0.0.0.20210111.xz - DOCSPEC_OPTIONS: "--timeout 60 --check-properties --property-variables xs" - # GHCUP_GHC_OPTIONS: ${{ matrix.ghcup_ghc_options }} - GHCVER: 9.6.3 - CABALVER: 3.10.1.0 - DISABLE_DOCS: n - ENABLE_DOCSPEC: n - DISABLE_TEST: n - DISABLE_BENCH: n - DISABLE_DIST_CHECKS: y - # SDIST_OPTIONS: ${{ matrix.sdist_options }} - DISABLE_SDIST_BUILD: y - - # Cabal options - CABAL_REINIT_CONFIG: y - # CABAL_BUILD_OPTIONS: ${{ matrix.cabal_build_options }} --flag limit-build-mem - # CABAL_BUILD_TARGETS: ${{ matrix.cabal_build_targets }} - CABAL_PROJECT: cabal.project - CABAL_CHECK_RELAX: y - - # Stack options - # STACK_UPGRADE: "y" - # RESOLVER: ${{ matrix.resolver }} - # STACK_YAML: ${{ matrix.stack_yaml }} - # STACK_BUILD_OPTIONS: ${{ matrix.stack_build_options }} - - # packcheck location and revision - PACKCHECK: "./packcheck.sh" - PACKCHECK_GITHUB_URL: "https://raw.githubusercontent.com/composewell/packcheck" - PACKCHECK_GITHUB_COMMIT: "ccc55fd4b895e842ca6e2d8ac63aa4acc1c3209a" - - # Pull token from "secrets" setting of the github repo - # COVERALLS_TOKEN: ${{ secrets.COVERALLS_TOKEN }} - # COVERAGE: ${{ matrix.coverage }} - - # hlint - # HLINT_VERSION: 3.6.1 - # HLINT_OPTIONS: "lint" - # HLINT_TARGETS: "core/src src test benchmark" - - # Subdir - # SUBDIR: ${{ matrix.subdir }} - - deps_install_script: | - pkg install -y gmake - pkg install -y bash - - packcheck_install_script: | - if test ! -e "$PACKCHECK" - then - if test -z "$PACKCHECK_GITHUB_COMMIT" - then - die "PACKCHECK_GITHUB_COMMIT is not specified." - fi - PACKCHECK_URL=${PACKCHECK_GITHUB_URL}/${PACKCHECK_GITHUB_COMMIT}/packcheck.sh - curl --fail -sL -o "$PACKCHECK" $PACKCHECK_URL || exit 1 - chmod +x $PACKCHECK - elif test ! -x "$PACKCHECK" - then - chmod +x $PACKCHECK - fi - - packcheck_run_script: | - export PATH=$HOME/.local/bin:$HOME/.ghcup/bin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin:/usr/local/opt/curl/bin - bash -c "$PACKCHECK $BUILD" diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml deleted file mode 100644 index 149c977639..0000000000 --- a/.github/workflows/haskell.yml +++ /dev/null @@ -1,305 +0,0 @@ -name: Haskell CI - -on: - push: - branches: - - master - pull_request: - -jobs: - build: - name: GHC ${{matrix.name}} - env: - # packcheck environment variables - LC_ALL: C.UTF-8 - BUILD: ${{ matrix.build }} - # For updating see: https://downloads.haskell.org/~ghcup/ - GHCUP_VERSION: 0.1.20.0 - DOCSPEC_URL: https://github.com/phadej/cabal-extras/releases/download/cabal-docspec-0.0.0.20210111/cabal-docspec-0.0.0.20210111.xz - DOCSPEC_OPTIONS: "--timeout 60 --check-properties --property-variables xs" - GHCUP_GHC_OPTIONS: ${{ matrix.ghcup_ghc_options }} - GHCVER: ${{ matrix.ghc_version }} - CABALVER: ${{ matrix.cabal_version }} - DISABLE_DOCS: ${{ matrix.disable_docs }} - ENABLE_DOCSPEC: ${{ matrix.enable_docspec }} - DISABLE_TEST: ${{ matrix.disable_test }} - DISABLE_BENCH: ${{ matrix.disable_bench }} - DISABLE_DIST_CHECKS: ${{ matrix.disable_dist_checks }} - SDIST_OPTIONS: ${{ matrix.sdist_options }} - DISABLE_SDIST_BUILD: ${{ matrix.disable_sdist_build }} - - # Cabal options - CABAL_REINIT_CONFIG: y - # Github has machines with 2 CPUS and 6GB memory so the cabal jobs - # default (ncpus) is good, this can be checked from the packcheck - # output in case it changes. - CABAL_BUILD_OPTIONS: ${{ matrix.cabal_build_options }} - CABAL_BUILD_TARGETS: ${{ matrix.cabal_build_targets }} - CABAL_PROJECT: ${{ matrix.cabal_project }} - CABAL_CHECK_RELAX: y - - # Stack options - STACK_UPGRADE: "y" - RESOLVER: ${{ matrix.resolver }} - STACK_YAML: ${{ matrix.stack_yaml }} - STACK_BUILD_OPTIONS: ${{ matrix.stack_build_options }} - - # packcheck location and revision - PACKCHECK: "./packcheck.sh" - PACKCHECK_GITHUB_URL: "https://raw.githubusercontent.com/composewell/packcheck" - PACKCHECK_GITHUB_COMMIT: "e575ff318c93add2a6d3f9107a52c5e37c666a98" - - # Pull token from "secrets" setting of the github repo - COVERALLS_TOKEN: ${{ secrets.COVERALLS_TOKEN }} - COVERAGE: ${{ matrix.coverage }} - - # hlint - HLINT_VERSION: 3.6.1 - HLINT_OPTIONS: "lint" - HLINT_TARGETS: "core/src src test benchmark" - - # Subdir - SUBDIR: ${{ matrix.subdir }} - - runs-on: ${{ matrix.runner }} - continue-on-error: true - strategy: - fail-fast: true - matrix: - # The order is important to optimize fail-fast. - name: - - 9.10.1-Werror - # - 9.8.1-docspec - # - 8.10.7-coverage - - # Note: if cabal.project is not specified benchmarks and tests won't - # run. But we need at least one test where we test without - # cabal.project because that is how hackage would build it. - include: - - name: head - ghc_version: head - # The URL may change, to find a working URL go to https://gitlab.haskell.org/ghc/ghc/-/jobs/ - # Find a debian10/11/12 job, click on a passed/failed status, at the - # end of the output you will find the tar.xz name, put that tar - # name after "raw/", and put the job name after "job=". - # Also see https://github.com/mpickering/ghc-artefact-nix/blob/master/gitlab-artifact.nix - # - # May also use ghcup for installing ghc head version, use the - # version "LatestNightly", and the following config: - # ghcup config add-release-channel https://ghc.gitlab.haskell.org/ghcup-metadata/ghcup-nightlies-0.0.7.yaml - ghcup_ghc_options: "-u https://gitlab.haskell.org/ghc/ghc/-/jobs/artifacts/master/raw/ghc-x86_64-linux-deb10-int_native-validate.tar.xz?job=x86_64-linux-deb10-int_native-validate" - runner: ubuntu-latest - build: cabal - cabal_build_options: "--flag limit-build-mem" - cabal_version: 3.12.1.0 - cabal_project: cabal.project.ghc-head - disable_sdist_build: "y" - ignore_error: true - - name: 9.12.1-alpha - ghc_version: head - ghcup_ghc_options: "-u https://downloads.haskell.org/ghc/9.12.1-alpha1/ghc-9.12.20241014-x86_64-deb12-linux.tar.xz" - runner: ubuntu-latest - build: cabal - cabal_build_options: "--flag limit-build-mem" - cabal_version: 3.12.1.0 - cabal_project: cabal.project.ghc-head - disable_sdist_build: "y" - ignore_error: false - # Note: use linux for warning build for convenient dev testing - - name: 9.10.1-Werror - ghc_version: 9.10.1 - runner: ubuntu-latest - build: cabal - cabal_build_options: "--flag limit-build-mem" - cabal_version: 3.12.1.0 - disable_sdist_build: "y" - cabal_project: cabal.project.Werror - ignore_error: false - - name: 9.10.1-macos - ghc_version: 9.10.1 - runner: macos-latest - build: cabal - cabal_build_options: "--flag limit-build-mem" - cabal_version: 3.12.1.0 - disable_sdist_build: "y" - cabal_project: cabal.project - ignore_error: false - - name: 9.10.1-fusion-inspection - ghc_version: 9.10.1 - runner: ubuntu-latest - build: cabal - cabal_version: 3.12.1.0 - disable_sdist_build: "y" - cabal_project: cabal.project - cabal_build_options: "--flag fusion-plugin --flag inspection" - ignore_error: false - - name: 9.8.2-macos-stack - runner: macos-latest - build: stack - resolver: nightly-2024-09-26 - stack_yaml: stack.yaml - disable_docs: "y" - disable_sdist_build: "y" - disable_dist_checks: "y" - disable_test: "y" - disable_bench: "y" - #sdist_options: "--ignore-check" - stack_build_options: "-v" - cabal_version: 3.12.1.0 - ignore_error: true - # - name: 9.8.1-docspec - # ghc_version: 9.8.1 - # runner: ubuntu-latest - # build: cabal - # cabal_version: 3.10.1.0 - # cabal_project: cabal.project.doctest - # disable_test: "y" - # disable_bench: "y" - # disable_docs: "y" - # enable_docspec: "y" - # disable_sdist_build: "y" - # ignore_error: false - - name: 9.8.1-fusion-inspection - ghc_version: 9.8.1 - runner: ubuntu-latest - build: cabal - cabal_version: 3.12.1.0 - disable_sdist_build: "y" - cabal_project: cabal.project - cabal_build_options: "--flag fusion-plugin --flag inspection" - ignore_error: false - - name: 9.6.3-macos - ghc_version: 9.6.3 - runner: macos-latest - build: cabal - cabal_version: 3.10.1.0 - disable_sdist_build: "y" - cabal_project: cabal.project - ignore_error: false - - name: 9.4.7 - ghc_version: 9.4.7 - runner: ubuntu-latest - build: cabal - cabal_version: 3.8.1.0 - disable_sdist_build: "y" - cabal_project: cabal.project - ignore_error: false - - name: 9.2.8 - ghc_version: 9.2.8 - runner: ubuntu-latest - build: cabal - cabal_project: cabal.project - cabal_version: 3.6.2.0 - disable_sdist_build: "y" - ignore_error: false - - name: 9.0.2-streamly-sdist - ghc_version: 9.0.2 - runner: ubuntu-latest - build: cabal - cabal_version: 3.6.2.0 - cabal_project: cabal.project.streamly - ignore_error: true - - name: 9.0.2-streamly-core-sdist - ghc_version: 9.0.2 - runner: ubuntu-latest - build: cabal - cabal_version: 3.6.2.0 - subdir: core - ignore_error: false - - name: 8.10.7-noopt - runner: ubuntu-latest - build: cabal - cabal_version: 3.6.2.0 - cabal_project: cabal.project - disable_sdist_build: "y" - disable_docs: "y" - disable_dist_checks: "y" - cabal_build_options: "--flags \"-opt\"" - ignore_error: false - # - name: 8.10.7-coverage - # ghc_version: 8.10.7 - # runner: ubuntu-latest - # coverage: "y" - # cabal_version: 3.6.2.0 - # ignore_error: false - - name: 8.8.4 - ghc_version: 8.8.4 - runner: ubuntu-latest - build: cabal - cabal_version: 3.6.2.0 - cabal_project: cabal.project - disable_sdist_build: "y" - disable_docs: "y" - ignore_error: false - - name: 8.6.5-debug-unoptimized - ghc_version: 8.6.5 - runner: ubuntu-latest - build: cabal - cabal_version: 3.6.2.0 - cabal_project: cabal.project - cabal_build_options: "--flag debug --flag -opt" - disable_sdist_build: "y" - disable_docs: "y" - ignore_error: false - # - name: hlint - # build: hlint - # runner: ubuntu-latest - # ignore_error: true - - steps: - - uses: actions/checkout@v2 - - - uses: actions/cache@v1 - name: Cache common directories - with: - path: | - ~/.local - ~/.cabal - ~/.stack - ~/.ghcup - # Bump the key version to clear the cache - key: ${{ runner.os }}-${{ matrix.ghc_version }}-cabal-v2 - - - name: Download packcheck - run: | - if test ! -e "$PACKCHECK" - then - if test -z "$PACKCHECK_GITHUB_COMMIT" - then - die "PACKCHECK_GITHUB_COMMIT is not specified." - fi - PACKCHECK_URL=${PACKCHECK_GITHUB_URL}/${PACKCHECK_GITHUB_COMMIT}/packcheck.sh - curl --fail -sL -o "$PACKCHECK" $PACKCHECK_URL || exit 1 - chmod +x $PACKCHECK - elif test ! -x "$PACKCHECK" - then - chmod +x $PACKCHECK - fi - - - name: Run tests - run: | - if test -n "$COVERAGE" - then - # Run tests with coverage - cabal update - # Build hpc-coveralls if needed - sudo apt-get install -y libcurl4-gnutls-dev - export PATH=$HOME/.cabal/bin:$PATH - which hpc-coveralls 2>/dev/null || cabal install --project-file cabal.project.hpc-coveralls hpc-coveralls - # Run tests and upload results to coveralls.io - bin/test.sh --coverage --raw - # XXX Uncomment this and fix it properly later - # hpc-coveralls --repo-token="$COVERALLS_TOKEN" --coverage-mode=StrictlyFullLines - else - # /usr/local/opt/curl/bin for macOS - export PATH=$HOME/.local/bin:$HOME/.ghcup/bin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin:/usr/local/opt/curl/bin - if test -n "$SUBDIR" - then - mv "$PACKCHECK" "$SUBDIR/packcheck.sh" - # This is required as dist-newstyle will be created on the top level - # directory as it is considered the working dir. - rm cabal.project - cd "$SUBDIR" - fi - bash -c "$PACKCHECK $BUILD" - fi diff --git a/.github/workflows/packdiff.yml b/.github/workflows/packdiff.yml deleted file mode 100644 index b2915c3e08..0000000000 --- a/.github/workflows/packdiff.yml +++ /dev/null @@ -1,39 +0,0 @@ -name: Packdiff - -on: pull_request - -jobs: - packdiff: - - runs-on: ubuntu-latest - - steps: - - - name: Download ghc - run: | - GHCUP_VER=0.1.20.0 - curl -sL -o ./ghcup https://downloads.haskell.org/~ghcup/$GHCUP_VER/x86_64-linux-ghcup-$GHCUP_VER - chmod +x ./ghcup - GHCVER=9.8.1 - ./ghcup install ghc $GHCVER - ./ghcup set ghc $GHCVER - cabal update - - - uses: actions/cache@v2 - name: Cache ~/.cabal - with: - path: | - ~/.cabal - # Bump the key version to clear the cache - key: cache-v2 - - - name: Checkout the current branch - uses: actions/checkout@v2 - with: - fetch-depth: 0 - - - name: Run packdiff on streamly-core - run: cabal run packdiff --project-file=cabal.project.packdiff -- diff streamly-core $(git rev-parse origin/master) streamly-core $(git rev-parse HEAD) - - - name: Run packdiff on streamly - run: cabal run packdiff --project-file=cabal.project.packdiff -- diff streamly $(git rev-parse origin/master) streamly $(git rev-parse HEAD) diff --git a/.github/workflows/regression-check.yml b/.github/workflows/regression-check.yml deleted file mode 100644 index 4b72d52eda..0000000000 --- a/.github/workflows/regression-check.yml +++ /dev/null @@ -1,174 +0,0 @@ -name: Regression checking - -on: - workflow_dispatch: - pull_request: - -# References: -# https://docs.github.com/en/actions/managing-workflow-runs/manually-running-a-workflow -# https://docs.github.com/en/actions/using-workflows/reusing-workflows#reusable-workflows-and-starter-workflows -# https://docs.github.com/en/actions/using-workflows/workflow-syntax-for-github-actions#onworkflow_call -# https://docs.github.com/en/actions/learn-github-actions/contexts#about-contexts-and-expressions - -# You can override the default DIFF_CUTOFF_PERCENT by specifying a cutoff along -# with the benchmark target. -# Eg, "Data.Async:12" where "Data.Async" is the benchmark target, ":" is the -# seperator, and "12" is the new cutoff percent -#---------------------------------------------------------------------- -#-- Benchmarks listed in alphabetical order -#---------------------------------------------------------------------- -jobs: - check-regressions: - env: - CI_BENCHMARKS_WITH_CUTOFF: >- - Data.Array - Data.Array.Generic - Data.Array.Stream - Data.Fold - Data.Fold.Prelude - Data.Fold.Window - Data.MutArray - Data.Parser - Data.ParserK - Data.ParserK.Chunked - Data.ParserK.Chunked.Generic - Data.RingArray - Data.Scanl.Window - Data.Serialize - Data.Stream - Data.Stream.Concurrent - Data.Stream.ConcurrentEager - Data.Stream.ConcurrentInterleaved - Data.Stream.ConcurrentOrdered - Data.StreamK:6 - Data.Unbox - Data.Unbox.Derive.TH - Data.Unfold - FileSystem.Handle - Unicode.Parser - Unicode.Stream - CI_FIELDS: allocated - CI_DIFF_CUTOFF_PERCENT: 3 - - runs-on: ubuntu-latest - - steps: - - - name: Update environment - run: | - CI_BENCHMARKS="" - for i in $CI_BENCHMARKS_WITH_CUTOFF - do - bname=$(echo "$i" | cut -d: -f1) - CI_BENCHMARKS="$CI_BENCHMARKS $bname" - done - echo "CI_BENCHMARKS=$CI_BENCHMARKS" >> $GITHUB_ENV - - - name: Download ghc - run: | - GHCUP_VER=0.1.18.0 - curl -sL -o ./ghcup https://downloads.haskell.org/~ghcup/$GHCUP_VER/x86_64-linux-ghcup-$GHCUP_VER - chmod +x ./ghcup - GHCVER=9.2.7 - ./ghcup install ghc $GHCVER - ./ghcup set ghc $GHCVER - cabal update - - - uses: actions/cache@v2 - name: Cache ~/.cabal - with: - path: | - ~/.cabal - # Bump the key version to clear the cache - key: cache-v2 - - - name: Cache bench-runner from pr - id: cache-bench-runner-pr - uses: actions/cache@v2 - with: - path: bench-runner - # Bump the key version to clear the cache - key: bench-runner-v1 - - # ----------------------------------------------------------------- - # -- Install bench-report in the current directory - # ----------------------------------------------------------------- - - - name: Checkout the current branch - uses: actions/checkout@v2 - with: - clean: false - - - name: Install bench-runner - run: | - cabal install bench-runner --project-file=cabal.project.report --installdir=./ - - # ----------------------------------------------------------------- - # -- Generate reports for the base branch and upload - # ----------------------------------------------------------------- - - - name: Checkout the base branch - uses: actions/checkout@v2 - with: - ref: master - clean: false - - - name: Run benchmarks - run: | - ./bench-runner --package-name streamly-benchmarks --package-version 0.0.0 --targets "$CI_BENCHMARKS" --raw - - - name: Move charts to charts-master - run: mv charts charts-master - - # ----------------------------------------------------------------- - # -- Download, generate reports for the current branch and append - # ----------------------------------------------------------------- - - - name: Checkout the current branch - uses: actions/checkout@v2 - with: - clean: false - - - name: Copy charts-master to charts - run: cp -r charts-master charts - - - name: Run benchmarks and append - run: | - ./bench-runner --package-name streamly-benchmarks --package-version 0.0.0 --targets "$CI_BENCHMARKS" --raw --append - - # ----------------------------------------------------------------- - # -- Compare - # ----------------------------------------------------------------- - - - name: List all benchmarks - run: | - ./bench-runner --package-name streamly-benchmarks --package-version 0.0.0 --targets "$CI_BENCHMARKS" --no-measure - - - name: Compare benchmarks - run: | - - EXIT_STATUS=0 - - for i in $CI_BENCHMARKS_WITH_CUTOFF - do - arrI=(${i//:/ }) - - bname=${arrI[0]} - cutoff=${arrI[1]} - - test -z "$cutoff" && cutoff=$CI_DIFF_CUTOFF_PERCENT - - echo - echo "Checking $bname for regressions greater than $cutoff percent" - ! ./bench-runner \ - --package-name streamly-benchmarks \ - --package-version 0.0.0 \ - --targets "$bname" \ - --fields "$CI_FIELDS" \ - --no-measure --silent \ - --diff-cutoff-percent $cutoff \ - | grep -v "^$" - test $? -eq 1 && EXIT_STATUS=1 - done - - exit $EXIT_STATUS From 67fedf7c5366d4ef6b763a7985ff88ce86b4372b Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Wed, 13 Nov 2024 15:38:58 +0530 Subject: [PATCH 06/23] Keep only createFile in Windows File module --- .../Internal/FileSystem/Windows/File.hs | 57 ++++++++++--------- 1 file changed, 30 insertions(+), 27 deletions(-) diff --git a/core/src/Streamly/Internal/FileSystem/Windows/File.hs b/core/src/Streamly/Internal/FileSystem/Windows/File.hs index 4c01a621ad..2d8919f194 100644 --- a/core/src/Streamly/Internal/FileSystem/Windows/File.hs +++ b/core/src/Streamly/Internal/FileSystem/Windows/File.hs @@ -1,8 +1,9 @@ module Streamly.Internal.FileSystem.Windows.File - ( openExistingFile - , openFile - , openExistingFileWithCloseOnExec - , openFileWithCloseOnExec + ( -- openExistingFile + -- openFile + createFile + -- , openExistingFileWithCloseOnExec + -- , openFileWithCloseOnExec ) where ------------------------------------------------------------------------------- @@ -43,7 +44,6 @@ import qualified Streamly.Internal.Data.Array as Array 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 @@ -81,6 +81,30 @@ createFile name access share mb_attr mode flag mb_h = failIfWithRetry (==iNVALID_HANDLE_VALUE) (unwords ["CreateFile",show name]) $ c_CreateFile c_name access share (maybePtr mb_attr) mode flag (maybePtr mb_h) +{- +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 + +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 + -- | Open a file and return the 'Handle'. openFile :: WindowsPath -> IOMode -> IO Handle openFile fp iomode = bracketOnError @@ -121,17 +145,6 @@ openFile fp iomode = bracketOnError 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 @@ -182,14 +195,4 @@ 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 +-} From 50bee496861bac37c199d449e9b6daeffc3212b0 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Wed, 13 Nov 2024 18:50:40 +0530 Subject: [PATCH 07/23] Update createFile --- .../Internal/FileSystem/Windows/File.hs | 78 ++++++++++++------- 1 file changed, 49 insertions(+), 29 deletions(-) diff --git a/core/src/Streamly/Internal/FileSystem/Windows/File.hs b/core/src/Streamly/Internal/FileSystem/Windows/File.hs index 2d8919f194..ac71b571b7 100644 --- a/core/src/Streamly/Internal/FileSystem/Windows/File.hs +++ b/core/src/Streamly/Internal/FileSystem/Windows/File.hs @@ -1,47 +1,52 @@ module Streamly.Internal.FileSystem.Windows.File - ( -- openExistingFile + ( +#if defined(mingw32_HOST_OS) || defined(__MINGW32__) -- openFile createFile - -- , openExistingFileWithCloseOnExec - -- , openFileWithCloseOnExec +#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 qualified System.Win32 as Win32 import Control.Monad (when, void) import Streamly.Internal.FileSystem.WindowsPath (WindowsPath) +import System.IO (IOMode(..), Handle) -import System.Win32.Types - +#if 0 #if defined(__IO_MANAGER_WINIO__) import GHC.IO.SubSystem #else import GHC.IO.Handle.FD (fdToHandle') #include #endif +#endif + +import qualified Streamly.Internal.FileSystem.WindowsPath as Path +import qualified Streamly.Internal.Data.Array as Array +import Data.Bits import Foreign.C.String +import Foreign.C.Types import Foreign.Ptr import Foreign.Marshal.Alloc import Foreign.Storable +import System.Win32 as Win32 hiding (createFile, failIfWithRetry) +import System.Win32.Types -import qualified Streamly.Internal.FileSystem.WindowsPath as Path -import qualified Streamly.Internal.Data.Array as Array - -#include "windows_cconv.h" +#include ------------------------------------------------------------------------------- -- Windows ------------------------------------------------------------------------------- -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 @@ -49,37 +54,51 @@ foreign import WINDOWS_CCONV unsafe "windows.h CreateFileW" -- 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 + + where + + delay = 100*1000 -- in ms, we use threadDelay + -- KB article recommends 250/5 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) + | 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 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) + failIfWithRetry + (== iNVALID_HANDLE_VALUE) + (unwords ["CreateFile", show name]) + $ c_CreateFile + c_name access share (maybePtr mb_attr) mode flag (maybePtr mb_h) {- maxShareMode :: Win32.ShareMode @@ -196,3 +215,4 @@ openExistingFileWithCloseOnExec :: WindowsPath -> IOMode -> IO Handle openExistingFileWithCloseOnExec = openExistingFile -} +#endif From 5d9345398b85ef82fec573fec6293e5ed664c8f4 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Wed, 13 Nov 2024 19:01:13 +0530 Subject: [PATCH 08/23] fixup: Windows File --- .../Internal/FileSystem/Windows/File.hs | 72 ++++--------------- 1 file changed, 12 insertions(+), 60 deletions(-) diff --git a/core/src/Streamly/Internal/FileSystem/Windows/File.hs b/core/src/Streamly/Internal/FileSystem/Windows/File.hs index ac71b571b7..a1007d1c9a 100644 --- a/core/src/Streamly/Internal/FileSystem/Windows/File.hs +++ b/core/src/Streamly/Internal/FileSystem/Windows/File.hs @@ -17,14 +17,12 @@ import Control.Monad (when, void) import Streamly.Internal.FileSystem.WindowsPath (WindowsPath) import System.IO (IOMode(..), Handle) -#if 0 #if defined(__IO_MANAGER_WINIO__) import GHC.IO.SubSystem #else import GHC.IO.Handle.FD (fdToHandle') #include #endif -#endif import qualified Streamly.Internal.FileSystem.WindowsPath as Path import qualified Streamly.Internal.Data.Array as Array @@ -101,16 +99,21 @@ createFile name access share mb_attr mode flag mb_h = c_name access share (maybePtr mb_attr) mode flag (maybePtr mb_h) {- -maxShareMode :: Win32.ShareMode +maxShareMode :: ShareMode maxShareMode = - Win32.fILE_SHARE_DELETE .|. - Win32.fILE_SHARE_READ .|. - Win32.fILE_SHARE_WRITE + Win32.fILE_SHARE_DELETE + .|. Win32.fILE_SHARE_READ + .|. Win32.fILE_SHARE_WRITE -writeShareMode :: Win32.ShareMode +writeShareMode :: ShareMode writeShareMode = - Win32.fILE_SHARE_DELETE .|. - Win32.fILE_SHARE_READ + Win32.fILE_SHARE_DELETE + .|. Win32.fILE_SHARE_READ + +#if !defined(__IO_MANAGER_WINIO__) +foreign import ccall "_open_osfhandle" + _open_osfhandle :: CIntPtr -> CInt -> IO CInt +#endif toHandle :: WindowsPath -> IOMode -> Win32.HANDLE -> IO Handle #if defined(__IO_MANAGER_WINIO__) @@ -163,56 +166,5 @@ openFile fp iomode = bracketOnError AppendMode -> writeShareMode ReadWriteMode -> maxShareMode - --- | 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 - -} #endif From 9a6e2da125b42e32bbcf098659e8ff0080eabb27 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Wed, 13 Nov 2024 19:04:27 +0530 Subject: [PATCH 09/23] 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 cbe143b10a..7246f878ad 100644 --- a/core/streamly-core.cabal +++ b/core/streamly-core.cabal @@ -392,6 +392,7 @@ library , Streamly.Internal.FileSystem.DirIO , Streamly.Internal.FileSystem.Posix.ReadDir , Streamly.Internal.FileSystem.Windows.ReadDir + , Streamly.Internal.FileSystem.Windows.File -- RingArray Arrays , Streamly.Internal.Data.RingArray @@ -567,4 +568,3 @@ library if os(windows) build-depends: Win32 >= 2.6 && < 2.14 - exposed-modules: Streamly.Internal.FileSystem.Windows.File From b6f4c5c69f7fdef40b21b8e8548c8587796249d5 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Wed, 13 Nov 2024 19:20:58 +0530 Subject: [PATCH 10/23] Add toHandle --- .../Internal/FileSystem/Windows/File.hsc | 21 +++++++++++-------- 1 file changed, 12 insertions(+), 9 deletions(-) diff --git a/core/src/Streamly/Internal/FileSystem/Windows/File.hsc b/core/src/Streamly/Internal/FileSystem/Windows/File.hsc index a1007d1c9a..abb30d4fef 100644 --- a/core/src/Streamly/Internal/FileSystem/Windows/File.hsc +++ b/core/src/Streamly/Internal/FileSystem/Windows/File.hsc @@ -14,6 +14,7 @@ module Streamly.Internal.FileSystem.Windows.File import Control.Exception (bracketOnError, try, SomeException, onException) import Control.Monad (when, void) +import Control.Monad.Concurrent (threadDelay) import Streamly.Internal.FileSystem.WindowsPath (WindowsPath) import System.IO (IOMode(..), Handle) @@ -56,12 +57,11 @@ failIfWithRetry needRetry msg action = retryOrFail retries where - delay = 100*1000 -- in ms, we use threadDelay + delay = 100 * 1000 -- 100 ms -- KB article recommends 250/5 retries = 20 :: Int - -- retryOrFail :: Int -> IO a retryOrFail times | times <= 0 = errorWin msg @@ -98,7 +98,6 @@ createFile name access share mb_attr mode flag mb_h = $ c_CreateFile c_name access share (maybePtr mb_attr) mode flag (maybePtr mb_h) -{- maxShareMode :: ShareMode maxShareMode = Win32.fILE_SHARE_DELETE @@ -115,18 +114,22 @@ foreign import ccall "_open_osfhandle" _open_osfhandle :: CIntPtr -> CInt -> IO CInt #endif -toHandle :: WindowsPath -> IOMode -> Win32.HANDLE -> IO Handle +win2HsHandle :: WindowsPath -> IOMode -> Win32.HANDLE -> IO Handle +win2HsHandle _fp iomode h = do + when (iomode == AppendMode ) + $ void $ Win32.setFilePointerEx h 0 Win32.fILE_END #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 + fdToHandle' fd Nothing False (Path.toString _fp) iomode True #endif +toHandle :: WindowsPath -> IOMode -> Win32.HANDLE -> IO Handle +toHandle fp iomode h = + win2HsHandle fp iomode h `onException` Win32.closeHandle h + +{- -- | Open a file and return the 'Handle'. openFile :: WindowsPath -> IOMode -> IO Handle openFile fp iomode = bracketOnError From 7b98b4206a55b3bfda7d2eccee4b0095e9b2a63a Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Wed, 13 Nov 2024 19:41:40 +0530 Subject: [PATCH 11/23] Add Windows/openFile --- .../Internal/FileSystem/Windows/File.hsc | 100 +++++++++--------- 1 file changed, 52 insertions(+), 48 deletions(-) diff --git a/core/src/Streamly/Internal/FileSystem/Windows/File.hsc b/core/src/Streamly/Internal/FileSystem/Windows/File.hsc index abb30d4fef..a5d9b9ef00 100644 --- a/core/src/Streamly/Internal/FileSystem/Windows/File.hsc +++ b/core/src/Streamly/Internal/FileSystem/Windows/File.hsc @@ -1,8 +1,7 @@ module Streamly.Internal.FileSystem.Windows.File ( #if defined(mingw32_HOST_OS) || defined(__MINGW32__) - -- openFile - createFile + openFile #endif ) where @@ -12,9 +11,9 @@ module Streamly.Internal.FileSystem.Windows.File -- Imports ------------------------------------------------------------------------------- +import Control.Concurrent (threadDelay) import Control.Exception (bracketOnError, try, SomeException, onException) import Control.Monad (when, void) -import Control.Monad.Concurrent (threadDelay) import Streamly.Internal.FileSystem.WindowsPath (WindowsPath) import System.IO (IOMode(..), Handle) @@ -88,8 +87,8 @@ createFile :: -> Maybe LPSECURITY_ATTRIBUTES -> CreateMode -> FileAttributeOrFlag - -> Maybe HANDLE - -> IO HANDLE + -> Maybe Win32.HANDLE + -> IO Win32.HANDLE createFile name access share mb_attr mode flag mb_h = withFilePath name $ \ c_name -> failIfWithRetry @@ -98,17 +97,6 @@ createFile name access share mb_attr mode flag mb_h = $ c_CreateFile c_name access share (maybePtr mb_attr) mode flag (maybePtr mb_h) -maxShareMode :: ShareMode -maxShareMode = - Win32.fILE_SHARE_DELETE - .|. Win32.fILE_SHARE_READ - .|. Win32.fILE_SHARE_WRITE - -writeShareMode :: ShareMode -writeShareMode = - Win32.fILE_SHARE_DELETE - .|. Win32.fILE_SHARE_READ - #if !defined(__IO_MANAGER_WINIO__) foreign import ccall "_open_osfhandle" _open_osfhandle :: CIntPtr -> CInt -> IO CInt @@ -129,16 +117,45 @@ toHandle :: WindowsPath -> IOMode -> Win32.HANDLE -> IO Handle toHandle fp iomode h = win2HsHandle fp iomode h `onException` Win32.closeHandle h -{- --- | Open a file and return the 'Handle'. openFile :: WindowsPath -> IOMode -> IO Handle -openFile fp iomode = bracketOnError - (createFile - fp - accessMode - shareMode - Nothing - createMode +openFile fp iomode = + bracketOnError create 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 + + 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 + + fileAttr = #if defined(__IO_MANAGER_WINIO__) (case ioSubSystem of IoPOSIX -> Win32.fILE_ATTRIBUTE_NORMAL @@ -147,27 +164,14 @@ openFile 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.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 - --} + + create = + createFile + fp + accessMode + shareMode + Nothing + createMode + fileAttr + Nothing #endif From be5cdc697223121ce060abf4f24f822df8694430 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Wed, 13 Nov 2024 20:16:53 +0530 Subject: [PATCH 12/23] Cleanup File/utils --- .../Internal/FileSystem/File/Utils.hs | 58 +++++++++++-------- 1 file changed, 33 insertions(+), 25 deletions(-) diff --git a/core/src/Streamly/Internal/FileSystem/File/Utils.hs b/core/src/Streamly/Internal/FileSystem/File/Utils.hs index 8365572bda..c9dfa09e3e 100644 --- a/core/src/Streamly/Internal/FileSystem/File/Utils.hs +++ b/core/src/Streamly/Internal/FileSystem/File/Utils.hs @@ -9,7 +9,7 @@ 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) @@ -52,42 +52,50 @@ addHandleFinalizer handle finalizer = do #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' } +addFilePathToIOError fun fp ioe = + let !str = Path.toString fp + in ioe + { ioe_location = fun + , ioe_filename = Just str + } -augmentError :: String -> Path -> IO a -> IO a -augmentError str osfp = flip catchException (ioError . addFilePathToIOError str osfp) +catchWith :: String -> Path -> IO a -> IO a +catchWith str path io = + catchException io (ioError . addFilePathToIOError str path) -withOpenFile' - :: Path - -> IOMode -> Bool -> Bool -> Bool - -> (Handle -> IO r) -> Bool -> IO r -withOpenFile' fp iomode binary existing cloExec action close_finally = +withOpenFile + :: Bool + -> Bool + -> Bool + -> Bool + -> Path + -> IOMode + -> (Handle -> IO r) + -> IO r +withOpenFile binary _existing _cloExec close_finally 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 + -} + hndl <- Platform.openFile fp iomode addHandleFinalizer hndl handleFinalizer when binary $ hSetBinaryMode hndl True r <- restore (action hndl) `onException` hClose hndl when close_finally $ hClose hndl pure r --- | 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. +-- XXX Write this using openFile instead? 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 +withFile path iomode act = + (catchWith "withFile" path + $ withOpenFile False False False True path iomode (try . act)) + >>= either ioError pure + +openFile :: Path -> IOMode -> IO Handle +openFile path iomode = + catchWith "openFile" path + $ withOpenFile False False False False path iomode pure From eec48b204777c7d90c3930434d199fd6ed5f3644 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Wed, 13 Nov 2024 20:20:13 +0530 Subject: [PATCH 13/23] Use _open_osfhandle from Win32 --- core/src/Streamly/Internal/FileSystem/Windows/File.hsc | 2 ++ 1 file changed, 2 insertions(+) diff --git a/core/src/Streamly/Internal/FileSystem/Windows/File.hsc b/core/src/Streamly/Internal/FileSystem/Windows/File.hsc index a5d9b9ef00..18567edd8a 100644 --- a/core/src/Streamly/Internal/FileSystem/Windows/File.hsc +++ b/core/src/Streamly/Internal/FileSystem/Windows/File.hsc @@ -97,10 +97,12 @@ createFile name access share mb_attr mode flag mb_h = $ c_CreateFile c_name access share (maybePtr mb_attr) mode flag (maybePtr mb_h) +{- #if !defined(__IO_MANAGER_WINIO__) foreign import ccall "_open_osfhandle" _open_osfhandle :: CIntPtr -> CInt -> IO CInt #endif +-} win2HsHandle :: WindowsPath -> IOMode -> Win32.HANDLE -> IO Handle win2HsHandle _fp iomode h = do From e72d0e9f5c72b738c4305827246d9e74847c3989 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Wed, 13 Nov 2024 20:32:24 +0530 Subject: [PATCH 14/23] Cleanup Posix.File --- .../Internal/FileSystem/Posix/File.hs | 105 ++++++++++-------- 1 file changed, 59 insertions(+), 46 deletions(-) diff --git a/core/src/Streamly/Internal/FileSystem/Posix/File.hs b/core/src/Streamly/Internal/FileSystem/Posix/File.hs index 9a6336079f..1b470d14b1 100644 --- a/core/src/Streamly/Internal/FileSystem/Posix/File.hs +++ b/core/src/Streamly/Internal/FileSystem/Posix/File.hs @@ -1,10 +1,15 @@ module Streamly.Internal.FileSystem.Posix.File - ( openExistingFile - , openFile - , openExistingFileWithCloseOnExec - , openFileWithCloseOnExec + ( +#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) + openFile + -- , openExistingFile + -- , openExistingFileWithCloseOnExec + -- , openFileWithCloseOnExec +#endif ) where +#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) + ------------------------------------------------------------------------------- -- Imports ------------------------------------------------------------------------------- @@ -65,16 +70,9 @@ defaultFileFlags = sync = False } -defaultExistingFileFlags :: OpenFileFlags -defaultExistingFileFlags = defaultFileFlags { noctty = True, nonBlock = True, creat = Nothing } - defaultFileFlags' :: OpenFileFlags defaultFileFlags' = defaultFileFlags { noctty = True, nonBlock = True } -withFilePath :: PosixPath -> (CString -> IO a) -> IO a -withFilePath p = Array.asCStringUnsafe (Path.toChunk p) - - -- |Open and optionally create a file relative to an optional -- directory file descriptor. openat_ :: Maybe Fd -- ^ Optional directory file descriptor @@ -87,7 +85,9 @@ openat_ fdMay str how (OpenFileFlags appendFlag exclusiveFlag nocttyFlag creatFlag cloexecFlag directoryFlag syncFlag) = Fd <$> c_openat c_fd str all_flags mode_w - where + + where + c_fd = maybe (-100) (\ (Fd fd) -> fd) fdMay all_flags = creat .|. flags .|. open_mode @@ -114,18 +114,14 @@ openat_ fdMay str how (OpenFileFlags appendFlag exclusiveFlag nocttyFlag foreign import capi unsafe "HsUnix.h openat" c_openat :: CInt -> CString -> CInt -> CMode -> IO CInt --- |Open and optionally create this file. See 'System.Posix.Files' --- for information on how to use the 'FileMode' type. -openFd :: PosixPath - -> OpenMode - -> OpenFileFlags - -> IO Fd -openFd = openFdAt Nothing - -throwErrnoPathIfMinus1Retry :: (Eq a, Num a) - => String -> PosixPath -> IO a -> IO a -throwErrnoPathIfMinus1Retry loc path f = do - throwErrnoPathIfRetry (== -1) loc path f +throwErrnoPath :: String -> PosixPath -> IO a +throwErrnoPath loc path = + do + errno <- getErrno + -- XXX What if this decode fails? + -- The unix package catches this kind of an error + let path' = Path.toString path + ioError (errnoToIOError loc errno Nothing (Just path')) throwErrnoPathIfRetry :: (a -> Bool) -> String -> PosixPath -> IO a -> IO a throwErrnoPathIfRetry pr loc rpath f = @@ -139,14 +135,13 @@ throwErrnoPathIfRetry pr loc rpath f = else throwErrnoPath loc rpath else return res -throwErrnoPath :: String -> PosixPath -> IO a -throwErrnoPath loc path = - do - errno <- getErrno - -- XXX What if this decode fails? - -- The unix package catches this kind of an error - let path' = Path.toString path - ioError (errnoToIOError loc errno Nothing (Just path')) +throwErrnoPathIfMinus1Retry :: (Eq a, Num a) + => String -> PosixPath -> IO a -> IO a +throwErrnoPathIfMinus1Retry loc path f = do + throwErrnoPathIfRetry (== -1) loc path f + +withFilePath :: PosixPath -> (CString -> IO a) -> IO a +withFilePath p = Array.asCStringUnsafe (Path.toChunk p) -- | Open a file relative to an optional directory file descriptor. -- @@ -163,15 +158,44 @@ openFdAt fdMay name how flags = withFilePath name $ \str -> throwErrnoPathIfMinus1Retry "openFdAt" name $ openat_ fdMay str how flags +-- |Open and optionally create this file. See 'System.Posix.Files' +-- for information on how to use the 'FileMode' type. +openFd :: PosixPath + -> OpenMode + -> OpenFileFlags + -> IO Fd +openFd = openFdAt Nothing + +openFile_ :: OpenFileFlags -> PosixPath -> IOMode -> IO Handle +openFile_ df fp iomode = fdToHandle =<< 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 } + + where + + open = openFd fp + +-- | Open a file and return the 'Handle'. +openFile :: PosixPath -> IOMode -> IO Handle +openFile = openFile_ defaultFileFlags' + +{- openExistingFile_ :: OpenFileFlags -> PosixPath -> IOMode -> IO Handle openExistingFile_ df fp iomode = fdToHandle =<< case iomode of ReadMode -> open ReadOnly df WriteMode -> open WriteOnly df { trunc = True } AppendMode -> open WriteOnly df { append = True } ReadWriteMode -> open ReadWrite df - where + + where + open = openFd fp +defaultExistingFileFlags :: OpenFileFlags +defaultExistingFileFlags = defaultFileFlags { noctty = True, nonBlock = True, creat = Nothing } + -- | Open an existing file and return the 'Handle'. openExistingFile :: PosixPath -> IOMode -> IO Handle openExistingFile = openExistingFile_ defaultExistingFileFlags @@ -179,18 +203,7 @@ openExistingFile = openExistingFile_ defaultExistingFileFlags openExistingFileWithCloseOnExec :: PosixPath -> IOMode -> IO Handle openExistingFileWithCloseOnExec = openExistingFile_ defaultExistingFileFlags { cloexec = True } -openFile_ :: OpenFileFlags -> PosixPath -> IOMode -> IO Handle -openFile_ df fp iomode = fdToHandle =<< 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 } - where - open = openFd fp - --- | Open a file and return the 'Handle'. -openFile :: PosixPath -> IOMode -> IO Handle -openFile = openFile_ defaultFileFlags' - openFileWithCloseOnExec :: PosixPath -> IOMode -> IO Handle openFileWithCloseOnExec = openFile_ defaultFileFlags' { cloexec = True } +-} +#endif From 723d22904766f25cf8c186ea1dff3dbb1fe40a0a Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Wed, 13 Nov 2024 20:35:15 +0530 Subject: [PATCH 15/23] Move Posix.File module outside conditionals --- core/streamly-core.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/streamly-core.cabal b/core/streamly-core.cabal index 7246f878ad..a74245e9a6 100644 --- a/core/streamly-core.cabal +++ b/core/streamly-core.cabal @@ -392,6 +392,7 @@ library , Streamly.Internal.FileSystem.DirIO , Streamly.Internal.FileSystem.Posix.ReadDir , Streamly.Internal.FileSystem.Windows.ReadDir + , Streamly.Internal.FileSystem.Posix.File , Streamly.Internal.FileSystem.Windows.File -- RingArray Arrays @@ -564,7 +565,6 @@ library if os(linux) || os (darwin) || os(freebsd) build-depends: unix >= 2.7.0 && < 2.9 - exposed-modules: Streamly.Internal.FileSystem.Posix.File if os(windows) build-depends: Win32 >= 2.6 && < 2.14 From 6e020830c0f951836e2fa317d09e7ff2194700f0 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Wed, 13 Nov 2024 20:37:03 +0530 Subject: [PATCH 16/23] Use Path.toString instead of show --- core/src/Streamly/Internal/FileSystem/Windows/File.hsc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/src/Streamly/Internal/FileSystem/Windows/File.hsc b/core/src/Streamly/Internal/FileSystem/Windows/File.hsc index 18567edd8a..976d7c7231 100644 --- a/core/src/Streamly/Internal/FileSystem/Windows/File.hsc +++ b/core/src/Streamly/Internal/FileSystem/Windows/File.hsc @@ -93,7 +93,7 @@ createFile name access share mb_attr mode flag mb_h = withFilePath name $ \ c_name -> failIfWithRetry (== iNVALID_HANDLE_VALUE) - (unwords ["CreateFile", show name]) + (unwords ["CreateFile", Path.toString name]) $ c_CreateFile c_name access share (maybePtr mb_attr) mode flag (maybePtr mb_h) From 24bf583a8b97e6e01db92dbde4024211a2f14292 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Wed, 13 Nov 2024 22:24:14 +0530 Subject: [PATCH 17/23] Remove redundant imports from Windows/File --- .../Streamly/Internal/FileSystem/Windows/File.hsc | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/core/src/Streamly/Internal/FileSystem/Windows/File.hsc b/core/src/Streamly/Internal/FileSystem/Windows/File.hsc index 976d7c7231..1381b638fb 100644 --- a/core/src/Streamly/Internal/FileSystem/Windows/File.hsc +++ b/core/src/Streamly/Internal/FileSystem/Windows/File.hsc @@ -12,7 +12,7 @@ module Streamly.Internal.FileSystem.Windows.File ------------------------------------------------------------------------------- import Control.Concurrent (threadDelay) -import Control.Exception (bracketOnError, try, SomeException, onException) +import Control.Exception (bracketOnError, onException) import Control.Monad (when, void) import Streamly.Internal.FileSystem.WindowsPath (WindowsPath) import System.IO (IOMode(..), Handle) @@ -28,13 +28,13 @@ import qualified Streamly.Internal.FileSystem.WindowsPath as Path import qualified Streamly.Internal.Data.Array as Array import Data.Bits -import Foreign.C.String -import Foreign.C.Types +-- import Foreign.C.String +-- import Foreign.C.Types import Foreign.Ptr -import Foreign.Marshal.Alloc -import Foreign.Storable +-- import Foreign.Marshal.Alloc +-- import Foreign.Storable import System.Win32 as Win32 hiding (createFile, failIfWithRetry) -import System.Win32.Types +-- import System.Win32.Types #include From 4c61acdb3a4ff233d99b77aef9d5471e4f86db24 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Thu, 14 Nov 2024 00:25:05 +0530 Subject: [PATCH 18/23] Keep only FileSystem.handle tests --- test/streamly-tests.cabal | 772 +++++++++++++++++++------------------- 1 file changed, 385 insertions(+), 387 deletions(-) diff --git a/test/streamly-tests.cabal b/test/streamly-tests.cabal index bef27c55f4..21970cea2b 100644 --- a/test/streamly-tests.cabal +++ b/test/streamly-tests.cabal @@ -219,400 +219,398 @@ common always-optimized -- Test suites in alphabetical order ------------------------------------------------------------------------------- -test-suite Data.Array - import: test-options - type: exitcode-stdio-1.0 - main-is: Streamly/Test/Data/Array.hs - ghc-options: -main-is Streamly.Test.Data.Array.main - -test-suite Data.Array.Generic - import: test-options - type: exitcode-stdio-1.0 - main-is: Streamly/Test/Data/Array/Generic.hs - ghc-options: -main-is Streamly.Test.Data.Array.Generic.main - if flag(use-streamly-core) - buildable: False - -test-suite Data.Array.Stream - import: test-options - type: exitcode-stdio-1.0 - main-is: Streamly/Test/Data/Array/Stream.hs - if flag(use-streamly-core) - buildable: False - -test-suite Data.Binary - import: test-options - type: exitcode-stdio-1.0 - main-is: Streamly/Test/Serialize/Serializable.hs - -test-suite Data.Fold - import: test-options - type: exitcode-stdio-1.0 - main-is: Streamly/Test/Data/Fold.hs - -test-suite Data.Fold.Window - import: test-options - type: exitcode-stdio-1.0 - main-is: Streamly/Test/Data/Fold/Window.hs - ghc-options: -main-is Streamly.Test.Data.Fold.Window.main - --- The Streamly.Data.List needs to be fixed to enable this --- test-suite Data.List +-- test-suite Data.Array +-- import: test-options +-- type: exitcode-stdio-1.0 +-- main-is: Streamly/Test/Data/Array.hs +-- ghc-options: -main-is Streamly.Test.Data.Array.main +-- +-- test-suite Data.Array.Generic +-- import: test-options +-- type: exitcode-stdio-1.0 +-- main-is: Streamly/Test/Data/Array/Generic.hs +-- ghc-options: -main-is Streamly.Test.Data.Array.Generic.main +-- if flag(use-streamly-core) +-- buildable: False +-- +-- test-suite Data.Array.Stream +-- import: test-options +-- type: exitcode-stdio-1.0 +-- main-is: Streamly/Test/Data/Array/Stream.hs +-- if flag(use-streamly-core) +-- buildable: False +-- +-- test-suite Data.Binary +-- import: test-options +-- type: exitcode-stdio-1.0 +-- main-is: Streamly/Test/Serialize/Serializable.hs +-- +-- test-suite Data.Fold +-- import: test-options +-- type: exitcode-stdio-1.0 +-- main-is: Streamly/Test/Data/Fold.hs +-- +-- test-suite Data.Fold.Window +-- import: test-options +-- type: exitcode-stdio-1.0 +-- main-is: Streamly/Test/Data/Fold/Window.hs +-- ghc-options: -main-is Streamly.Test.Data.Fold.Window.main +-- +-- -- The Streamly.Data.List needs to be fixed to enable this +-- -- test-suite Data.List +-- -- import: test-options +-- -- type: exitcode-stdio-1.0 +-- -- main-is: Streamly/Test/Data/List.hs +-- -- cpp-options: -DUSE_STREAMLY_LIST +-- -- if !flag(dev) +-- -- buildable: False +-- +-- test-suite Data.List.Base -- import: test-options -- type: exitcode-stdio-1.0 -- main-is: Streamly/Test/Data/List.hs --- cpp-options: -DUSE_STREAMLY_LIST --- if !flag(dev) +-- +-- test-suite Data.MutArray +-- import: test-options +-- type: exitcode-stdio-1.0 +-- main-is: Streamly/Test/Data/MutArray.hs +-- ghc-options: -main-is Streamly.Test.Data.MutArray.main +-- +-- test-suite Data.Parser +-- import: test-options +-- type: exitcode-stdio-1.0 +-- main-is: Streamly/Test/Data/Parser.hs +-- if flag(limit-build-mem) +-- ghc-options: +RTS -M4000M -RTS +-- +-- test-suite Data.ParserK +-- import: test-options +-- type: exitcode-stdio-1.0 +-- main-is: Streamly/Test/Data/ParserK.hs +-- if flag(limit-build-mem) +-- ghc-options: +RTS -M1500M -RTS +-- +-- test-suite Data.RingArray +-- import: test-options +-- type: exitcode-stdio-1.0 +-- main-is: Streamly/Test/Data/RingArray.hs +-- ghc-options: -main-is Streamly.Test.Data.RingArray.main +-- +-- -- XXX Rename to MutByteArray +-- test-suite Data.Serialize +-- import: test-options +-- type: exitcode-stdio-1.0 +-- main-is: Streamly/Test/Data/Serialize.hs +-- other-modules: +-- Streamly.Test.Data.Serialize.TH +-- Streamly.Test.Data.Serialize.CompatV0 +-- Streamly.Test.Data.Serialize.CompatV1 +-- ghc-options: -main-is Streamly.Test.Data.Serialize.main +-- if flag(limit-build-mem) +-- ghc-options: +RTS -M1500M -RTS +-- +-- test-suite Data.Serialize.Derive.TH +-- import: test-options +-- type: exitcode-stdio-1.0 +-- cpp-options: -DUSE_SERIALIZE +-- main-is: Streamly/Test/Data/Unbox.hs +-- ghc-options: -main-is Streamly.Test.Data.Unbox.main +-- +-- test-suite Data.Serialize.ENABLE_constructorTagAsString +-- import: test-options +-- type: exitcode-stdio-1.0 +-- main-is: Streamly/Test/Data/Serialize.hs +-- other-modules: +-- Streamly.Test.Data.Serialize.TH +-- Streamly.Test.Data.Serialize.CompatV0 +-- Streamly.Test.Data.Serialize.CompatV1 +-- cpp-options: -DENABLE_constructorTagAsString +-- ghc-options: -main-is Streamly.Test.Data.Serialize.main +-- if flag(limit-build-mem) +-- ghc-options: +RTS -M1500M -RTS +-- +-- test-suite Data.SmallArray +-- import: test-options +-- type: exitcode-stdio-1.0 +-- main-is: Streamly/Test/Data/SmallArray.hs +-- ghc-options: -main-is Streamly.Test.Data.SmallArray.main +-- if !flag(dev) || flag(use-streamly-core) -- buildable: False - -test-suite Data.List.Base - import: test-options - type: exitcode-stdio-1.0 - main-is: Streamly/Test/Data/List.hs - -test-suite Data.MutArray - import: test-options - type: exitcode-stdio-1.0 - main-is: Streamly/Test/Data/MutArray.hs - ghc-options: -main-is Streamly.Test.Data.MutArray.main - -test-suite Data.Parser - import: test-options - type: exitcode-stdio-1.0 - main-is: Streamly/Test/Data/Parser.hs - if flag(limit-build-mem) - ghc-options: +RTS -M4000M -RTS - -test-suite Data.ParserK - import: test-options - type: exitcode-stdio-1.0 - main-is: Streamly/Test/Data/ParserK.hs - if flag(limit-build-mem) - ghc-options: +RTS -M1500M -RTS - -test-suite Data.RingArray - import: test-options - type: exitcode-stdio-1.0 - main-is: Streamly/Test/Data/RingArray.hs - ghc-options: -main-is Streamly.Test.Data.RingArray.main - --- XXX Rename to MutByteArray -test-suite Data.Serialize - import: test-options - type: exitcode-stdio-1.0 - main-is: Streamly/Test/Data/Serialize.hs - other-modules: - Streamly.Test.Data.Serialize.TH - Streamly.Test.Data.Serialize.CompatV0 - Streamly.Test.Data.Serialize.CompatV1 - ghc-options: -main-is Streamly.Test.Data.Serialize.main - if flag(limit-build-mem) - ghc-options: +RTS -M1500M -RTS - -test-suite Data.Serialize.Derive.TH - import: test-options - type: exitcode-stdio-1.0 - cpp-options: -DUSE_SERIALIZE - main-is: Streamly/Test/Data/Unbox.hs - ghc-options: -main-is Streamly.Test.Data.Unbox.main - -test-suite Data.Serialize.ENABLE_constructorTagAsString - import: test-options - type: exitcode-stdio-1.0 - main-is: Streamly/Test/Data/Serialize.hs - other-modules: - Streamly.Test.Data.Serialize.TH - Streamly.Test.Data.Serialize.CompatV0 - Streamly.Test.Data.Serialize.CompatV1 - cpp-options: -DENABLE_constructorTagAsString - ghc-options: -main-is Streamly.Test.Data.Serialize.main - if flag(limit-build-mem) - ghc-options: +RTS -M1500M -RTS - -test-suite Data.SmallArray - import: test-options - type: exitcode-stdio-1.0 - main-is: Streamly/Test/Data/SmallArray.hs - ghc-options: -main-is Streamly.Test.Data.SmallArray.main - if !flag(dev) || flag(use-streamly-core) - buildable: False - -test-suite Data.Stream - import: test-options - type: exitcode-stdio-1.0 - main-is: Streamly/Test/Data/Stream.hs - ghc-options: -main-is Streamly.Test.Data.Stream.main - if flag(limit-build-mem) - ghc-options: +RTS -M1500M -RTS - -test-suite Data.Stream.Concurrent - import: test-options - type: exitcode-stdio-1.0 - main-is: Streamly/Test/Data/Stream/Concurrent.hs - ghc-options: -main-is Streamly.Test.Data.Stream.Concurrent.main - if flag(use-streamly-core) - buildable: False - -test-suite Data.Stream.Time - import: test-options - type: exitcode-stdio-1.0 - main-is: Streamly/Test/Data/Stream/Time.hs - ghc-options: -main-is Streamly.Test.Data.Stream.Time.main - if flag(use-streamly-core) - buildable: False - -test-suite Data.Stream.Rate - import:always-optimized - type: exitcode-stdio-1.0 - main-is: Streamly/Test/Data/Stream/Rate.hs - ghc-options: -main-is Streamly.Test.Data.Stream.Rate.main - if flag(dev) - buildable: True - else - buildable: False - if flag(use-streamly-core) - buildable: False - --- XXX Rename to MutByteArray.Unbox -test-suite Data.Unbox.Derive.Generic - import: test-options - type: exitcode-stdio-1.0 - main-is: Streamly/Test/Data/Unbox.hs - ghc-options: -main-is Streamly.Test.Data.Unbox.main - -test-suite Data.Unbox.Derive.TH - import: test-options - type: exitcode-stdio-1.0 - cpp-options: -DUSE_TH - main-is: Streamly/Test/Data/Unbox.hs - ghc-options: -main-is Streamly.Test.Data.Unbox.main - -test-suite Data.Unbox.TH - import: test-options - type: exitcode-stdio-1.0 - main-is: Streamly/Test/Data/Unbox/TH.hs - ghc-options: -main-is Streamly.Test.Data.Unbox.TH.main - -test-suite Data.Unfold - import: test-options - type: exitcode-stdio-1.0 - main-is: Streamly/Test/Data/Unfold.hs - -test-suite FileSystem.Event - import: test-options - type: exitcode-stdio-1.0 - ghc-options: -main-is Streamly.Test.FileSystem.Event - main-is: Streamly/Test/FileSystem/Event.hs - other-modules: Streamly.Test.FileSystem.Event.Common - if !(os(linux) || os(darwin) || os(windows)) || flag(use-streamly-core) - buildable: False - -test-suite FileSystem.Event.Darwin - import: test-options - type: exitcode-stdio-1.0 - main-is: Streamly/Test/FileSystem/Event/Darwin.hs - other-modules: Streamly.Test.FileSystem.Event.Common - cpp-options: -DFILESYSTEM_EVENT_DARWIN - ghc-options: -main-is Streamly.Test.FileSystem.Event.Darwin - if !os(darwin) || flag(use-streamly-core) - buildable: False - -test-suite FileSystem.Event.Linux - import: test-options - type: exitcode-stdio-1.0 - main-is: Streamly/Test/FileSystem/Event/Linux.hs - other-modules: Streamly.Test.FileSystem.Event.Common - cpp-options: -DFILESYSTEM_EVENT_LINUX - ghc-options: -main-is Streamly.Test.FileSystem.Event.Linux - if !os(linux) || flag(use-streamly-core) - buildable: False - -test-suite FileSystem.Event.Windows - import: test-options - type: exitcode-stdio-1.0 - main-is: Streamly/Test/FileSystem/Event/Windows.hs - other-modules: Streamly.Test.FileSystem.Event.Common - cpp-options: -DFILESYSTEM_EVENT_WINDOWS - ghc-options: -main-is Streamly.Test.FileSystem.Event.Windows - if !os(windows) || flag(use-streamly-core) - buildable: False - +-- +-- test-suite Data.Stream +-- import: test-options +-- type: exitcode-stdio-1.0 +-- main-is: Streamly/Test/Data/Stream.hs +-- ghc-options: -main-is Streamly.Test.Data.Stream.main +-- if flag(limit-build-mem) +-- ghc-options: +RTS -M1500M -RTS +-- +-- test-suite Data.Stream.Concurrent +-- import: test-options +-- type: exitcode-stdio-1.0 +-- main-is: Streamly/Test/Data/Stream/Concurrent.hs +-- ghc-options: -main-is Streamly.Test.Data.Stream.Concurrent.main +-- if flag(use-streamly-core) +-- buildable: False +-- +-- test-suite Data.Stream.Time +-- import: test-options +-- type: exitcode-stdio-1.0 +-- main-is: Streamly/Test/Data/Stream/Time.hs +-- ghc-options: -main-is Streamly.Test.Data.Stream.Time.main +-- if flag(use-streamly-core) +-- buildable: False +-- +-- test-suite Data.Stream.Rate +-- import:always-optimized +-- type: exitcode-stdio-1.0 +-- main-is: Streamly/Test/Data/Stream/Rate.hs +-- ghc-options: -main-is Streamly.Test.Data.Stream.Rate.main +-- if flag(dev) +-- buildable: True +-- else +-- buildable: False +-- if flag(use-streamly-core) +-- buildable: False +-- +-- -- XXX Rename to MutByteArray.Unbox +-- test-suite Data.Unbox.Derive.Generic +-- import: test-options +-- type: exitcode-stdio-1.0 +-- main-is: Streamly/Test/Data/Unbox.hs +-- ghc-options: -main-is Streamly.Test.Data.Unbox.main +-- +-- test-suite Data.Unbox.Derive.TH +-- import: test-options +-- type: exitcode-stdio-1.0 +-- cpp-options: -DUSE_TH +-- main-is: Streamly/Test/Data/Unbox.hs +-- ghc-options: -main-is Streamly.Test.Data.Unbox.main +-- +-- test-suite Data.Unbox.TH +-- import: test-options +-- type: exitcode-stdio-1.0 +-- main-is: Streamly/Test/Data/Unbox/TH.hs +-- ghc-options: -main-is Streamly.Test.Data.Unbox.TH.main +-- +-- test-suite Data.Unfold +-- import: test-options +-- type: exitcode-stdio-1.0 +-- main-is: Streamly/Test/Data/Unfold.hs +-- +-- test-suite FileSystem.Event +-- import: test-options +-- type: exitcode-stdio-1.0 +-- ghc-options: -main-is Streamly.Test.FileSystem.Event +-- main-is: Streamly/Test/FileSystem/Event.hs +-- other-modules: Streamly.Test.FileSystem.Event.Common +-- if !(os(linux) || os(darwin) || os(windows)) || flag(use-streamly-core) +-- buildable: False +-- +-- test-suite FileSystem.Event.Darwin +-- import: test-options +-- type: exitcode-stdio-1.0 +-- main-is: Streamly/Test/FileSystem/Event/Darwin.hs +-- other-modules: Streamly.Test.FileSystem.Event.Common +-- cpp-options: -DFILESYSTEM_EVENT_DARWIN +-- ghc-options: -main-is Streamly.Test.FileSystem.Event.Darwin +-- if !os(darwin) || flag(use-streamly-core) +-- buildable: False +-- +-- test-suite FileSystem.Event.Linux +-- import: test-options +-- type: exitcode-stdio-1.0 +-- main-is: Streamly/Test/FileSystem/Event/Linux.hs +-- other-modules: Streamly.Test.FileSystem.Event.Common +-- cpp-options: -DFILESYSTEM_EVENT_LINUX +-- ghc-options: -main-is Streamly.Test.FileSystem.Event.Linux +-- if !os(linux) || flag(use-streamly-core) +-- buildable: False +-- +-- test-suite FileSystem.Event.Windows +-- import: test-options +-- type: exitcode-stdio-1.0 +-- main-is: Streamly/Test/FileSystem/Event/Windows.hs +-- other-modules: Streamly.Test.FileSystem.Event.Common +-- cpp-options: -DFILESYSTEM_EVENT_WINDOWS +-- ghc-options: -main-is Streamly.Test.FileSystem.Event.Windows +-- if !os(windows) || flag(use-streamly-core) +-- buildable: False +-- test-suite FileSystem.Handle import: test-options type: exitcode-stdio-1.0 main-is: Streamly/Test/FileSystem/Handle.hs ghc-options: -main-is Streamly.Test.FileSystem.Handle.main - if flag(use-streamly-core) - buildable: False - -test-suite Network.Inet.TCP - import: lib-options - type: exitcode-stdio-1.0 - main-is: Streamly/Test/Network/Inet/TCP.hs - ghc-options: -rtsopts -fno-ignore-asserts - include-dirs: . - build-depends: streamly-tests - -- Cannot killThread in listen/accept on Windows threaded runtime - if !os(windows) - ghc-options: -threaded -with-rtsopts=-N - if flag(use-streamly-core) - buildable: False - -test-suite Network.Socket - import: lib-options - type: exitcode-stdio-1.0 - main-is: Streamly/Test/Network/Socket.hs - ghc-options: -rtsopts -fno-ignore-asserts - include-dirs: . - build-depends: streamly-tests - -- Cannot killThread in listen/accept on Windows threaded runtime - if !os(windows) - ghc-options: -threaded -with-rtsopts=-N - if flag(use-streamly-core) - buildable: False - -test-suite Unicode.Char - import: test-options - type: exitcode-stdio-1.0 - main-is: Streamly/Test/Unicode/Char.hs - ghc-options: -main-is Streamly.Test.Unicode.Char.main - if flag(use-streamly-core) || !flag(dev) - buildable: False - -test-suite Unicode.Parser - import: test-options - type: exitcode-stdio-1.0 - main-is: Streamly/Test/Unicode/Parser.hs - ghc-options: -main-is Streamly.Test.Unicode.Parser.main - if flag(use-streamly-core) - buildable: False - -test-suite Unicode.Stream - import: test-options - type: exitcode-stdio-1.0 - main-is: Streamly/Test/Unicode/Stream.hs - ghc-options: -main-is Streamly.Test.Unicode.Stream.main - if flag(use-streamly-core) - buildable: False -test-suite version-bounds - import: test-options - type: exitcode-stdio-1.0 - main-is: version-bounds.hs - -------------------------------------------------------------------------------- --- Deprecated -------------------------------------------------------------------------------- - -test-suite Prelude - import: test-options - type: exitcode-stdio-1.0 - main-is: Streamly/Test/Prelude.hs - ghc-options: -main-is Streamly.Test.Prelude.main - if flag(use-streamly-core) - buildable: False - -test-suite Prelude.Ahead - import: test-options - type: exitcode-stdio-1.0 - main-is: Streamly/Test/Prelude/Ahead.hs - ghc-options: -main-is Streamly.Test.Prelude.Ahead.main - if flag(use-streamly-core) - buildable: False - -test-suite Prelude.Async - import: test-options - type: exitcode-stdio-1.0 - main-is: Streamly/Test/Prelude/Async.hs - ghc-options: -main-is Streamly.Test.Prelude.Async.main - if flag(use-streamly-core) - buildable: False - -test-suite Prelude.Concurrent - import: test-options - type: exitcode-stdio-1.0 - main-is: Streamly/Test/Prelude/Concurrent.hs - ghc-options: -main-is Streamly.Test.Prelude.Concurrent.main - if flag(limit-build-mem) - ghc-options: +RTS -M2000M -RTS - if flag(use-streamly-core) - buildable: False - -test-suite Prelude.Fold - import: test-options - type: exitcode-stdio-1.0 - main-is: Streamly/Test/Prelude/Fold.hs - ghc-options: -main-is Streamly.Test.Prelude.Fold.main - if flag(use-streamly-core) - buildable: False - -test-suite Prelude.Parallel - import: test-options - type: exitcode-stdio-1.0 - main-is: Streamly/Test/Prelude/Parallel.hs - ghc-options: -main-is Streamly.Test.Prelude.Parallel.main - if flag(use-streamly-core) - buildable: False - -test-suite Prelude.Rate - import:always-optimized - type: exitcode-stdio-1.0 - main-is: Streamly/Test/Prelude/Rate.hs - ghc-options: -main-is Streamly.Test.Prelude.Rate.main - if flag(dev) - buildable: True - else - buildable: False - if flag(use-streamly-core) - buildable: False - -test-suite Prelude.Serial - import: test-options - type: exitcode-stdio-1.0 - main-is: Streamly/Test/Prelude/Serial.hs - ghc-options: -main-is Streamly.Test.Prelude.Serial.main - if flag(limit-build-mem) - ghc-options: +RTS -M1500M -RTS - if flag(use-streamly-core) - buildable: False - -test-suite Prelude.Top - import: test-options - type: exitcode-stdio-1.0 - main-is: Streamly/Test/Prelude/Top.hs - if flag(use-streamly-core) - buildable: False - -test-suite Prelude.WAsync - import: test-options - type: exitcode-stdio-1.0 - main-is: Streamly/Test/Prelude/WAsync.hs - ghc-options: -main-is Streamly.Test.Prelude.WAsync.main - if flag(use-streamly-core) - buildable: False - -test-suite Prelude.WSerial - import: test-options - type: exitcode-stdio-1.0 - main-is: Streamly/Test/Prelude/WSerial.hs - ghc-options: -main-is Streamly.Test.Prelude.WSerial.main - if flag(use-streamly-core) - buildable: False - -test-suite Prelude.ZipAsync - import: test-options - type: exitcode-stdio-1.0 - main-is: Streamly/Test/Prelude/ZipAsync.hs - ghc-options: -main-is Streamly.Test.Prelude.ZipAsync.main - if flag(limit-build-mem) - ghc-options: +RTS -M750M -RTS - if flag(use-streamly-core) - buildable: False - -test-suite Prelude.ZipSerial - import: test-options - type: exitcode-stdio-1.0 - main-is: Streamly/Test/Prelude/ZipSerial.hs - ghc-options: -main-is Streamly.Test.Prelude.ZipSerial.main - if flag(use-streamly-core) - buildable: False +-- test-suite Network.Inet.TCP +-- import: lib-options +-- type: exitcode-stdio-1.0 +-- main-is: Streamly/Test/Network/Inet/TCP.hs +-- ghc-options: -rtsopts -fno-ignore-asserts +-- include-dirs: . +-- build-depends: streamly-tests +-- -- Cannot killThread in listen/accept on Windows threaded runtime +-- if !os(windows) +-- ghc-options: -threaded -with-rtsopts=-N +-- if flag(use-streamly-core) +-- buildable: False +-- +-- test-suite Network.Socket +-- import: lib-options +-- type: exitcode-stdio-1.0 +-- main-is: Streamly/Test/Network/Socket.hs +-- ghc-options: -rtsopts -fno-ignore-asserts +-- include-dirs: . +-- build-depends: streamly-tests +-- -- Cannot killThread in listen/accept on Windows threaded runtime +-- if !os(windows) +-- ghc-options: -threaded -with-rtsopts=-N +-- if flag(use-streamly-core) +-- buildable: False +-- +-- test-suite Unicode.Char +-- import: test-options +-- type: exitcode-stdio-1.0 +-- main-is: Streamly/Test/Unicode/Char.hs +-- ghc-options: -main-is Streamly.Test.Unicode.Char.main +-- if flag(use-streamly-core) || !flag(dev) +-- buildable: False +-- +-- test-suite Unicode.Parser +-- import: test-options +-- type: exitcode-stdio-1.0 +-- main-is: Streamly/Test/Unicode/Parser.hs +-- ghc-options: -main-is Streamly.Test.Unicode.Parser.main +-- if flag(use-streamly-core) +-- buildable: False +-- +-- test-suite Unicode.Stream +-- import: test-options +-- type: exitcode-stdio-1.0 +-- main-is: Streamly/Test/Unicode/Stream.hs +-- ghc-options: -main-is Streamly.Test.Unicode.Stream.main +-- if flag(use-streamly-core) +-- buildable: False +-- +-- test-suite version-bounds +-- import: test-options +-- type: exitcode-stdio-1.0 +-- main-is: version-bounds.hs +-- +-- ------------------------------------------------------------------------------- +-- -- Deprecated +-- ------------------------------------------------------------------------------- +-- +-- test-suite Prelude +-- import: test-options +-- type: exitcode-stdio-1.0 +-- main-is: Streamly/Test/Prelude.hs +-- ghc-options: -main-is Streamly.Test.Prelude.main +-- if flag(use-streamly-core) +-- buildable: False +-- +-- test-suite Prelude.Ahead +-- import: test-options +-- type: exitcode-stdio-1.0 +-- main-is: Streamly/Test/Prelude/Ahead.hs +-- ghc-options: -main-is Streamly.Test.Prelude.Ahead.main +-- if flag(use-streamly-core) +-- buildable: False +-- +-- test-suite Prelude.Async +-- import: test-options +-- type: exitcode-stdio-1.0 +-- main-is: Streamly/Test/Prelude/Async.hs +-- ghc-options: -main-is Streamly.Test.Prelude.Async.main +-- if flag(use-streamly-core) +-- buildable: False +-- +-- test-suite Prelude.Concurrent +-- import: test-options +-- type: exitcode-stdio-1.0 +-- main-is: Streamly/Test/Prelude/Concurrent.hs +-- ghc-options: -main-is Streamly.Test.Prelude.Concurrent.main +-- if flag(limit-build-mem) +-- ghc-options: +RTS -M2000M -RTS +-- if flag(use-streamly-core) +-- buildable: False +-- +-- test-suite Prelude.Fold +-- import: test-options +-- type: exitcode-stdio-1.0 +-- main-is: Streamly/Test/Prelude/Fold.hs +-- ghc-options: -main-is Streamly.Test.Prelude.Fold.main +-- if flag(use-streamly-core) +-- buildable: False +-- +-- test-suite Prelude.Parallel +-- import: test-options +-- type: exitcode-stdio-1.0 +-- main-is: Streamly/Test/Prelude/Parallel.hs +-- ghc-options: -main-is Streamly.Test.Prelude.Parallel.main +-- if flag(use-streamly-core) +-- buildable: False +-- +-- test-suite Prelude.Rate +-- import:always-optimized +-- type: exitcode-stdio-1.0 +-- main-is: Streamly/Test/Prelude/Rate.hs +-- ghc-options: -main-is Streamly.Test.Prelude.Rate.main +-- if flag(dev) +-- buildable: True +-- else +-- buildable: False +-- if flag(use-streamly-core) +-- buildable: False +-- +-- test-suite Prelude.Serial +-- import: test-options +-- type: exitcode-stdio-1.0 +-- main-is: Streamly/Test/Prelude/Serial.hs +-- ghc-options: -main-is Streamly.Test.Prelude.Serial.main +-- if flag(limit-build-mem) +-- ghc-options: +RTS -M1500M -RTS +-- if flag(use-streamly-core) +-- buildable: False +-- +-- test-suite Prelude.Top +-- import: test-options +-- type: exitcode-stdio-1.0 +-- main-is: Streamly/Test/Prelude/Top.hs +-- if flag(use-streamly-core) +-- buildable: False +-- +-- test-suite Prelude.WAsync +-- import: test-options +-- type: exitcode-stdio-1.0 +-- main-is: Streamly/Test/Prelude/WAsync.hs +-- ghc-options: -main-is Streamly.Test.Prelude.WAsync.main +-- if flag(use-streamly-core) +-- buildable: False +-- +-- test-suite Prelude.WSerial +-- import: test-options +-- type: exitcode-stdio-1.0 +-- main-is: Streamly/Test/Prelude/WSerial.hs +-- ghc-options: -main-is Streamly.Test.Prelude.WSerial.main +-- if flag(use-streamly-core) +-- buildable: False +-- +-- test-suite Prelude.ZipAsync +-- import: test-options +-- type: exitcode-stdio-1.0 +-- main-is: Streamly/Test/Prelude/ZipAsync.hs +-- ghc-options: -main-is Streamly.Test.Prelude.ZipAsync.main +-- if flag(limit-build-mem) +-- ghc-options: +RTS -M750M -RTS +-- if flag(use-streamly-core) +-- buildable: False +-- +-- test-suite Prelude.ZipSerial +-- import: test-options +-- type: exitcode-stdio-1.0 +-- main-is: Streamly/Test/Prelude/ZipSerial.hs +-- ghc-options: -main-is Streamly.Test.Prelude.ZipSerial.main +-- if flag(use-streamly-core) +-- buildable: False From 24a6a81d242a3cb3c4e88fbb9382904299261f1c Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Thu, 14 Nov 2024 00:52:35 +0530 Subject: [PATCH 19/23] Add some debug messages --- core/src/Streamly/Internal/FileSystem/Windows/File.hsc | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/core/src/Streamly/Internal/FileSystem/Windows/File.hsc b/core/src/Streamly/Internal/FileSystem/Windows/File.hsc index 1381b638fb..c582647fc6 100644 --- a/core/src/Streamly/Internal/FileSystem/Windows/File.hsc +++ b/core/src/Streamly/Internal/FileSystem/Windows/File.hsc @@ -90,12 +90,15 @@ createFile :: -> Maybe Win32.HANDLE -> IO Win32.HANDLE createFile name access share mb_attr mode flag mb_h = - withFilePath name $ \ c_name -> - failIfWithRetry + withFilePath name $ \ c_name -> do + putStrLn $ "**pre createFile: fp [" ++ Path.toString name + h <- failIfWithRetry (== iNVALID_HANDLE_VALUE) (unwords ["CreateFile", Path.toString name]) $ c_CreateFile c_name access share (maybePtr mb_attr) mode flag (maybePtr mb_h) + putStrLn $ "**post createFile: fp [" ++ Path.toString name + return h {- #if !defined(__IO_MANAGER_WINIO__) @@ -120,7 +123,8 @@ toHandle fp iomode h = win2HsHandle fp iomode h `onException` Win32.closeHandle h openFile :: WindowsPath -> IOMode -> IO Handle -openFile fp iomode = +openFile fp iomode = do + putStrLn $ "**openFile: fp [" ++ Path.toString fp ++ "] iomode [" ++ show iomode ++ "]" bracketOnError create Win32.closeHandle (toHandle fp iomode) where From 9147b87a09d7403c3ceb6e0b26c88c312cdf56f4 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Thu, 14 Nov 2024 00:53:20 +0530 Subject: [PATCH 20/23] Disable benchmarks in appveyor --- appveyor.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/appveyor.yml b/appveyor.yml index 395dd48054..08cfa8c19e 100644 --- a/appveyor.yml +++ b/appveyor.yml @@ -24,8 +24,8 @@ environment: # What to build # ------------------------------------------------------------------------ # DISABLE_TEST: "y" - # DISABLE_BENCH: "y" - # DISABLE_DOCS: "y" + DISABLE_BENCH: "y" + DISABLE_DOCS: "y" DISABLE_SDIST_BUILD: "y" DISABLE_DIST_CHECKS: "y" ENABLE_INSTALL: "y" From 7739c2c4ff4815f1b78b446925844b059bfc5bc5 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Thu, 14 Nov 2024 02:04:49 +0530 Subject: [PATCH 21/23] Add some debug code in executor --- test/Streamly/Test/FileSystem/Handle.hs | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/test/Streamly/Test/FileSystem/Handle.hs b/test/Streamly/Test/FileSystem/Handle.hs index d7b696f163..f9c970ff81 100644 --- a/test/Streamly/Test/FileSystem/Handle.hs +++ b/test/Streamly/Test/FileSystem/Handle.hs @@ -70,10 +70,16 @@ testBinData = "01234567890123456789012345678901234567890123456789" executor :: (Handle -> Stream IO Char) -> IO (Stream IO Char) executor f = withSystemTempDirectory "fs_handle" $ \fp -> do - fpath <- Path.fromString $ fp "tmp_read.txt" - writeFile fpath testDataLarge - h <- openFile fpath ReadMode - return $ f h + let path = fp "tmp_read.txt" + putStrLn $ "executor: [" ++ path ++ "]" + fpath <- Path.fromString path + if path /= Path.toString fpath + then + error $ "executor: path = " ++ path ++ " fpath = " ++ Path.toString fpath + else do + writeFile fpath testDataLarge + h <- openFile fpath ReadMode + return $ f h readFromHandle :: IO (Stream IO Char) readFromHandle = From b795bf86a7bca6ff08e3289a5a873e3211efac0e Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Thu, 14 Nov 2024 04:40:00 +0530 Subject: [PATCH 22/23] Add some more debug messages --- core/src/Streamly/Internal/FileSystem/Windows/File.hsc | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/core/src/Streamly/Internal/FileSystem/Windows/File.hsc b/core/src/Streamly/Internal/FileSystem/Windows/File.hsc index c582647fc6..baf8687476 100644 --- a/core/src/Streamly/Internal/FileSystem/Windows/File.hsc +++ b/core/src/Streamly/Internal/FileSystem/Windows/File.hsc @@ -70,8 +70,10 @@ failIfWithRetry needRetry msg action = retryOrFail retries then return ret else do err_code <- getLastError + putStrLn $ "failed.........err_code " ++ show err_code if err_code == 32 then do + putStrLn "retrying......" threadDelay delay retryOrFail (times - 1) else errorWin msg @@ -91,13 +93,13 @@ createFile :: -> IO Win32.HANDLE createFile name access share mb_attr mode flag mb_h = withFilePath name $ \ c_name -> do - putStrLn $ "**pre createFile: fp [" ++ Path.toString name + putStrLn $ "**pre createFile: fp [" ++ Path.toString name ++ "]" h <- failIfWithRetry (== iNVALID_HANDLE_VALUE) (unwords ["CreateFile", Path.toString name]) $ c_CreateFile c_name access share (maybePtr mb_attr) mode flag (maybePtr mb_h) - putStrLn $ "**post createFile: fp [" ++ Path.toString name + putStrLn $ "**post createFile: fp [" ++ Path.toString name ++ "]" return h {- @@ -112,8 +114,10 @@ win2HsHandle _fp iomode h = do when (iomode == AppendMode ) $ void $ Win32.setFilePointerEx h 0 Win32.fILE_END #if defined(__IO_MANAGER_WINIO__) + putStrLn "win2HSHandle: IO Manager WINIO" Win32.hANDLEToHandle h #else + putStrLn "win2HSHandle: NOT WINIO" fd <- _open_osfhandle (fromIntegral (ptrToIntPtr h)) (#const _O_BINARY) fdToHandle' fd Nothing False (Path.toString _fp) iomode True #endif From 01121cf40cdc8af8487e6daf1f29cc2ed437bd62 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Thu, 14 Nov 2024 05:24:25 +0530 Subject: [PATCH 23/23] Add a debug check to ensure the temp dir exists --- test/Streamly/Test/FileSystem/Handle.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/test/Streamly/Test/FileSystem/Handle.hs b/test/Streamly/Test/FileSystem/Handle.hs index f9c970ff81..6d165e020d 100644 --- a/test/Streamly/Test/FileSystem/Handle.hs +++ b/test/Streamly/Test/FileSystem/Handle.hs @@ -8,10 +8,12 @@ module Streamly.Test.FileSystem.Handle (main) where +import Control.Monad (when) import Data.Functor.Identity (runIdentity) import Data.Word (Word8) import Streamly.Internal.Data.Stream (Stream) import Streamly.Internal.System.IO (defaultChunkSize) +import System.Directory (doesDirectoryExist) import System.FilePath (()) import System.IO ( Handle @@ -70,6 +72,8 @@ testBinData = "01234567890123456789012345678901234567890123456789" executor :: (Handle -> Stream IO Char) -> IO (Stream IO Char) executor f = withSystemTempDirectory "fs_handle" $ \fp -> do + r <- doesDirectoryExist fp + when (not r) $ error $ "temp directory [" ++ fp ++ "] does not exist" let path = fp "tmp_read.txt" putStrLn $ "executor: [" ++ path ++ "]" fpath <- Path.fromString path