diff --git a/.stylish-haskell.yaml b/.stylish-haskell.yaml index 3c7daa0..0045c67 100644 --- a/.stylish-haskell.yaml +++ b/.stylish-haskell.yaml @@ -21,7 +21,7 @@ steps: # # # Should export lists be sorted? Sorting is only performed within the # # export section, as delineated by Haddock comments. - sort: true + sort: false # # # See `separate_lists` for the `imports` step. separate_lists: true diff --git a/fs-api/CHANGELOG.md b/fs-api/CHANGELOG.md index b739bb4..f81b92f 100644 --- a/fs-api/CHANGELOG.md +++ b/fs-api/CHANGELOG.md @@ -2,6 +2,19 @@ ## next release -- ????-??-?? +### Breaking + +* New `primitive ^>=0.9` dependency + +### Non-breaking + +* Add new `HasBufFS` interface for performing I/O using pointer buffers. Note + that it is likely that this interfaced is unified with the `HasFS` interface + in the future. +* Add compound functions, built from primitives in `HasBufFS`: `hGetAllAt`, + `hGetBufExactly`, `hPutBufExactly`, `hGetBufExactlyAt` and `hPutBufExactlyAt` +* Provide an instantiation of the `HasBufFS` interface for `IO`. + ### Patch * Make internal error comparison function more lenient on MacOS systems. diff --git a/fs-api/fs-api.cabal b/fs-api/fs-api.cabal index 2621e84..03a4d31 100644 --- a/fs-api/fs-api.cabal +++ b/fs-api/fs-api.cabal @@ -10,7 +10,7 @@ license-files: copyright: 2019-2023 Input Output Global Inc (IOG) author: IOG Engineering Team -maintainer: operations@iohk.io, Joris Dral +maintainer: operations@iohk.io, Joris Dral (joris@well-typed.com) category: System build-type: Simple extra-doc-files: CHANGELOG.md @@ -45,6 +45,7 @@ library , directory >=1.3 && <1.4 , filepath >=1.4 && <1.5 , io-classes >=0.3 && <1.5 + , primitive ^>=0.9 , text >=1.2 && <2.2 if os(windows) @@ -69,3 +70,24 @@ library -Wall -Wcompat -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -Widentities -Wredundant-constraints -Wmissing-export-lists -Wunused-packages + +test-suite fs-api-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + other-modules: Test.System.FS.IO + default-language: Haskell2010 + build-depends: + , base + , bytestring + , fs-api + , primitive + , tasty + , tasty-quickcheck + , temporary + + ghc-options: + -Wall -Wcompat -Wincomplete-uni-patterns + -Wincomplete-record-updates -Wpartial-fields -Widentities + -Wredundant-constraints -Wmissing-export-lists -Wunused-packages + -fno-ignore-asserts diff --git a/fs-api/src-unix/System/FS/IO/Internal.hs b/fs-api/src-unix/System/FS/IO/Internal.hs index 82835ef..b3ba47d 100644 --- a/fs-api/src-unix/System/FS/IO/Internal.hs +++ b/fs-api/src-unix/System/FS/IO/Internal.hs @@ -9,11 +9,15 @@ module System.FS.IO.Internal ( , getSize , open , pread + , preadBuf + , pwriteBuf , read + , readBuf , sameError , seek , truncate , write + , writeBuf ) where import Prelude hiding (read, truncate) @@ -29,8 +33,9 @@ import System.FS.API.Types (AllowExisting (..), OpenMode (..), import System.FS.IO.Internal.Error (sameError) import System.FS.IO.Internal.Handle import qualified System.Posix as Posix -import System.Posix (Fd) -import System.Posix.IO.ByteString.Ext (fdPreadBuf) +import System.Posix (ByteCount, Fd (..), FileOffset) +import qualified System.Posix.IO.ByteString.Ext as Posix (fdPreadBuf, + fdPwriteBuf) type FHandle = HandleOS Fd @@ -130,10 +135,28 @@ read h bytes = withOpenHandle "read" h $ \fd -> Internal.createUptoN (fromIntegral bytes) $ \ptr -> fromIntegral <$> Posix.fdReadBuf fd ptr (fromIntegral bytes) +readBuf :: FHandle -> Ptr Word8 -> ByteCount -> IO ByteCount +readBuf f buf c = withOpenHandle "readBuf" f $ \fd -> Posix.fdReadBuf fd buf c + +writeBuf :: FHandle -> Ptr Word8 -> ByteCount -> IO ByteCount +writeBuf f buf c = withOpenHandle "writeBuf" f $ \fd -> Posix.fdWriteBuf fd buf c + pread :: FHandle -> Word64 -> Word64 -> IO ByteString pread h bytes offset = withOpenHandle "pread" h $ \fd -> Internal.createUptoN (fromIntegral bytes) $ \ptr -> - fromIntegral <$> fdPreadBuf fd ptr (fromIntegral bytes) (fromIntegral offset) + fromIntegral <$> Posix.fdPreadBuf fd ptr (fromIntegral bytes) (fromIntegral offset) + +-- | @'preadBuf' fh buf c off@ reads @c@ bytes into the buffer @buf@ from the file +-- handle @fh@ at the file offset @off@. This does not move the position of the +-- file handle. +preadBuf :: FHandle -> Ptr Word8 -> ByteCount -> FileOffset -> IO ByteCount +preadBuf h buf c off = withOpenHandle "preadBuf" h $ \fd -> Posix.fdPreadBuf fd buf c off + +-- | @'pwriteBuf' fh buf c off@ writes @c@ bytes from the data in the buffer +-- @buf@ to the file handle @fh@ at the file offset @off@. This does not move +-- the position of the file handle. +pwriteBuf :: FHandle -> Ptr Word8 -> ByteCount -> FileOffset -> IO ByteCount +pwriteBuf h buf c off = withOpenHandle "pwriteBuf" h $ \fd -> Posix.fdPwriteBuf fd buf c off -- | Truncates the file managed by the input 'FHandle' to the input size. truncate :: FHandle -> Word64 -> IO () diff --git a/fs-api/src-win32/System/FS/IO/Internal.hs b/fs-api/src-win32/System/FS/IO/Internal.hs index d0e074c..452a00f 100644 --- a/fs-api/src-win32/System/FS/IO/Internal.hs +++ b/fs-api/src-win32/System/FS/IO/Internal.hs @@ -8,11 +8,15 @@ module System.FS.IO.Internal ( , getSize , open , pread + , preadBuf + , pwriteBuf , read + , readBuf , sameError , seek , truncate , write + , writeBuf ) where import Prelude hiding (read, truncate) @@ -26,6 +30,7 @@ import Foreign (Int64, Ptr) import System.FS.API.Types (AllowExisting (..), FsError (..), FsErrorType (..), OpenMode (..), SeekMode (..)) import System.FS.IO.Internal.Handle +import System.Posix.Types import System.Win32 type FHandle = HandleOS HANDLE @@ -78,6 +83,14 @@ read fh bytes = withOpenHandle "read" fh $ \h -> getCurrentFileOffset :: HANDLE -> IO Int64 getCurrentFileOffset h = setFilePointerEx h 0 fILE_CURRENT +readBuf :: FHandle -> Ptr Word8 -> ByteCount -> IO ByteCount +readBuf fh buf c = withOpenHandle "readBuf" fh $ \h -> + fromIntegral <$> win32_ReadFile h buf (fromIntegral c) Nothing + +writeBuf :: FHandle -> Ptr Word8 -> ByteCount -> IO ByteCount +writeBuf fh buf c = withOpenHandle "writeBuf" fh $ \h -> + fromIntegral <$> win32_WriteFile h buf (fromIntegral c) Nothing + pread :: FHandle -> Word64 -> Word64 -> IO ByteString pread fh bytes pos = withOpenHandle "pread" fh $ \h -> Internal.createUptoN (fromIntegral bytes) $ \ptr -> do @@ -87,6 +100,22 @@ pread fh bytes pos = withOpenHandle "pread" fh $ \h -> _ <- setFilePointerEx h initialOffset fILE_BEGIN return n +preadBuf :: FHandle -> Ptr Word8 -> ByteCount -> FileOffset -> IO ByteCount +preadBuf fh buf c off = withOpenHandle "preadBuf" fh $ \h -> do + initialOffset <- getCurrentFileOffset h + _ <- setFilePointerEx h (fromIntegral off) fILE_BEGIN + n <- fromIntegral <$> win32_ReadFile h buf (fromIntegral c) Nothing + _ <- setFilePointerEx h initialOffset fILE_BEGIN + return n + +pwriteBuf :: FHandle -> Ptr Word8 -> ByteCount -> FileOffset -> IO ByteCount +pwriteBuf fh buf c off = withOpenHandle "pwriteBuf" fh $ \h -> do + initialOffset <- getCurrentFileOffset h + _ <- setFilePointerEx h (fromIntegral off) fILE_BEGIN + n <- fromIntegral <$> win32_WriteFile h buf (fromIntegral c) Nothing + _ <- setFilePointerEx h initialOffset fILE_BEGIN + return n + -- We only allow truncate in AppendMode, but Windows do not support it, so we manually seek to the end. -- It is important that the logical end of the handle stays alligned to the physical end of the file. truncate :: FHandle -> Word64 -> IO () diff --git a/fs-api/src/System/FS/API.hs b/fs-api/src/System/FS/API.hs index 806c39f..6ca0813 100644 --- a/fs-api/src/System/FS/API.hs +++ b/fs-api/src/System/FS/API.hs @@ -1,10 +1,12 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | An abstract view over the filesystem. module System.FS.API ( @@ -17,13 +19,24 @@ module System.FS.API ( , withFile -- * SomeHasFS , SomeHasFS (..) + -- * HasBufFS + , BufferOffset (..) + , HasBufFS (..) + , hGetBufAllAt + , hGetBufExactly + , hGetBufExactlyAt + , hPutBufExactly + , hPutBufExactlyAt ) where import Control.Monad.Class.MonadThrow +import Control.Monad.Primitive (PrimMonad (..)) import qualified Data.ByteString as BS import Data.Int (Int64) +import Data.Primitive (MutableByteArray) import Data.Set (Set) import Data.Word +import System.Posix.Types (ByteCount) import System.FS.API.Types as Types @@ -175,3 +188,188 @@ hClose' HasFS { hClose, hIsOpen } h = do -- hides an existential @h@ parameter of a 'HasFS'. data SomeHasFS m where SomeHasFS :: Eq h => HasFS m h -> SomeHasFS m + +{------------------------------------------------------------------------------- + HasBufFS +-------------------------------------------------------------------------------} + +-- | Absolute offset into a buffer (i.e., 'MutableByteArray'). +-- +-- Can be negative, because buffer offsets can be added together to change +-- offset positions. This is similar to 'plusPtr' for 'Ptr' types. However, note +-- that reading or writing from a buffer at a negative offset leads to undefined +-- behaviour. +newtype BufferOffset = BufferOffset { unBufferOffset :: Int } + deriving (Eq, Ord, Enum, Bounded, Num, Show) + +-- | Abstract interface for performing I\/O using user-supplied buffers. +-- +-- [User-supplied buffers]: It is the user's responsiblity to provide buffers +-- that are large enough. Behaviour is undefined if the I\/O operations access +-- the buffer outside it's allocated range. +-- +-- Note: this interface is likely going to become part of the 'HasFS' interface, +-- but is separated for now so downstream code does not break. +data HasBufFS m h = HasBufFS { + -- | Like 'hGetSome', but the bytes are read into a user-supplied buffer. + -- See __User-supplied buffers__. + hGetBufSome :: HasCallStack + => Handle h + -> MutableByteArray (PrimState m) -- ^ Buffer to read bytes into + -> BufferOffset -- ^ Offset into buffer + -> ByteCount -- ^ The number of bytes to read + -> m ByteCount + -- | Like 'hGetSomeAt', but the bytes are read into a user-supplied buffer. + -- See __User-supplied buffers__. + , hGetBufSomeAt :: HasCallStack + => Handle h + -> MutableByteArray (PrimState m) -- ^ Buffer to read bytes into + -> BufferOffset -- ^ Offset into buffer + -> ByteCount -- ^ The number of bytes to read + -> AbsOffset -- ^ The file offset at which to read + -> m ByteCount + -- | Like 'hPutSome', but the bytes are written from a user-supplied buffer. + -- See __User-supplied buffers__. + , hPutBufSome :: HasCallStack + => Handle h + -> MutableByteArray (PrimState m) -- ^ Buffer to write bytes from + -> BufferOffset -- ^ Offset into buffer + -> ByteCount -- ^ The number of bytes to write + -> m ByteCount + -- | Like 'hPutSome', but the bytes are written from a user-supplied buffer + -- at a given file offset. This offset does not affect the offset stored in + -- the file handle (see also 'hGetSomeAt'). See __User-supplied buffers__. + , hPutBufSomeAt :: HasCallStack + => Handle h + -> MutableByteArray (PrimState m) -- ^ Buffer to write bytes from + -> BufferOffset -- ^ Offset into buffer + -> ByteCount -- ^ The number of bytes to write + -> AbsOffset -- ^ The file offset at which to write + -> m ByteCount + } + +-- | Wrapper for 'hGetBufSomeAt' that ensures that we read all bytes from a +-- file. +-- +-- A sufficiently large buffer can be provided by comparing 'hGetSize' against +-- the requested file offset. +-- +-- Is implemented in terms of 'hGetBufExactlyAt'. +hGetBufAllAt :: forall m h. (HasCallStack, MonadThrow m) + => HasFS m h + -> HasBufFS m h + -> Handle h + -> MutableByteArray (PrimState m) -- ^ Buffer to read bytes into + -> BufferOffset -- ^ Offset into buffer + -> AbsOffset -- ^ The file offset at which to read + -> m ByteCount +hGetBufAllAt hfs hbfs h buf bufOff off = do + sz <- hGetSize hfs h + let c = sz - unAbsOffset off + hGetBufExactlyAt hfs hbfs h buf bufOff (fromIntegral c) off + +-- | Wrapper for 'hGetBufSome' that ensures that we read exactly as many +-- bytes as requested. If EOF is found before the requested number of bytes is +-- read, an 'FsError' exception is thrown. +hGetBufExactly :: forall m h. (HasCallStack, MonadThrow m) + => HasFS m h + -> HasBufFS m h + -> Handle h + -> MutableByteArray (PrimState m) -- ^ Buffer to read bytes into + -> BufferOffset -- ^ Offset into buffer + -> ByteCount -- ^ The number of bytes to read + -> m ByteCount +hGetBufExactly hfs hbfs h buf bufOff c = go c bufOff + where + go :: ByteCount -> BufferOffset -> m ByteCount + go !remainingCount !currentBufOff + | remainingCount == 0 = pure c + | otherwise = do + readBytes <- hGetBufSome hbfs h buf currentBufOff c + if readBytes == 0 then + throwIO FsError { + fsErrorType = FsReachedEOF + , fsErrorPath = mkFsErrorPath hfs $ handlePath h + , fsErrorString = "hGetBufExactly found eof before reading " ++ show c ++ " bytes" + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = False + } + -- We know the length <= remainingBytes, so this can't underflow. + else go (remainingCount - readBytes) + (currentBufOff + fromIntegral readBytes) + +-- | Wrapper for 'hGetBufSomeAt' that ensures that we read exactly as many bytes +-- as requested. If EOF is found before the requested number of bytes is read, +-- an 'FsError' exception is thrown. +hGetBufExactlyAt :: forall m h. (HasCallStack, MonadThrow m) + => HasFS m h + -> HasBufFS m h + -> Handle h + -> MutableByteArray (PrimState m) -- ^ Buffer to read bytes into + -> BufferOffset -- ^ Offset into buffer + -> ByteCount -- ^ The number of bytes to read + -> AbsOffset -- ^ The file offset at which to read + -> m ByteCount +hGetBufExactlyAt hfs hbfs h buf bufOff c off = go c off bufOff + where + go :: ByteCount -> AbsOffset -> BufferOffset -> m ByteCount + go !remainingCount !currentOffset !currentBufOff + | remainingCount == 0 = pure c + | otherwise = do + readBytes <- hGetBufSomeAt hbfs h buf currentBufOff c currentOffset + if readBytes == 0 then + throwIO FsError { + fsErrorType = FsReachedEOF + , fsErrorPath = mkFsErrorPath hfs $ handlePath h + , fsErrorString = "hGetBufExactlyAt found eof before reading " ++ show c ++ " bytes" + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = False + } + -- We know the length <= remainingBytes, so this can't underflow. + else go (remainingCount - readBytes) + (currentOffset + fromIntegral readBytes) + (currentBufOff + fromIntegral readBytes) + +-- | Wrapper for 'hPutBufSome' that ensures we write exactly as many bytes as +-- requested. +hPutBufExactly :: forall m h. (HasCallStack, MonadThrow m) + => HasBufFS m h + -> Handle h + -> MutableByteArray (PrimState m) -- ^ Buffer to write bytes from + -> BufferOffset -- ^ Offset into buffer + -> ByteCount -- ^ The number of bytes to write + -> m ByteCount +hPutBufExactly hbfs h buf bufOff c = go c bufOff + where + go :: ByteCount -> BufferOffset -> m ByteCount + go !remainingCount !currentBufOff = do + writtenBytes <- hPutBufSome hbfs h buf currentBufOff remainingCount + let remainingCount' = remainingCount - writtenBytes + if remainingCount' == 0 + then pure c + else go remainingCount' + (currentBufOff + fromIntegral writtenBytes) + +-- | Wrapper for 'hPutBufSomeAt' that ensures we write exactly as many bytes as +-- requested. +hPutBufExactlyAt :: forall m h. (HasCallStack, MonadThrow m) + => HasBufFS m h + -> Handle h + -> MutableByteArray (PrimState m) -- ^ Buffer to write bytes from + -> BufferOffset -- ^ Offset into buffer + -> ByteCount -- ^ The number of bytes to write + -> AbsOffset -- ^ The file offset at which to write + -> m ByteCount +hPutBufExactlyAt hbfs h buf bufOff c off = go c off bufOff + where + go :: ByteCount -> AbsOffset -> BufferOffset -> m ByteCount + go !remainingCount !currentOffset !currentBufOff = do + writtenBytes <- hPutBufSomeAt hbfs h buf currentBufOff remainingCount currentOffset + let remainingCount' = remainingCount - writtenBytes + if remainingCount' == 0 + then pure c + else go remainingCount' + (currentOffset + fromIntegral writtenBytes) + (currentBufOff + fromIntegral writtenBytes) diff --git a/fs-api/src/System/FS/IO.hs b/fs-api/src/System/FS/IO.hs index 268c697..803d4dc 100644 --- a/fs-api/src/System/FS/IO.hs +++ b/fs-api/src/System/FS/IO.hs @@ -3,14 +3,17 @@ module System.FS.IO ( -- * IO implementation & monad HandleIO , ioHasFS + , ioHasBufFS ) where import Control.Concurrent.MVar import qualified Control.Exception as E import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Primitive (PrimBase) import qualified Data.ByteString.Unsafe as BS +import Data.Primitive (withMutableByteArrayContents) import qualified Data.Set as Set -import Foreign (castPtr) +import qualified Foreign import GHC.Stack import qualified System.Directory as Dir import System.FS.API @@ -52,7 +55,7 @@ ioHasFS mount = HasFS { F.getSize h , hPutSome = \(Handle h fp) bs -> liftIO $ rethrowFsError fp $ do BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> - fromIntegral <$> F.write h (castPtr ptr) (fromIntegral len) + fromIntegral <$> F.write h (Foreign.castPtr ptr) (fromIntegral len) , createDirectory = \fp -> liftIO $ rethrowFsError fp $ Dir.createDirectory (root fp) , listDirectory = \fp -> liftIO $ rethrowFsError fp $ @@ -76,18 +79,44 @@ ioHasFS mount = HasFS { root :: FsPath -> FilePath root = fsToFilePath mount - -- | Catch IO exceptions and rethrow them as 'FsError' - -- - -- See comments for 'ioToFsError' rethrowFsError :: HasCallStack => FsPath -> IO a -> IO a - rethrowFsError fp action = do - res <- E.try action - case res of - Left err -> handleError err - Right a -> return a - where - handleError :: HasCallStack => IOError -> IO a - handleError ioErr = E.throwIO $ ioToFsError errorPath ioErr + rethrowFsError = _rethrowFsError mount - errorPath :: FsErrorPath - errorPath = fsToFsErrorPath mount fp +{-# INLINE _rethrowFsError #-} +-- | Catch IO exceptions and rethrow them as 'FsError' +-- +-- See comments for 'ioToFsError' +_rethrowFsError :: HasCallStack => MountPoint -> FsPath -> IO a -> IO a +_rethrowFsError mount fp action = do + res <- E.try action + case res of + Left err -> handleError err + Right a -> return a + where + handleError :: HasCallStack => IOError -> IO a + handleError ioErr = E.throwIO $ ioToFsError errorPath ioErr + + errorPath :: FsErrorPath + errorPath = fsToFsErrorPath mount fp + +{------------------------------------------------------------------------------- + HasBufFS +-------------------------------------------------------------------------------} + +ioHasBufFS :: (MonadIO m, PrimBase m) => MountPoint -> HasBufFS m HandleIO +ioHasBufFS mount = HasBufFS { + hGetBufSome = \(Handle h fp) buf bufOff c -> + withMutableByteArrayContents buf $ \ptr -> liftIO $ rethrowFsError fp $ + F.readBuf h (ptr `Foreign.plusPtr` unBufferOffset bufOff) c + , hGetBufSomeAt = \(Handle h fp) buf bufOff c off -> + withMutableByteArrayContents buf $ \ptr -> liftIO $ rethrowFsError fp $ + F.preadBuf h (ptr `Foreign.plusPtr` unBufferOffset bufOff) c (fromIntegral $ unAbsOffset off) + , hPutBufSome = \(Handle h fp) buf bufOff c -> + withMutableByteArrayContents buf $ \ptr -> liftIO $ rethrowFsError fp $ + F.writeBuf h (ptr `Foreign.plusPtr` unBufferOffset bufOff) c + , hPutBufSomeAt = \(Handle h fp) buf bufOff c off -> + withMutableByteArrayContents buf $ \ptr -> liftIO $ rethrowFsError fp $ + F.pwriteBuf h (ptr `Foreign.plusPtr` unBufferOffset bufOff) c (fromIntegral $ unAbsOffset off) + } + where + rethrowFsError = _rethrowFsError mount diff --git a/fs-api/test/Main.hs b/fs-api/test/Main.hs new file mode 100644 index 0000000..e4a9b84 --- /dev/null +++ b/fs-api/test/Main.hs @@ -0,0 +1,9 @@ +module Main (main) where + +import Test.System.FS.IO +import Test.Tasty + +main :: IO () +main = defaultMain $ testGroup "fs-api-test" [ + Test.System.FS.IO.tests + ] diff --git a/fs-api/test/Test/System/FS/IO.hs b/fs-api/test/Test/System/FS/IO.hs new file mode 100644 index 0000000..945734e --- /dev/null +++ b/fs-api/test/Test/System/FS/IO.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE BangPatterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Test.System.FS.IO (tests) where + +import Control.Monad.Primitive +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Short.Internal as SBS +import Data.Primitive.ByteArray +import Prelude hiding (read) +import qualified System.FS.API as FS +import qualified System.FS.IO as IO +import System.IO.Temp +import System.Posix.Types (ByteCount) +import Test.Tasty +import Test.Tasty.QuickCheck + +tests :: TestTree +tests = testGroup "Test.System.FS.IO" [ + testProperty "prop_roundtrip_hPutGetBufSome" + prop_roundtrip_hPutGetBufSome + , testProperty "prop_roundtrip_hPutGetBufSomeAt" + prop_roundtrip_hPutGetBufSomeAt + , testProperty "prop_roundtrip_hPutGetBufExactly" + prop_roundtrip_hPutGetBufExactly + , testProperty "prop_roundtrip_hPutGetBufExactlyAt" + prop_roundtrip_hPutGetBufExactlyAt + ] + +instance Arbitrary ByteString where + arbitrary = BS.pack <$> arbitrary + shrink = fmap BS.pack . shrink . BS.unpack + +instance Arbitrary FS.AbsOffset where + arbitrary = FS.AbsOffset . getSmall <$> arbitrary + shrink (FS.AbsOffset x) = FS.AbsOffset <$> shrink x + +fromByteString :: PrimMonad m => ByteString -> m (MutableByteArray (PrimState m)) +fromByteString bs = thawByteArray (ByteArray ba) 0 (SBS.length sbs) + where !sbs@(SBS.SBS ba) = SBS.toShort bs + +toByteString :: PrimMonad m => Int -> MutableByteArray (PrimState m) -> m ByteString +toByteString n mba = freezeByteArray mba 0 n >>= \(ByteArray ba) -> pure (SBS.fromShort $ SBS.SBS ba) + +-- | A write-then-read roundtrip test for buffered I\/O in 'IO'. +-- +-- The 'ByteString'\'s internal pointer doubles as the buffer used for the I\/O +-- operations, and we only write/read a prefix of the bytestring. This does not +-- test what happens if we try to write/read more bytes than fits in the buffer, +-- because the behaviour is then undefined. +prop_roundtrip_hPutGetBufSome :: + ByteString + -> Small ByteCount -- ^ Prefix length + -> Property +prop_roundtrip_hPutGetBufSome bs (Small c) = + BS.length bs >= fromIntegral c ==> + ioProperty $ withSystemTempDirectory "prop_roundtrip_hPutGetBufSome" $ \dirPath -> do + let hfs = IO.ioHasFS (FS.MountPoint dirPath) + hbfs = IO.ioHasBufFS (FS.MountPoint dirPath) + + FS.withFile hfs (FS.mkFsPath ["temp"]) (FS.WriteMode FS.MustBeNew) $ \h -> do + putBuf <- fromByteString bs + m <- FS.hPutBufSome hbfs h putBuf 0 c + let writeTest = counterexample "wrote too many bytes" ((if c > 0 then 1 .<= m else property True) .&&. m .<= c) + FS.hSeek hfs h FS.AbsoluteSeek 0 + getBuf <- newPinnedByteArray (fromIntegral m) + o <- FS.hGetBufSome hbfs h getBuf 0 m + let readTest = counterexample "read too many bytes" ((if c > 0 then 1 .<= o else property True) .&&. o .<= m) + bs' <- toByteString (fromIntegral o) getBuf + let cmpTest = counterexample "(prefix of) input and output bytestring do not match" + $ BS.take (fromIntegral o) bs === bs' + pure (writeTest .&&. readTest .&&. cmpTest) + +-- | Like 'prop_roundtrip_hPutGetBufSome', but reading and writing at a specified offset. +prop_roundtrip_hPutGetBufSomeAt :: + ByteString + -> Small ByteCount -- ^ Prefix length + -> FS.AbsOffset + -> Property +prop_roundtrip_hPutGetBufSomeAt bs (Small c) off = + BS.length bs >= fromIntegral c ==> + ioProperty $ withSystemTempDirectory "prop_roundtrip_hPutGetBufSomeAt" $ \dirPath -> do + let hfs = IO.ioHasFS (FS.MountPoint dirPath) + hbfs = IO.ioHasBufFS (FS.MountPoint dirPath) + + FS.withFile hfs (FS.mkFsPath ["temp"]) (FS.WriteMode FS.MustBeNew) $ \h -> do + putBuf <- fromByteString bs + m <- FS.hPutBufSomeAt hbfs h putBuf 0 c off + let writeTest = counterexample "wrote too many bytes" ((if c > 0 then 1 .<= m else property True) .&&. m .<= c) + getBuf <- newPinnedByteArray (fromIntegral m) + o <- FS.hGetBufSomeAt hbfs h getBuf 0 m off + let readTest = counterexample "read too many bytes" ((if c > 0 then 1 .<= o else property True) .&&. o .<= m) + bs' <- toByteString (fromIntegral o) getBuf + let cmpTest = counterexample "(prefix of) input and output bytestring do not match" + $ BS.take (fromIntegral o) bs === bs' + pure (writeTest .&&. readTest .&&. cmpTest) + +-- | Like 'prop_roundtrip_hPutGetBufSome', but ensuring that all bytes are +-- written/read. +prop_roundtrip_hPutGetBufExactly :: + ByteString + -> Small ByteCount -- ^ Prefix length + -> Property +prop_roundtrip_hPutGetBufExactly bs (Small c) = + BS.length bs >= fromIntegral c ==> + ioProperty $ withSystemTempDirectory "prop_roundtrip_hPutGetBufExactly" $ \dirPath -> do + let hfs = IO.ioHasFS (FS.MountPoint dirPath) + hbfs = IO.ioHasBufFS (FS.MountPoint dirPath) + + FS.withFile hfs (FS.mkFsPath ["temp"]) (FS.WriteMode FS.MustBeNew) $ \h -> do + putBuf <- fromByteString bs + m <- FS.hPutBufExactly hbfs h putBuf 0 c + let writeTest = counterexample "wrote too few bytes" (m === c) + FS.hSeek hfs h FS.AbsoluteSeek 0 + getBuf <- newPinnedByteArray (fromIntegral c) + o <- FS.hGetBufExactly hfs hbfs h getBuf 0 c + let readTest = counterexample "read too few byes" (o === c) + bs' <- toByteString (fromIntegral c) getBuf + let cmpTest = counterexample "input and output bytestring do not match" + $ BS.take (fromIntegral c) bs === BS.take (fromIntegral c) bs' + pure (writeTest .&&. readTest .&&. cmpTest) + +-- | Like 'prop_roundtrip_hPutGetBufSome', but reading and writing at a +-- specified offset, and ensuring that all bytes are written/read. +prop_roundtrip_hPutGetBufExactlyAt :: + ByteString + -> Small ByteCount -- ^ Prefix length + -> FS.AbsOffset + -> Property +prop_roundtrip_hPutGetBufExactlyAt bs (Small c) off = + BS.length bs >= fromIntegral c ==> + ioProperty $ withSystemTempDirectory "prop_roundtrip_hPutGetBufExactlyAt" $ \dirPath -> do + let hfs = IO.ioHasFS (FS.MountPoint dirPath) + hbfs = IO.ioHasBufFS (FS.MountPoint dirPath) + + FS.withFile hfs (FS.mkFsPath ["temp"]) (FS.WriteMode FS.MustBeNew) $ \h -> do + putBuf <- fromByteString bs + m <- FS.hPutBufExactlyAt hbfs h putBuf 0 c off + let writeTest = counterexample "wrote too few bytes" (m === c) + getBuf <- newPinnedByteArray (fromIntegral c) + o <- FS.hGetBufExactlyAt hfs hbfs h getBuf 0 c off + let readTest = counterexample "read too few byes" (o === c) + bs' <- toByteString (fromIntegral c) getBuf + let cmpTest = counterexample "input and output bytestring do not match" + $ BS.take (fromIntegral c) bs === BS.take (fromIntegral c) bs' + pure (writeTest .&&. readTest .&&. cmpTest) + +infix 4 .<= + +(.<=) :: (Ord a, Show a) => a -> a -> Property +x .<= y = counterexample (show x ++ interpret res ++ show y) res + where + res = x <= y + interpret True = " <= " + interpret False = " > "