From dd23e6c62df6ff1553b7e5e69939146c403ae060 Mon Sep 17 00:00:00 2001 From: Joris Dral Date: Thu, 7 Mar 2024 15:45:38 +0100 Subject: [PATCH] TOSQUASH --- fs-api/src-unix/System/FS/IO/Internal.hs | 22 ++- fs-api/src-win32/System/FS/IO/Internal.hs | 18 ++- fs-api/src/System/FS/API.hs | 162 +++++++++++++++++---- fs-api/src/System/FS/API/Types.hs | 2 +- fs-api/src/System/FS/IO.hs | 9 +- fs-api/test/Test/System/FS/IO.hs | 53 ++++--- fs-sim/src/System/FS/Sim/Error.hs | 118 ++++++++++++--- fs-sim/src/System/FS/Sim/MockFS.hs | 32 ++-- 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 ++++-- 11 files changed, 365 insertions(+), 100 deletions(-) diff --git a/fs-api/src-unix/System/FS/IO/Internal.hs b/fs-api/src-unix/System/FS/IO/Internal.hs index 8dc9614..fd57925 100644 --- a/fs-api/src-unix/System/FS/IO/Internal.hs +++ b/fs-api/src-unix/System/FS/IO/Internal.hs @@ -12,10 +12,13 @@ module System.FS.IO.Internal ( , preadBuf , pwriteBuf , read + , readBuf , sameError , seek + , tell , truncate , write + , writeBuf ) where import Prelude hiding (read, truncate) @@ -23,14 +26,17 @@ 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 (ByteCount, Fd, FileOffset) +import System.Posix (ByteCount, Fd (..), FileOffset) import qualified System.Posix.IO.ByteString.Ext as Posix (fdPreadBuf, fdPwriteBuf) @@ -126,12 +132,22 @@ 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 -> @@ -141,13 +157,13 @@ pread h bytes offset = withOpenHandle "pread" h $ \fd -> -- 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 fh buf c off = withOpenHandle "preadBuf" fh $ \h -> Posix.fdPreadBuf h buf c off +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 fh buf c off = withOpenHandle "pwriteBuf" fh $ \h -> Posix.fdPwriteBuf h buf c off +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 207e802..452a00f 100644 --- a/fs-api/src-win32/System/FS/IO/Internal.hs +++ b/fs-api/src-win32/System/FS/IO/Internal.hs @@ -11,10 +11,12 @@ module System.FS.IO.Internal ( , preadBuf , pwriteBuf , read + , readBuf , sameError , seek , truncate , write + , writeBuf ) where import Prelude hiding (read, truncate) @@ -81,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 @@ -91,18 +101,18 @@ pread fh bytes pos = withOpenHandle "pread" fh $ \h -> return n preadBuf :: FHandle -> Ptr Word8 -> ByteCount -> FileOffset -> IO ByteCount -preadBuf fh bufptr c off = withOpenHandle "preadBuf" fh $ \h -> do +preadBuf fh buf c off = withOpenHandle "preadBuf" fh $ \h -> do initialOffset <- getCurrentFileOffset h _ <- setFilePointerEx h (fromIntegral off) fILE_BEGIN - n <- fromIntegral <$> win32_ReadFile h bufptr (fromIntegral c) Nothing + 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 bufptr c off = withOpenHandle "pwriteBuf" fh $ \h -> do +pwriteBuf fh buf c off = withOpenHandle "pwriteBuf" fh $ \h -> do initialOffset <- getCurrentFileOffset h _ <- setFilePointerEx h (fromIntegral off) fILE_BEGIN - n <- fromIntegral <$> win32_WriteFile h bufptr (fromIntegral c) Nothing + n <- fromIntegral <$> win32_WriteFile h buf (fromIntegral c) Nothing _ <- setFilePointerEx h initialOffset fILE_BEGIN return n diff --git a/fs-api/src/System/FS/API.hs b/fs-api/src/System/FS/API.hs index b92a9f2..209188b 100644 --- a/fs-api/src/System/FS/API.hs +++ b/fs-api/src/System/FS/API.hs @@ -20,7 +20,11 @@ module System.FS.API ( , SomeHasFS (..) -- * Buffer filesystem access , HasBufFS (..) + , hGetBufAll + , hGetBufAllAt + , hGetBufExactly , hGetBufExactlyAt + , hPutBufExactly , hPutBufExactlyAt ) where @@ -111,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 @@ -188,48 +194,125 @@ data SomeHasFS m where -- | Abstract interface for performing I\/O using user-supplied buffers. -- --- 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. +-- [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. -- --- TODO: add versions that use the file offset that is stored in the file --- handle, akin to 'hGetSome' and 'hPutSome'. +-- 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 'hGetSomeAt', but the resulting bytes are read into a - -- user-supplied buffer. - 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 resulting bytes are written from a - -- user-supplied buffer at a given offset. This offset does not affect the - -- offset stored in the file handle (see 'hGetSomeAt'). - , 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 - -- | See 'mkFsErrorPath'. - -- - -- Note: this function is included here so that we can use 'HasBufFS' without - -- providing a 'HasBufFS'. For an example, see 'hGetBufExactlyAt'. - , mkBufFsErrorPath :: FsPath -> FsErrorPath + -- | 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) - => HasBufFS m h Foreign.Ptr + => 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 hbfs h buf c off = go 0 off buf +hGetBufExactlyAt hfs hbfs h buf c off = go 0 off buf where go :: Word64 -> AbsOffset -> Foreign.Ptr Word8 -> m Word64 go !remainingCount !currentOffset currentBuf @@ -239,7 +322,7 @@ hGetBufExactlyAt hbfs h buf c off = go 0 off buf if readBytes == 0 then throwIO FsError { fsErrorType = FsReachedEOF - , fsErrorPath = mkBufFsErrorPath hbfs $ handlePath h + , fsErrorPath = mkFsErrorPath hfs $ handlePath h , fsErrorString = "hGetBufExactlyAt found eof before reading " ++ show c ++ " bytes" , fsErrorNo = Nothing , fsErrorStack = prettyCallStack @@ -250,6 +333,25 @@ hGetBufExactlyAt hbfs h buf c off = go 0 off buf (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) 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 77036cd..08df813 100644 --- a/fs-api/src/System/FS/IO.hs +++ b/fs-api/src/System/FS/IO.hs @@ -52,6 +52,8 @@ 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 (Foreign.castPtr ptr) (fromIntegral len) @@ -104,11 +106,14 @@ _rethrowFsError mount fp action = do ioHasBufFS :: MonadIO m => MountPoint -> HasBufFS m HandleIO Foreign.Ptr ioHasBufFS mount = HasBufFS { - hGetBufSomeAt = \(Handle h fp) buf c off -> liftIO $ rethrowFsError fp $ + 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) - , mkBufFsErrorPath = fsToFsErrorPath mount } where rethrowFsError = _rethrowFsError mount diff --git a/fs-api/test/Test/System/FS/IO.hs b/fs-api/test/Test/System/FS/IO.hs index 350e804..f030151 100644 --- a/fs-api/test/Test/System/FS/IO.hs +++ b/fs-api/test/Test/System/FS/IO.hs @@ -6,6 +6,7 @@ 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 @@ -26,6 +27,10 @@ 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 @@ -34,10 +39,11 @@ instance Arbitrary ByteString where -- because the behaviour is then undefined. prop_roundtrip_hPutGetBufSomeAt :: ByteString - -> Positive Int -- ^ Prefix length + -> Small Word64 -- ^ Prefix length + -> FS.AbsOffset -> Property -prop_roundtrip_hPutGetBufSomeAt bs (Positive c) = - BS.length bs >= c ==> +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) @@ -45,20 +51,23 @@ prop_roundtrip_hPutGetBufSomeAt bs (Positive c) = 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) (fromIntegral c) 0 -- m <= c - o <- FS.hGetBufExactlyAt hbfs h (Foreign.castPtr ptr) m 0 -- 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 copyTest + 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 - -> Positive Int -- ^ Prefix length + -> Small Word64 -- ^ Prefix length + -> FS.AbsOffset -> Property -prop_roundtrip_hPutGetBufExactlyAt bs (Positive c) = - BS.length bs >= c ==> +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) @@ -66,9 +75,19 @@ prop_roundtrip_hPutGetBufExactlyAt bs (Positive c) = 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) (fromIntegral c) 0 -- m == c - let writeTest = counterexample "wrote too few bytes" $ c === fromIntegral m - o <- FS.hGetBufSomeAt hbfs h (Foreign.castPtr ptr) (fromIntegral c) 0 -- o == c - let readTest = counterexample "read too few byes" $ c === fromIntegral o - let copyTest = counterexample "input and output bytestring do not match" $ bsCopy === bs - pure $ writeTest .&&. readTest .&&. copyTest + 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/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..ab08ebe 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,9 @@ 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 + | Append !Word64 deriving (Show, Generic) data ClosedHandleState = ClosedHandle { @@ -229,7 +231,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 { @@ -491,7 +493,7 @@ hOpen fp openMode = do filePtr ReadMode = RW True False 0 filePtr (WriteMode _) = RW False True 0 filePtr (ReadWriteMode _) = RW True True 0 - filePtr (AppendMode _) = Append + filePtr (AppendMode _) = Append 0 -- | Mock implementation of 'hClose' hClose :: CanSimFS m => Handle' -> m () @@ -520,6 +522,14 @@ 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 off -> pure (AbsOffset off, hs) + -- | Get bytes from handle -- -- NOTE: Unlike real I/O, we disallow 'hGetSome' on a handle in append mode. @@ -532,7 +542,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 +573,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 +603,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 fromIntegral (BS.length file') else _o )})) where written = toEnum $ BS.length toWrite @@ -674,8 +684,8 @@ hTruncate h sz = , fsErrorStack = prettyCallStack , fsLimitation = True } - (False, Append) -> - return Append + (False, Append off) -> + return (Append off) 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..095eb5e 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]