From f2bbbee7ce82ce38b9927f5888204ba01acf7655 Mon Sep 17 00:00:00 2001 From: Joris Dral Date: Thu, 7 Mar 2024 18:19:59 +0100 Subject: [PATCH] `IOHasBufFS`` interface for I/O using user-supplied buffers --- fs-api/CHANGELOG.md | 11 ++ fs-api/fs-api.cabal | 22 ++- fs-api/src-unix/System/FS/IO/Internal.hs | 37 +++- fs-api/src-win32/System/FS/IO/Internal.hs | 33 ++++ fs-api/src/System/FS/API.hs | 197 +++++++++++++++++++++ fs-api/src/System/FS/API/Types.hs | 2 +- fs-api/src/System/FS/IO.hs | 56 ++++-- fs-api/test/Main.hs | 9 + fs-api/test/Test/System/FS/IO.hs | 93 ++++++++++ fs-sim/fs-sim.cabal | 2 +- fs-sim/src/System/FS/Sim/Error.hs | 118 +++++++++--- fs-sim/src/System/FS/Sim/MockFS.hs | 58 ++++-- fs-sim/src/System/FS/Sim/Pure.hs | 1 + fs-sim/src/System/FS/Sim/STM.hs | 1 + fs-sim/test/Test/System/FS/StateMachine.hs | 47 +++-- 15 files changed, 618 insertions(+), 69 deletions(-) create mode 100644 fs-api/test/Main.hs create mode 100644 fs-api/test/Test/System/FS/IO.hs diff --git a/fs-api/CHANGELOG.md b/fs-api/CHANGELOG.md index 61bea93..0925cc5 100644 --- a/fs-api/CHANGELOG.md +++ b/fs-api/CHANGELOG.md @@ -1,5 +1,16 @@ # Revision history for fs-api +## next version -- ????-??-?? + +### 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 `hGetBufExactlyAt` and `hPutBufExactlyAt` functions that ensure all + requested bytes are read or written respectively. +* Provide an instantiation of the `HasBufFS` interface for `IO`. + ## 0.2.0.1 -- 2023-10-30 ### Patch diff --git a/fs-api/fs-api.cabal b/fs-api/fs-api.cabal index 5b07daf..9af893d 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 @@ -66,3 +66,23 @@ 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 + , 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 5a00ba1..fd57925 100644 --- a/fs-api/src-unix/System/FS/IO/Internal.hs +++ b/fs-api/src-unix/System/FS/IO/Internal.hs @@ -9,11 +9,16 @@ module System.FS.IO.Internal ( , getSize , open , pread + , preadBuf + , pwriteBuf , read + , readBuf , sameError , seek + , tell , truncate , write + , writeBuf ) where import Prelude hiding (read, truncate) @@ -21,15 +26,19 @@ import Prelude hiding (read, truncate) import Control.Monad (void) import Data.ByteString (ByteString) import qualified Data.ByteString.Internal as Internal +import Data.Coerce (coerce) import Data.Int (Int64) import Data.Word (Word32, Word64, Word8) import Foreign (Ptr) +import qualified GHC.IO.Device as Device +import GHC.IO.FD (FD (..)) import System.FS.API.Types (AllowExisting (..), FsError, OpenMode (..), SeekMode (..), sameFsError) 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 @@ -123,16 +132,38 @@ seek :: FHandle -> SeekMode -> Int64 -> IO () seek h seekMode offset = withOpenHandle "seek" h $ \fd -> void $ Posix.fdSeek fd seekMode (fromIntegral offset) +tell :: FHandle -> IO Word64 +tell h = withOpenHandle "tell" h $ \fd -> + fromIntegral <$> Device.tell (FD (coerce fd) 0) + -- | Reads a given number of bytes from the input 'FHandle'. read :: FHandle -> Word64 -> IO ByteString 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..81702f3 100644 --- a/fs-api/src-win32/System/FS/IO/Internal.hs +++ b/fs-api/src-win32/System/FS/IO/Internal.hs @@ -8,11 +8,16 @@ module System.FS.IO.Internal ( , getSize , open , pread + , preadBuf + , pwriteBuf , read + , readBuf , sameError , seek + , tell , truncate , write + , writeBuf ) where import Prelude hiding (read, truncate) @@ -26,6 +31,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 @@ -65,6 +71,9 @@ seek :: FHandle -> SeekMode -> Int64 -> IO () seek fh seekMode size = void <$> withOpenHandle "seek" fh $ \h -> setFilePointerEx h size (fromSeekMode seekMode) +tell :: FHandle -> IO Word64 +tell h = withOpenHandle "tell" h $ fmap fromIntegral . getCurrentFileOffset + fromSeekMode :: SeekMode -> FilePtrDirection fromSeekMode AbsoluteSeek = fILE_BEGIN fromSeekMode RelativeSeek = fILE_CURRENT @@ -78,6 +87,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 +104,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..209188b 100644 --- a/fs-api/src/System/FS/API.hs +++ b/fs-api/src/System/FS/API.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE GADTs #-} @@ -17,6 +18,14 @@ module System.FS.API ( , withFile -- * SomeHasFS , SomeHasFS (..) + -- * Buffer filesystem access + , HasBufFS (..) + , hGetBufAll + , hGetBufAllAt + , hGetBufExactly + , hGetBufExactlyAt + , hPutBufExactly + , hPutBufExactlyAt ) where import Control.Monad.Class.MonadThrow @@ -24,6 +33,7 @@ import qualified Data.ByteString as BS import Data.Int (Int64) import Data.Set (Set) import Data.Word +import qualified Foreign import System.FS.API.Types as Types @@ -105,6 +115,8 @@ data HasFS m h = HasFS { -- may affect this thread). , hGetSize :: HasCallStack => Handle h -> m Word64 + , hTell :: HasCallStack => Handle h -> m AbsOffset + -- Operations of directories -- | Create new directory @@ -175,3 +187,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 +-------------------------------------------------------------------------------} + +-- | 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 because of adding an additional type parameter. +data HasBufFS m h ptr = HasBufFS { + -- | Like 'hGetSome', but the bytes are read into a user-supplied buffer. + -- See __User-supplied buffers__. + hGetBufSome :: HasCallStack + => Handle h + -> ptr Word8 -- ^ Buffer to read bytes into + -> Word64 -- ^ The number of bytes to read + -> m Word64 + -- | Like 'hGetSomeAt', but the bytes are read into a user-supplied buffer. + -- See __User-supplied buffers__. + , hGetBufSomeAt :: HasCallStack + => Handle h + -> ptr Word8 -- ^ Buffer to read bytes into + -> Word64 -- ^ The number of bytes to read + -> AbsOffset -- ^ The file offset at which to read + -> m Word64 + -- | Like 'hPutSome', but the bytes are written from a user-supplied buffer. + -- See __User-supplied buffers__. + , hPutBufSome :: HasCallStack + => Handle h + -> ptr Word8 -- ^ Buffer to write bytes from + -> Word64 -- ^ The number of bytes to write + -> m Word64 + -- | 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 + -> ptr Word8 -- ^ Buffer to write bytes from + -> Word64 -- ^ The number of bytes to write + -> AbsOffset -- ^ The file offset at which to write + -> m Word64 + } + +-- | Wrapper for 'hGetBufSome' that ensures that we read all bytes from a file. +-- +-- A sufficiently large buffer can be provided by comparing 'hGetSize' against +-- 'hTell'. +-- +-- Is implemented in terms of 'hGetBufExactly'. +hGetBufAll :: forall m h. (HasCallStack, MonadThrow m) + => HasFS m h + -> HasBufFS m h Foreign.Ptr + -> Handle h + -> Foreign.Ptr Word8 -- ^ Buffer to read bytes into + -> m Word64 +hGetBufAll hfs hbfs h buf = do + sz <- hGetSize hfs h + off <- hTell hfs h + let c = sz - fromIntegral off + hGetBufExactly hfs hbfs h buf c + +-- | 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 Foreign.Ptr + -> Handle h + -> Foreign.Ptr Word8 -- ^ Buffer to read bytes into + -> AbsOffset -- ^ The file offset at which to read + -> m Word64 +hGetBufAllAt hfs hbfs h buf off = do + sz <- hGetSize hfs h + let c = sz - fromIntegral off + hGetBufExactlyAt hfs hbfs h buf 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 Foreign.Ptr + -> Handle h + -> Foreign.Ptr Word8 -- ^ Buffer to read bytes into + -> Word64 -- ^ The number of bytes to read + -> m Word64 +hGetBufExactly hfs hbfs h buf c = go 0 buf + where + go :: Word64 -> Foreign.Ptr Word8 -> m Word64 + go !remainingCount !currentBuf + | remainingCount == 0 = pure c + | otherwise = do + readBytes <- hGetBufSome hbfs h currentBuf 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) + (currentBuf `Foreign.plusPtr` 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 Foreign.Ptr + -> Handle h + -> Foreign.Ptr Word8 -- ^ Buffer to read bytes into + -> Word64 -- ^ The number of bytes to read + -> AbsOffset -- ^ The file offset at which to read + -> m Word64 +hGetBufExactlyAt hfs hbfs h buf c off = go 0 off buf + where + go :: Word64 -> AbsOffset -> Foreign.Ptr Word8 -> m Word64 + go !remainingCount !currentOffset currentBuf + | remainingCount == 0 = pure c + | otherwise = do + readBytes <- hGetBufSomeAt hbfs h currentBuf 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) + (currentBuf `Foreign.plusPtr` 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 Foreign.Ptr + -> Handle h + -> Foreign.Ptr Word8 -- ^ Buffer to write bytes from + -> Word64 -- ^ The number of bytes to write + -> m Word64 +hPutBufExactly hbfs h buf c = go 0 buf + where + go :: Word64 -> Foreign.Ptr Word8 -> m Word64 + go !remainingCount currentBuf = do + writtenBytes <- hPutBufSome hbfs h currentBuf remainingCount + let remainingCount' = remainingCount - writtenBytes + if remainingCount' == 0 + then pure c + else go remainingCount' + (currentBuf `Foreign.plusPtr` 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 Foreign.Ptr + -> Handle h + -> Foreign.Ptr Word8 -- ^ Buffer to write bytes from + -> Word64 -- ^ The number of bytes to write + -> AbsOffset -- ^ The file offset at which to write + -> m Word64 +hPutBufExactlyAt hbfs h buf c off = go 0 off buf + where + go :: Word64 -> AbsOffset -> Foreign.Ptr Word8 -> m Word64 + go !remainingCount !currentOffset currentBuf = do + writtenBytes <- hPutBufSomeAt hbfs h currentBuf remainingCount currentOffset + let remainingCount' = remainingCount - writtenBytes + if remainingCount' == 0 + then pure c + else go remainingCount' + (currentOffset + fromIntegral writtenBytes) + (currentBuf `Foreign.plusPtr` fromIntegral writtenBytes) diff --git a/fs-api/src/System/FS/API/Types.hs b/fs-api/src/System/FS/API/Types.hs index f53095e..3e312f0 100644 --- a/fs-api/src/System/FS/API/Types.hs +++ b/fs-api/src/System/FS/API/Types.hs @@ -194,7 +194,7 @@ instance Show (Handle h) where -------------------------------------------------------------------------------} newtype AbsOffset = AbsOffset { unAbsOffset :: Word64 } - deriving (Eq, Ord, Enum, Bounded, Num, Show) + deriving (Eq, Ord, Enum, Bounded, Num, Show, Real, Integral) {------------------------------------------------------------------------------- Errors diff --git a/fs-api/src/System/FS/IO.hs b/fs-api/src/System/FS/IO.hs index 268c697..08df813 100644 --- a/fs-api/src/System/FS/IO.hs +++ b/fs-api/src/System/FS/IO.hs @@ -3,6 +3,8 @@ module System.FS.IO ( -- * IO implementation & monad HandleIO , ioHasFS + -- * HasBufFS + , ioHasBufFS ) where import Control.Concurrent.MVar @@ -10,7 +12,7 @@ import qualified Control.Exception as E import Control.Monad.IO.Class (MonadIO (..)) import qualified Data.ByteString.Unsafe as BS 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 @@ -50,9 +52,11 @@ ioHasFS mount = HasFS { F.truncate h sz , hGetSize = \(Handle h fp) -> liftIO $ rethrowFsError fp $ F.getSize h + , hTell = \(Handle h fp) -> liftIO $ rethrowFsError fp $ + AbsOffset <$> F.tell 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 +80,40 @@ 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 => MountPoint -> HasBufFS m HandleIO Foreign.Ptr +ioHasBufFS mount = HasBufFS { + hGetBufSome = \(Handle h fp) buf c -> liftIO $ rethrowFsError fp $ + fromIntegral <$> F.readBuf h buf (fromIntegral c) + , hGetBufSomeAt = \(Handle h fp) buf c off -> liftIO $ rethrowFsError fp $ + fromIntegral <$> F.preadBuf h buf (fromIntegral c) (fromIntegral $ unAbsOffset off) + , hPutBufSome = \(Handle h fp) buf c -> liftIO $ rethrowFsError fp $ + fromIntegral <$> F.writeBuf h buf (fromIntegral c) + , hPutBufSomeAt = \(Handle h fp) buf c off -> liftIO $ rethrowFsError fp $ + fromIntegral <$> F.pwriteBuf h buf (fromIntegral 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..f030151 --- /dev/null +++ b/fs-api/test/Test/System/FS/IO.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE BangPatterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Test.System.FS.IO (tests) where + +import Data.ByteString +import qualified Data.ByteString as BS +import Data.ByteString.Unsafe as BSU +import Data.Word (Word64) +import qualified Foreign +import Prelude hiding (read) +import qualified System.FS.API as FS +import qualified System.FS.IO as IO +import System.IO.Temp +import Test.Tasty +import Test.Tasty.QuickCheck + +tests :: TestTree +tests = testGroup "Test.System.FS.IO" [ + testProperty "prop_roundtrip_hPutGetBufSomeAt" + prop_roundtrip_hPutGetBufSomeAt + , 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 + +-- | 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_hPutGetBufSomeAt :: + ByteString + -> Small Word64 -- ^ Prefix length + -> FS.AbsOffset + -> Property +prop_roundtrip_hPutGetBufSomeAt bs (Small c) off = + BS.length bs >= fromIntegral c ==> + ioProperty $ withSystemTempDirectory "prop_readWrite" $ \dirPath -> do + let hfs = IO.ioHasFS (FS.MountPoint dirPath) + hbfs = IO.ioHasBufFS (FS.MountPoint dirPath) + !bsCopy = BS.copy bs + + FS.withFile hfs (FS.mkFsPath ["temp"]) (FS.WriteMode FS.MustBeNew) $ \h -> do + BSU.unsafeUseAsCStringLen bs $ \(ptr, _n) -> do + m <- FS.hPutBufExactlyAt hbfs h (Foreign.castPtr ptr) c off -- m <= c + let writeTest = counterexample "wrote too many bytes" (m .<= c) + o <- FS.hGetBufExactlyAt hfs hbfs h (Foreign.castPtr ptr) m off -- o <= m + let readTest = counterexample "read too many bytes" (o .<= m) + let copyTest = counterexample "(prefix of) input and output bytestring do not match" + $ BS.take (fromIntegral o) bsCopy === BS.take (fromIntegral o) bs + pure (writeTest .&&. readTest .&&. copyTest) + +-- | Like 'prop_roundtrip_hPutGetBufSomeAt', but for buffered I\/O that ensures +-- all bytes are written/read. +prop_roundtrip_hPutGetBufExactlyAt :: + ByteString + -> Small Word64 -- ^ Prefix length + -> FS.AbsOffset + -> Property +prop_roundtrip_hPutGetBufExactlyAt bs (Small c) off = + BS.length bs >= fromIntegral c ==> + ioProperty $ withSystemTempDirectory "prop_readWrite" $ \dirPath -> do + let hfs = IO.ioHasFS (FS.MountPoint dirPath) + hbfs = IO.ioHasBufFS (FS.MountPoint dirPath) + !bsCopy = BS.copy bs + + FS.withFile hfs (FS.mkFsPath ["temp"]) (FS.WriteMode FS.MustBeNew) $ \h -> do + BSU.unsafeUseAsCStringLen bs $ \(ptr, _n) -> do + m <- FS.hPutBufSomeAt hbfs h (Foreign.castPtr ptr) c off -- m == c + let writeTest = counterexample "wrote too few bytes" (m === c) + o <- FS.hGetBufSomeAt hbfs h (Foreign.castPtr ptr) c off -- o == c + let readTest = counterexample "read too few byes" (o === c) + let copyTest = counterexample "input and output bytestring do not match" + $ bsCopy === bs + pure (writeTest .&&. readTest .&&. copyTest) + +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 = " > " diff --git a/fs-sim/fs-sim.cabal b/fs-sim/fs-sim.cabal index 8448b49..004fd36 100644 --- a/fs-sim/fs-sim.cabal +++ b/fs-sim/fs-sim.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: Testing build-type: Simple extra-doc-files: CHANGELOG.md diff --git a/fs-sim/src/System/FS/Sim/Error.hs b/fs-sim/src/System/FS/Sim/Error.hs index b3f3f9b..20ea7f3 100644 --- a/fs-sim/src/System/FS/Sim/Error.hs +++ b/fs-sim/src/System/FS/Sim/Error.hs @@ -1,5 +1,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} @@ -211,6 +212,7 @@ data Errors = Errors , hOpenE :: ErrorStream , hCloseE :: ErrorStream , hSeekE :: ErrorStream + , hTellE :: ErrorStream , hGetSomeE :: ErrorStreamGetSome , hGetSomeAtE :: ErrorStreamGetSome , hPutSomeE :: ErrorStreamPutSome @@ -230,28 +232,72 @@ data Errors = Errors -- | Return 'True' if all streams are empty ('null'). allNull :: Errors -> Bool -allNull Errors {..} = Stream.null dumpStateE - && Stream.null hOpenE - && Stream.null hCloseE - && Stream.null hSeekE - && Stream.null hGetSomeE - && Stream.null hGetSomeAtE - && Stream.null hPutSomeE - && Stream.null hTruncateE - && Stream.null hGetSizeE - && Stream.null createDirectoryE - && Stream.null createDirectoryIfMissingE - && Stream.null listDirectoryE - && Stream.null doesDirectoryExistE - && Stream.null doesFileExistE - && Stream.null removeFileE - && Stream.null renameFileE - +allNull errs = + Stream.null dumpStateE + && Stream.null hOpenE + && Stream.null hCloseE + && Stream.null hSeekE + && Stream.null hTellE + && Stream.null hGetSomeE + && Stream.null hGetSomeAtE + && Stream.null hPutSomeE + && Stream.null hTruncateE + && Stream.null hGetSizeE + && Stream.null createDirectoryE + && Stream.null createDirectoryIfMissingE + && Stream.null listDirectoryE + && Stream.null doesDirectoryExistE + && Stream.null doesFileExistE + && Stream.null removeDirectoryRecursiveE + && Stream.null removeFileE + && Stream.null renameFileE + where + Errors + dumpStateE + hOpenE + hCloseE + hSeekE + hTellE + hGetSomeE + hGetSomeAtE + hPutSomeE + hTruncateE + hGetSizeE + createDirectoryE + createDirectoryIfMissingE + listDirectoryE + doesDirectoryExistE + doesFileExistE + removeDirectoryRecursiveE + removeFileE + renameFileE + = errs instance Show Errors where - show Errors {..} = + show errs = "Errors {" <> intercalate ", " streams <> "}" where + Errors + dumpStateE + hOpenE + hCloseE + hSeekE + hTellE + hGetSomeE + hGetSomeAtE + hPutSomeE + hTruncateE + hGetSizeE + createDirectoryE + createDirectoryIfMissingE + listDirectoryE + doesDirectoryExistE + doesFileExistE + removeDirectoryRecursiveE + removeFileE + renameFileE + = errs + -- | Show a stream unless it is empty s :: Show a => String -> Stream a -> Maybe String s fld str | Stream.null str = Nothing @@ -263,6 +309,7 @@ instance Show Errors where , s "hOpenE" hOpenE , s "hCloseE" hCloseE , s "hSeekE" hSeekE + , s "hTellE" hTellE , s "hGetSomeE" hGetSomeE , s "hGetSomeAtE" hGetSomeAtE , s "hPutSomeE" hPutSomeE @@ -273,10 +320,12 @@ instance Show Errors where , s "listDirectoryE" listDirectoryE , s "doesDirectoryExistE" doesDirectoryExistE , s "doesFileExistE" doesFileExistE + , s "removeDirectyRecursiveE" removeDirectoryRecursiveE , s "removeFileE" removeFileE , s "renameFileE" renameFileE ] + emptyErrors :: Errors emptyErrors = simpleErrors Stream.empty @@ -288,6 +337,7 @@ simpleErrors es = Errors , hOpenE = es , hCloseE = es , hSeekE = es + , hTellE = es , hGetSomeE = Left <$> es , hGetSomeAtE = Left <$> es , hPutSomeE = (Left . (, Nothing)) <$> es @@ -327,6 +377,7 @@ genErrors genPartialWrites genSubstituteWithJunk = do , FsResourceAlreadyInUse, FsResourceAlreadyExist , FsInsufficientPermissions, FsTooManyOpenFiles ] hSeekE <- streamGen 3 [ FsReachedEOF ] + hTellE <- streamGen 3 [ FsResourceInappropriateType ] hGetSomeE <- streamGen' 20 [ (1, return $ Left FsReachedEOF) , (3, Right <$> arbitrary) ] @@ -365,11 +416,12 @@ genErrors genPartialWrites genSubstituteWithJunk = do instance Arbitrary Errors where arbitrary = genErrors True True - shrink err@Errors {..} = filter (not . allNull) $ concat + shrink err = filter (not . allNull) $ concat [ (\s' -> err { dumpStateE = s' }) <$> Stream.shrinkStream dumpStateE , (\s' -> err { hOpenE = s' }) <$> Stream.shrinkStream hOpenE , (\s' -> err { hCloseE = s' }) <$> Stream.shrinkStream hCloseE , (\s' -> err { hSeekE = s' }) <$> Stream.shrinkStream hSeekE + , (\s' -> err { hTellE = s' }) <$> Stream.shrinkStream hTellE , (\s' -> err { hGetSomeE = s' }) <$> Stream.shrinkStream hGetSomeE , (\s' -> err { hGetSomeAtE = s' }) <$> Stream.shrinkStream hGetSomeAtE , (\s' -> err { hPutSomeE = s' }) <$> Stream.shrinkStream hPutSomeE @@ -380,9 +432,31 @@ instance Arbitrary Errors where , (\s' -> err { listDirectoryE = s' }) <$> Stream.shrinkStream listDirectoryE , (\s' -> err { doesDirectoryExistE = s' }) <$> Stream.shrinkStream doesDirectoryExistE , (\s' -> err { doesFileExistE = s' }) <$> Stream.shrinkStream doesFileExistE + , (\s' -> err { removeDirectoryRecursiveE = s' }) <$> Stream.shrinkStream removeDirectoryRecursiveE , (\s' -> err { removeFileE = s' }) <$> Stream.shrinkStream removeFileE , (\s' -> err { renameFileE = s' }) <$> Stream.shrinkStream renameFileE ] + where + Errors + dumpStateE + hOpenE + hCloseE + hSeekE + hTellE + hGetSomeE + hGetSomeAtE + hPutSomeE + hTruncateE + hGetSizeE + createDirectoryE + createDirectoryIfMissingE + listDirectoryE + doesDirectoryExistE + doesFileExistE + removeDirectoryRecursiveE + removeFileE + renameFileE + = err {------------------------------------------------------------------------------- Simulate Errors monad @@ -419,6 +493,9 @@ mkSimErrorHasFS fsVar errorsVar = , hSeek = \h m n -> withErr' errorsVar h (hSeek h m n) "hSeek" hSeekE (\e es -> es { hSeekE = e }) + , hTell = \h -> + withErr' errorsVar h (hTell h) "hTell" + hTellE (\e es -> es { hTellE = e }) , hGetSome = hGetSome' errorsVar hGetSome , hGetSomeAt = hGetSomeAt' errorsVar hGetSomeAt , hPutSome = hPutSome' errorsVar hPutSome @@ -537,8 +614,7 @@ withErr' :: (MonadSTM m, MonadThrow m, HasCallStack) -> (Errors -> ErrorStream) -- ^ @getter@ -> (ErrorStream -> Errors -> Errors) -- ^ @setter@ -> m a -withErr' errorsVar handle action msg getter setter = - withErr errorsVar (handlePath handle) action msg getter setter +withErr' errorsVar handle = withErr errorsVar (handlePath handle) -- | Execute the wrapped 'hGetSome', throw an error, or simulate a partial -- read, depending on the corresponding 'ErrorStreamGetSome' (see diff --git a/fs-sim/src/System/FS/Sim/MockFS.hs b/fs-sim/src/System/FS/Sim/MockFS.hs index 58199ac..e2f40cd 100644 --- a/fs-sim/src/System/FS/Sim/MockFS.hs +++ b/fs-sim/src/System/FS/Sim/MockFS.hs @@ -34,6 +34,7 @@ module System.FS.Sim.MockFS ( , hOpen , hPutSome , hSeek + , hTell , hTruncate -- * Operations on directories , createDirectory @@ -120,7 +121,7 @@ data OpenHandleState = OpenHandle { isWriteHandle :: OpenHandleState -> Bool isWriteHandle OpenHandle{..} = case openPtr of RW _ True _ -> True - Append -> True + Append _ -> True _ -> False -- | File pointer @@ -134,8 +135,11 @@ data FilePtr = -- | Append-only pointer -- - -- Offset is always the end of the file in append mode - | Append + -- Offset is always the end of the file in append mode, unless the file has + -- been truncated recently. If truncated, the offset is "unknown" until we + -- write to the file, though we will always start writing at the point where + -- the file was truncated to + | Append !(Maybe Word64) deriving (Show, Generic) data ClosedHandleState = ClosedHandle { @@ -229,7 +233,7 @@ seekFilePtr MockFS{..} (Handle h _) seekMode o = do when (o' > fsize) $ throwError (errNegative openFilePath) let cur' = fsize - o' return $ RW r w cur' - (Append, _, _) -> + (Append _, _, _) -> throwError (errAppend openFilePath) where errPastEnd fp = FsError { @@ -465,6 +469,7 @@ hOpen fp openMode = do , fsErrorStack = prettyCallStack , fsLimitation = True } + fileExists <- doesFileExist fp modifyMockFS $ \fs -> do let alreadyHasWriter = any (\hs -> openFilePath hs == fp && isWriteHandle hs) $ @@ -482,16 +487,18 @@ hOpen fp openMode = do checkFsTree $ FS.getFile fp (mockFiles fs) files' <- checkFsTree $ FS.openFile fp ex (mockFiles fs) return $ newHandle (fs { mockFiles = files' }) - (OpenHandle fp (filePtr openMode)) + (OpenHandle fp (filePtr openMode fileExists)) where ex :: AllowExisting ex = allowExisting openMode - filePtr :: OpenMode -> FilePtr - filePtr ReadMode = RW True False 0 - filePtr (WriteMode _) = RW False True 0 - filePtr (ReadWriteMode _) = RW True True 0 - filePtr (AppendMode _) = Append + filePtr :: OpenMode -> Bool -> FilePtr + filePtr ReadMode _ = RW True False 0 + filePtr (WriteMode _ ) _ = RW False True 0 + filePtr (ReadWriteMode _ ) _ = RW True True 0 + filePtr (AppendMode aex) fExists + | aex == AllowExisting && fExists = Append Nothing + | otherwise = Append (Just 0) -- | Mock implementation of 'hClose' hClose :: CanSimFS m => Handle' -> m () @@ -520,6 +527,25 @@ hSeek h seekMode o = withOpenHandleRead h $ \fs hs -> do openPtr' <- seekFilePtr fs h seekMode o return ((), hs { openPtr = openPtr' }) +-- | Get the current offset stored in the file handle +hTell :: CanSimFS m => Handle' -> m AbsOffset +hTell h = withOpenHandleRead h $ \_ hs@OpenHandle{..} -> do + case openPtr of + RW _ _ off -> pure (AbsOffset off, hs) + Append offM -> do + case offM of + Nothing -> throwError (errTellOnTruncatedFile openFilePath) + Just off -> pure (AbsOffset off, hs) + where + errTellOnTruncatedFile fp = FsError { + fsErrorType = FsInvalidArgument + , fsErrorPath = fsToFsErrorPathUnmounted fp + , fsErrorString = "hTell: not supported on truncated files" + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = True + } + -- | Get bytes from handle -- -- NOTE: Unlike real I/O, we disallow 'hGetSome' on a handle in append mode. @@ -532,7 +558,7 @@ hGetSome h n = unless r $ throwError (errNoReadAccess openFilePath "write") let bs = BS.take (fromIntegral n) . BS.drop (fromIntegral o) $ file return (bs, hs { openPtr = RW True w (o + fromIntegral (BS.length bs)) }) - Append -> throwError (errNoReadAccess openFilePath "append") + Append _ -> throwError (errNoReadAccess openFilePath "append") where errNoReadAccess fp mode = FsError { fsErrorType = FsInvalidArgument @@ -563,7 +589,7 @@ hGetSomeAt h n o = -- EOF, in AbsoluteSeek mode. when (o' > fsize) $ throwError (errPastEnd openFilePath) return (bs, hs) - Append -> throwError (errNoReadAccess openFilePath "append") + Append _ -> throwError (errNoReadAccess openFilePath "append") where errNoReadAccess fp mode = FsError { fsErrorType = FsInvalidArgument @@ -593,11 +619,11 @@ hPutSome h toWrite = let file' = replace o toWrite file files' <- checkFsTree $ FS.replace openFilePath file' (mockFiles fs) return (written, (files', hs { openPtr = RW r w (o + written) })) - Append -> do + Append o -> do file <- checkFsTree $ FS.getFile openFilePath (mockFiles fs) let file' = file <> toWrite files' <- checkFsTree $ FS.replace openFilePath file' (mockFiles fs) - return (written, (files', hs)) + return (written, (files', hs { openPtr = Append (if BS.length toWrite == 0 then o else Just (fromIntegral (BS.length file'))) })) where written = toEnum $ BS.length toWrite @@ -674,8 +700,8 @@ hTruncate h sz = , fsErrorStack = prettyCallStack , fsLimitation = True } - (False, Append) -> - return Append + (False, Append _) -> + return (Append Nothing) let file' = BS.take (fromIntegral sz) file files' <- checkFsTree $ FS.replace openFilePath file' (mockFiles fs) -- TODO: Don't replace the file pointer (not changed) diff --git a/fs-sim/src/System/FS/Sim/Pure.hs b/fs-sim/src/System/FS/Sim/Pure.hs index 4ccd5a8..6c26433 100644 --- a/fs-sim/src/System/FS/Sim/Pure.hs +++ b/fs-sim/src/System/FS/Sim/Pure.hs @@ -29,6 +29,7 @@ pureHasFS = HasFS { , hClose = Mock.hClose , hIsOpen = Mock.hIsOpen , hSeek = Mock.hSeek + , hTell = Mock.hTell , hGetSome = Mock.hGetSome , hGetSomeAt = Mock.hGetSomeAt , hPutSome = Mock.hPutSome diff --git a/fs-sim/src/System/FS/Sim/STM.hs b/fs-sim/src/System/FS/Sim/STM.hs index 1a9ee59..6eefe54 100644 --- a/fs-sim/src/System/FS/Sim/STM.hs +++ b/fs-sim/src/System/FS/Sim/STM.hs @@ -50,6 +50,7 @@ simHasFS var = HasFS { , hClose = sim . Mock.hClose , hIsOpen = sim . Mock.hIsOpen , hSeek = sim ..: Mock.hSeek + , hTell = sim . Mock.hTell , hGetSome = sim .: Mock.hGetSome , hGetSomeAt = sim ..: Mock.hGetSomeAt , hPutSome = sim .: Mock.hPutSome diff --git a/fs-sim/test/Test/System/FS/StateMachine.hs b/fs-sim/test/Test/System/FS/StateMachine.hs index a204f87..f361b92 100644 --- a/fs-sim/test/Test/System/FS/StateMachine.hs +++ b/fs-sim/test/Test/System/FS/StateMachine.hs @@ -89,7 +89,7 @@ import qualified Test.StateMachine.Labelling as C import qualified Test.StateMachine.Sequential as QSM import qualified Test.StateMachine.Types as QSM import qualified Test.StateMachine.Types.Rank2 as Rank2 -import Test.Tasty (TestTree, testGroup) +import Test.Tasty (TestTree, localOption, testGroup) import Test.Tasty.QuickCheck import System.FS.API @@ -143,6 +143,7 @@ data Cmd fp h = | Close h | IsOpen h | Seek h SeekMode Int64 + | Tell h | Get h Word64 | GetAt h Word64 AbsOffset | Put h ByteString @@ -171,6 +172,7 @@ data Success fp h = | ByteString ByteString | Strings (Set String) | Bool Bool + | Offset AbsOffset deriving (Eq, Show, Functor, Foldable) -- | Successful semantics @@ -191,6 +193,7 @@ run hasFS@HasFS{..} = go go (IsOpen h ) = Bool <$> hIsOpen h go (Close h ) = Unit <$> hClose h go (Seek h mode sz ) = Unit <$> hSeek h mode sz + go (Tell h ) = Offset <$> hTell h -- Note: we're not using 'hGetSome', 'hGetSomeAt' and 'hPutSome' that may -- produce partial reads/writes, but wrappers around them that handle -- partial reads/writes, see #502. @@ -500,6 +503,7 @@ generator Model{..} = oneof $ concat [ fmap At $ Close <$> genHandle , fmap At $ IsOpen <$> genHandle , fmap At $ Seek <$> genHandle <*> genSeekMode <*> genOffset + , fmap At $ Tell <$> genHandle , fmap At $ Get <$> genHandle <*> (getSmall <$> arbitrary) , fmap At $ GetAt <$> genHandle <*> (getSmall <$> arbitrary) <*> arbitrary , fmap At $ Put <$> genHandle <*> (BS.pack <$> arbitrary) @@ -811,10 +815,16 @@ data Tag = -- > Put h1 | TagWrite - -- | Seek from end of a file + -- | Seek with a mode -- - -- > Seek h IO.SeekFromEnd n (n<0) - | TagSeekFromEnd + -- > Seek h ... n (n<0) + | TagSeekWithMode SeekMode + + -- | Seek an absolute offset and then tell should return the same offset + -- + -- > Seek h ... n + -- > Tell h ... + | TagSeekTellWithMode SeekMode -- | Create a directory -- @@ -959,7 +969,8 @@ tag = C.classify [ , tagWriteWriteRead Map.empty , tagOpenDirectory Set.empty , tagWrite - , tagSeekFromEnd + , tagSeekWithMode + , tagSeekTellWithMode Map.empty , tagCreateDirectory , tagDoesFileExistOK , tagDoesFileExistKO @@ -1183,11 +1194,21 @@ tag = C.classify [ Left TagWrite _otherwise -> Right tagWrite - tagSeekFromEnd :: EventPred - tagSeekFromEnd = successful $ \ev _ -> + tagSeekWithMode :: EventPred + tagSeekWithMode = successful $ \ev _ -> case eventMockCmd ev of - Seek _ SeekFromEnd n | n < 0 -> Left TagSeekFromEnd - _otherwise -> Right tagSeekFromEnd + Seek _ m n | n > 0 -> Left (TagSeekWithMode m) + _otherwise -> Right tagSeekWithMode + + tagSeekTellWithMode :: Map HandleMock SeekMode -> EventPred + tagSeekTellWithMode seek = successful $ \ev _suc -> + case eventMockCmd ev of + Seek (Handle h _) m n | n /= 0 -> + Right $ tagSeekTellWithMode (Map.insert h m seek) + Tell (Handle h _) | Just m <- Map.lookup h seek -> + Left (TagSeekTellWithMode m) + _otherwise -> + Right $ tagSeekTellWithMode seek tagCreateDirectory :: EventPred tagCreateDirectory = successful $ \ev _ -> @@ -1438,7 +1459,7 @@ showLabelledExamples :: IO () showLabelledExamples = showLabelledExamples' Nothing 1000 (const True) prop_sequential :: FilePath -> Property -prop_sequential tmpDir = withMaxSuccess 10000 $ +prop_sequential tmpDir = QSM.forAllCommands (sm mountUnused) Nothing $ \cmds -> QC.monadicIO $ do (tstTmpDir, hist, res) <- QC.run $ withTempDirectory tmpDir "HasFS" $ \tstTmpDir -> do @@ -1453,13 +1474,16 @@ prop_sequential tmpDir = withMaxSuccess 10000 $ return (tstTmpDir, hist, res) QSM.prettyCommands (sm mountUnused) hist + $ QSM.checkCommandNames cmds $ tabulate "Tags" (map show $ tag (execCmds cmds)) $ counterexample ("Mount point: " ++ tstTmpDir) $ res === QSM.Ok tests :: FilePath -> TestTree tests tmpDir = testGroup "HasFS" [ - testProperty "q-s-m" $ prop_sequential tmpDir + localOption (QuickCheckTests 10000) + $ localOption (QuickCheckMaxSize 500) + $ testProperty "q-s-m" $ prop_sequential tmpDir ] -- | Unused mount mount @@ -1513,6 +1537,7 @@ instance (Condense fp, Condense h) => Condense (Cmd fp h) where go (Close h) = ["close", condense h] go (IsOpen h) = ["isOpen", condense h] go (Seek h mode o) = ["seek", condense h, condense mode, condense o] + go (Tell h) = ["tell", condense h] go (Get h n) = ["get", condense h, condense n] go (GetAt h n o) = ["getAt", condense h, condense n, condense o] go (Put h bs) = ["put", condense h, condense bs]