From ec7c42db80301d038cba6a59067441dcce780615 Mon Sep 17 00:00:00 2001 From: Joris Dral Date: Fri, 3 May 2024 10:19:26 +0200 Subject: [PATCH] Merge HasBufFS into HasFS --- fs-api/CHANGELOG.md | 14 +- fs-api/src/System/FS/API.hs | 110 ++++---- fs-api/src/System/FS/IO.hs | 42 ++-- fs-api/test/Test/System/FS/IO.hs | 26 +- fs-sim/CHANGELOG.md | 14 ++ fs-sim/README.md | 18 +- fs-sim/fs-sim.cabal | 1 - fs-sim/src/System/FS/Sim/Error.hs | 279 +++++++++++++++++++-- fs-sim/src/System/FS/Sim/Prim.hs | 70 ++---- fs-sim/src/System/FS/Sim/Pure.hs | 28 --- fs-sim/src/System/FS/Sim/STM.hs | 45 ++-- fs-sim/test/Test/System/FS/StateMachine.hs | 29 +-- 12 files changed, 420 insertions(+), 256 deletions(-) delete mode 100644 fs-sim/src/System/FS/Sim/Pure.hs diff --git a/fs-api/CHANGELOG.md b/fs-api/CHANGELOG.md index d43902c..10addde 100644 --- a/fs-api/CHANGELOG.md +++ b/fs-api/CHANGELOG.md @@ -6,15 +6,17 @@ * New `primitive ^>=0.9` dependency * Remove orphan `Show` instance for `Foreign.C.Error.Errno`. +* Provide implementations for the new primitives in the `IO` implementation of + `HasFS`. As a result, `ioHasFS` now requires that `PrimState IO ~ PrimState m`. ### Non-breaking -* Add new `HasBufFS` interface for performing I/O using 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`. +* Add new primitives to the `HasFS` interface for performing file I/O with + user-supplied buffers: `hGetBufSome`, `hGetBufSomeAt`, `hPutBufSome`, and + `hPutBufSomeAt`. +* Add compound functions, built from the new primitives in `HasFS`: + `hGetBufExactly`, `hGetBufExactlyAt`, `hPutBufExactly`, and + `hPutBufExactlyAt`. ### Patch diff --git a/fs-api/src/System/FS/API.hs b/fs-api/src/System/FS/API.hs index d4c6147..85cf669 100644 --- a/fs-api/src/System/FS/API.hs +++ b/fs-api/src/System/FS/API.hs @@ -19,9 +19,8 @@ module System.FS.API ( , withFile -- * SomeHasFS , SomeHasFS (..) - -- * HasBufFS + -- * File I\/O with user-supplied buffers , BufferOffset (..) - , HasBufFS (..) , hGetBufExactly , hGetBufExactlyAt , hPutBufExactly @@ -45,6 +44,13 @@ import Util.CallStack Record that abstracts over the filesystem ------------------------------------------------------------------------------} +-- | Abstract interface for performing file I\/O +-- +-- [User-supplied buffers #user-supplied-buffers#]: For functions that require +-- user-supplied buffers (i.e., 'MutableByteArray'), 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. data HasFS m h = HasFS { -- | Debugging: human-readable description of file system state dumpState :: m String @@ -159,6 +165,44 @@ data HasFS m h = HasFS { -- Postcondition: Should throw an error for any @m@ that is not @IO@ -- (or for which we do not have @'MonadIO' m@). , unsafeToFilePath :: FsPath -> m FilePath + + -- === File I\/O with user-supplied buffers + + -- | Like 'hGetSome', but the bytes are read into a user-supplied buffer. + -- See [__User-supplied buffers__](#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__](#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__](#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__](#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 } {------------------------------------------------------------------------------- @@ -189,7 +233,7 @@ data SomeHasFS m where SomeHasFS :: Eq h => HasFS m h -> SomeHasFS m {------------------------------------------------------------------------------- - HasBufFS + File I\/O with user-supplied buffers -------------------------------------------------------------------------------} -- | Absolute offset into a buffer (i.e., 'MutableByteArray'). @@ -201,70 +245,23 @@ data SomeHasFS m where 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 '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 +hGetBufExactly hfs 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 + readBytes <- hGetBufSome hfs h buf currentBufOff c if readBytes == 0 then throwIO FsError { fsErrorType = FsReachedEOF @@ -283,20 +280,19 @@ hGetBufExactly hfs hbfs h buf bufOff c = go c bufOff -- 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 +hGetBufExactlyAt hfs 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 + readBytes <- hGetBufSomeAt hfs h buf currentBufOff c currentOffset if readBytes == 0 then throwIO FsError { fsErrorType = FsReachedEOF @@ -314,7 +310,7 @@ hGetBufExactlyAt hfs hbfs h buf bufOff c off = go c off bufOff -- | Wrapper for 'hPutBufSome' that ensures we write exactly as many bytes as -- requested. hPutBufExactly :: forall m h. (HasCallStack, MonadThrow m) - => HasBufFS m h + => HasFS m h -> Handle h -> MutableByteArray (PrimState m) -- ^ Buffer to write bytes from -> BufferOffset -- ^ Offset into buffer @@ -334,7 +330,7 @@ hPutBufExactly hbfs h buf bufOff c = go c bufOff -- | Wrapper for 'hPutBufSomeAt' that ensures we write exactly as many bytes as -- requested. hPutBufExactlyAt :: forall m h. (HasCallStack, MonadThrow m) - => HasBufFS m h + => HasFS m h -> Handle h -> MutableByteArray (PrimState m) -- ^ Buffer to write bytes from -> BufferOffset -- ^ Offset into buffer diff --git a/fs-api/src/System/FS/IO.hs b/fs-api/src/System/FS/IO.hs index 32fb7c1..4a5b0a5 100644 --- a/fs-api/src/System/FS/IO.hs +++ b/fs-api/src/System/FS/IO.hs @@ -1,12 +1,11 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} --- | IO implementation of the 'HasFS' class +-- | IO implementation of the 'HasFS' interface module System.FS.IO ( -- * IO implementation & monad HandleIO , ioHasFS - , ioHasBufFS ) where import Control.Concurrent.MVar @@ -32,7 +31,7 @@ import qualified System.FS.IO.Internal.Handle as H -- We store the path the handle points to for better error messages type HandleIO = F.FHandle -ioHasFS :: MonadIO m => MountPoint -> HasFS m HandleIO +ioHasFS :: (MonadIO m, PrimState IO ~ PrimState m) => MountPoint -> HasFS m HandleIO ioHasFS mount = HasFS { -- TODO(adn) Might be useful to implement this properly by reading all -- the stuff available at the 'MountPoint'. @@ -77,6 +76,18 @@ ioHasFS mount = HasFS { Dir.renameFile (root fp1) (root fp2) , mkFsErrorPath = fsToFsErrorPath mount , unsafeToFilePath = pure . root + , hGetBufSome = \(Handle h fp) buf bufOff c -> liftIO $ rethrowFsError fp $ + withMutableByteArrayContents buf $ \ptr -> + F.readBuf h (ptr `Foreign.plusPtr` unBufferOffset bufOff) c + , hGetBufSomeAt = \(Handle h fp) buf bufOff c off -> liftIO $ rethrowFsError fp $ + withMutableByteArrayContents buf $ \ptr -> + F.preadBuf h (ptr `Foreign.plusPtr` unBufferOffset bufOff) c (fromIntegral $ unAbsOffset off) + , hPutBufSome = \(Handle h fp) buf bufOff c -> liftIO $ rethrowFsError fp $ + withMutableByteArrayContents buf $ \ptr -> + F.writeBuf h (ptr `Foreign.plusPtr` unBufferOffset bufOff) c + , hPutBufSomeAt = \(Handle h fp) buf bufOff c off -> liftIO $ rethrowFsError fp $ + withMutableByteArrayContents buf $ \ptr -> + F.pwriteBuf h (ptr `Foreign.plusPtr` unBufferOffset bufOff) c (fromIntegral $ unAbsOffset off) } where root :: FsPath -> FilePath @@ -101,28 +112,3 @@ _rethrowFsError mount fp action = do errorPath :: FsErrorPath errorPath = fsToFsErrorPath mount fp - -{------------------------------------------------------------------------------- - HasBufFS --------------------------------------------------------------------------------} - -ioHasBufFS :: - (MonadIO m, PrimState IO ~ PrimState m) - => MountPoint - -> HasBufFS m HandleIO -ioHasBufFS mount = HasBufFS { - hGetBufSome = \(Handle h fp) buf bufOff c -> liftIO $ rethrowFsError fp $ - withMutableByteArrayContents buf $ \ptr -> - F.readBuf h (ptr `Foreign.plusPtr` unBufferOffset bufOff) c - , hGetBufSomeAt = \(Handle h fp) buf bufOff c off -> liftIO $ rethrowFsError fp $ - withMutableByteArrayContents buf $ \ptr -> - F.preadBuf h (ptr `Foreign.plusPtr` unBufferOffset bufOff) c (fromIntegral $ unAbsOffset off) - , hPutBufSome = \(Handle h fp) buf bufOff c -> liftIO $ rethrowFsError fp $ - withMutableByteArrayContents buf $ \ptr -> - F.writeBuf h (ptr `Foreign.plusPtr` unBufferOffset bufOff) c - , hPutBufSomeAt = \(Handle h fp) buf bufOff c off -> liftIO $ rethrowFsError fp $ - withMutableByteArrayContents buf $ \ptr -> - F.pwriteBuf h (ptr `Foreign.plusPtr` unBufferOffset bufOff) c (fromIntegral $ unAbsOffset off) - } - 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 945734e..c75a086 100644 --- a/fs-api/test/Test/System/FS/IO.hs +++ b/fs-api/test/Test/System/FS/IO.hs @@ -45,10 +45,8 @@ toByteString n mba = freezeByteArray mba 0 n >>= \(ByteArray ba) -> pure (SBS.fr -- | 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. +-- 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 @@ -57,15 +55,14 @@ 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 + m <- FS.hPutBufSome hfs 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 + o <- FS.hGetBufSome hfs 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" @@ -82,14 +79,13 @@ 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 + m <- FS.hPutBufSomeAt hfs 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 + o <- FS.hGetBufSomeAt hfs 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" @@ -106,15 +102,14 @@ 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 + m <- FS.hPutBufExactly hfs 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 + o <- FS.hGetBufExactly hfs 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" @@ -132,14 +127,13 @@ 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 + m <- FS.hPutBufExactlyAt hfs 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 + o <- FS.hGetBufExactlyAt hfs 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" diff --git a/fs-sim/CHANGELOG.md b/fs-sim/CHANGELOG.md index 87f6f3e..e27fd54 100644 --- a/fs-sim/CHANGELOG.md +++ b/fs-sim/CHANGELOG.md @@ -11,6 +11,20 @@ * Replace `hGetSomePartial` by `partialiseByteCount`/`partialiseWord64`. * Replace `hPutSomePartial` by `partialiseByteString` * Replace `corrupt` by `corruptByteString` +* Remove `System.FS.Sim.Pure` module. +* Adapt `simHasFS` to the new `HasFS` primitives. This leads to two breaking + changes: + * Add a `PrimMonad m` constraint to `runSimFS`, `simHasFS'` and `simHasFS`. + * Change the `StrictTVar` argument to `simHasFS` to a `StrictTMVar`. +* Adapt `mkSimErrorHasFS` to the new `HasFS` primitives. This leads to two + breaking changes: + * Add a `PrimMonad m` constraint to `runSimErrorFS`, `mkSimErrorHasFS'` and `mkSimErrorHasFS`. + * Change the `StrictTVar` argument to `mkSimErrorHasFS` to a `StrictTMVar`. + +### Non-breaking + +* New constructors for the `Errors` type: `hGetBufSomeE`, `hGetBufSomeAtE`, + `hGetBufSomeE`, and `hPutBufSomeAtE`. ### Patch diff --git a/fs-sim/README.md b/fs-sim/README.md index 1587295..5e4d1c2 100644 --- a/fs-sim/README.md +++ b/fs-sim/README.md @@ -7,22 +7,8 @@ testing purposes, and works well in conjunction with Code that is written using the abstract filesystem interface (`HasFS`) that is provided by the parent package `fs-api` can be run against any of the simulator -implementations provided by `fs-sim`. `fs-sim` currently provides three +implementations provided by `fs-sim`. `fs-sim` currently provides two simulators: -* `System.FS.Sim.Pure` provides a pure implementation. * `System.FS.Sim.STM` provides an implementation that uses STM. -* `System.FS.im.Error` provides an implementation that uses STM, but can also +* `System.FS.Sim.Error` provides an implementation that uses STM, but can also simulate errors and file corruption. - -```haskell -pureHasFS :: HasFS PureSimFS Mock.HandleMock - -simHasFS :: forall m. (MonadSTM m, MonadThrow m) - => StrictTVar m MockFS - -> HasFS m HandleMock - -mkSimErrorHasFS :: forall m. (MonadSTM m, MonadThrow m) - => StrictTVar m MockFS - -> StrictTVar m Errors - -> HasFS m HandleMock -``` diff --git a/fs-sim/fs-sim.cabal b/fs-sim/fs-sim.cabal index dca9da1..08f4ce2 100644 --- a/fs-sim/fs-sim.cabal +++ b/fs-sim/fs-sim.cabal @@ -30,7 +30,6 @@ library System.FS.Sim.Error System.FS.Sim.FsTree System.FS.Sim.MockFS - System.FS.Sim.Pure System.FS.Sim.STM System.FS.Sim.Stream diff --git a/fs-sim/src/System/FS/Sim/Error.hs b/fs-sim/src/System/FS/Sim/Error.hs index b5eda7c..ded8676 100644 --- a/fs-sim/src/System/FS/Sim/Error.hs +++ b/fs-sim/src/System/FS/Sim/Error.hs @@ -39,8 +39,9 @@ module System.FS.Sim.Error ( ) where import Control.Concurrent.Class.MonadSTM.Strict -import Control.Monad (void) +import Control.Monad (unless, void) import Control.Monad.Class.MonadThrow hiding (handle) +import Control.Monad.Primitive import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as C8 @@ -51,6 +52,7 @@ import Data.Foldable (for_) import Data.List (intercalate) import qualified Data.List as List import Data.Maybe (catMaybes) +import Data.Primitive.ByteArray import Data.String (IsString (..)) import Data.Word (Word64) import Foreign.C.Types @@ -66,6 +68,7 @@ import Util.CallStack import System.FS.API +import qualified System.FS.Sim.MockFS as MockFS import System.FS.Sim.MockFS (HandleMock, MockFS) import qualified System.FS.Sim.STM as Sim import qualified System.FS.Sim.Stream as Stream @@ -189,13 +192,63 @@ instance Arbitrary PutCorruption where -- | Apply the 'PutCorruption' to the 'BS.ByteString'. -- --- If the bytestring is subsitituted by corrupt junk, then the output bytestring +-- If the bytestring is substituted by corrupt junk, then the output bytestring -- __might__ be larger than the input bytestring. corruptByteString :: BS.ByteString -> PutCorruption -> BS.ByteString corruptByteString bs pc = case pc of SubstituteWithJunk blob -> getBlob blob PartialWrite partial -> partialiseByteString partial bs +-- | Apply the 'PutCorruption' to a 'MutableByteArray'. +-- +-- This either means that part of the bytes written to file are subsituted with +-- junk, or that only part of the buffer will be written out to disk due to a +-- partial write. +-- +-- With respect to junk substitution, the intent of this function is to model +-- corruption of the bytes written to a file, __not__ corruption of the +-- in-memory buffer itself. As such, we don't corrupt the argument +-- 'MutableByteArray' in place, but instead we return a new 'MutableByteArray' +-- that has the same contents plus some possible corruption. This ensures that +-- the corruption is not visible to other parts of the program that use the same +-- 'MutableByteArray'. Corruption will only be applied to the buffer at the the +-- given 'BufferOffset', up to the requested 'ByteCount'. If there are not +-- enough bytes in the bytearray, then corruption will only apply up until the +-- end of the bytearray. +-- +-- With respect to partial writes, the function returns a new number of +-- requested bytes, which is strictly smaller or equal to the input +-- 'ByteCount'. +-- +-- NOTE: junk substitution and partial writes are mutually exclusive, and so +-- this functions produces only one effect. Either the buffer contents are +-- changed, or the 'ByteCount' is reduced. +corruptBuffer :: + PrimMonad m + => MutableByteArray (PrimState m) + -> BufferOffset + -> ByteCount + -> PutCorruption + -> m (MutableByteArray (PrimState m), ByteCount) +corruptBuffer buf bufOff c pc = do + case pc of + SubstituteWithJunk blob -> do + len <- getSizeofMutableByteArray buf + -- this creates an unpinned byte array containing a copy of @buf@. It should + -- be fine that it is unpinned, because the simulation is fully in-memory. + copy <- freezeByteArray buf 0 len + buf' <- unsafeThawByteArray copy + -- Only corrupt up to the end of the bytearray. + let lenRemaining = len - unBufferOffset bufOff + b <- MockFS.intoBuffer buf' bufOff (BS.take lenRemaining (getBlob blob)) + -- Applying the corruption shouldn't have failed because we've ensured + -- that the bytestring isn't too large to fit into the buffer. + unless b $ error "corruptBuffer: corruption failed. This probably \ + \indicates a bug in the fs-sim library." + pure (buf', c) + PartialWrite partial -> + pure (buf, partialiseByteCount partial c) + {------------------------------------------------------------------------------- Simulated errors -------------------------------------------------------------------------------} @@ -231,6 +284,11 @@ data Errors = Errors , removeDirectoryRecursiveE :: ErrorStream , removeFileE :: ErrorStream , renameFileE :: ErrorStream + -- File I\/O with user-supplied buffers + , hGetBufSomeE :: ErrorStreamGetSome + , hGetBufSomeAtE :: ErrorStreamGetSome + , hPutBufSomeE :: ErrorStreamPutSome + , hPutBufSomeAtE :: ErrorStreamPutSome } $(pure []) -- https://blog.monadfix.com/th-groups @@ -254,6 +312,9 @@ allNull $(fields 'Errors) = and [ , Stream.null removeDirectoryRecursiveE , Stream.null removeFileE , Stream.null renameFileE + -- File I\/O with user-supplied buffers + , Stream.null hGetBufSomeE, Stream.null hGetBufSomeAtE + , Stream.null hPutBufSomeE, Stream.null hPutBufSomeAtE ] instance Show Errors where @@ -284,6 +345,11 @@ instance Show Errors where , s "removeDirectoryRecursiveE" removeDirectoryRecursiveE , s "removeFileE" removeFileE , s "renameFileE" renameFileE + -- File I\/O with user-supplied buffers + , s "hGetBufSomeE" hGetBufSomeE + , s "hGetBufSomeAtE" hGetBufSomeAtE + , s "hPutBufSomeE" hPutBufSomeE + , s "hPutBufSomeAtE" hPutBufSomeAtE ] emptyErrors :: Errors @@ -310,6 +376,11 @@ simpleErrors es = Errors , removeDirectoryRecursiveE = es , removeFileE = es , renameFileE = es + -- File I\/O with user-supplied buffers + , hGetBufSomeE = Left <$> es + , hGetBufSomeAtE = Left <$> es + , hPutBufSomeE = Left . (, Nothing) <$> es + , hPutBufSomeAtE = Left . (, Nothing) <$> es } -- | Generator for 'Errors' that allows some things to be disabled. @@ -320,9 +391,7 @@ genErrors :: Bool -- ^ 'True' -> generate partial writes -> Bool -- ^ 'True' -> generate 'SubstituteWithJunk' corruptions -> Gen Errors genErrors genPartialWrites genSubstituteWithJunk = do - let streamGen l = Stream.genInfinite . Stream.genMaybe' l . QC.elements - streamGen' l = Stream.genInfinite . Stream.genMaybe' l . QC.frequency - -- TODO which errors are possible for these operations below (that + let -- TODO which errors are possible for these operations below (that -- have dummy for now)? dummy = streamGen 2 [ FsInsufficientPermissions ] dumpStateE <- dummy @@ -336,20 +405,9 @@ genErrors genPartialWrites genSubstituteWithJunk = do , FsResourceAlreadyInUse, FsResourceAlreadyExist , FsInsufficientPermissions, FsTooManyOpenFiles ] hSeekE <- streamGen 3 [ FsReachedEOF ] - hGetSomeE <- streamGen' 20 - [ (1, return $ Left FsReachedEOF) - , (3, Right <$> arbitrary) ] - hGetSomeAtE <- streamGen' 20 - [ (1, return $ Left FsReachedEOF) - , (3, Right <$> arbitrary) ] - hPutSomeE <- streamGen' 5 - [ (1, Left . (FsDeviceFull, ) <$> QC.frequency - [ (2, return Nothing) - , (1, Just . PartialWrite <$> arbitrary) - , (if genSubstituteWithJunk then 1 else 0, - Just . SubstituteWithJunk <$> arbitrary) - ]) - , (if genPartialWrites then 3 else 0, Right <$> arbitrary) ] + hGetSomeE <- commonGetErrors + hGetSomeAtE <- commonGetErrors + hPutSomeE <- commonPutErrors hGetSizeE <- streamGen 2 [ FsResourceDoesNotExist ] createDirectoryE <- streamGen 3 [ FsInsufficientPermissions, FsResourceInappropriateType @@ -369,7 +427,28 @@ genErrors genPartialWrites genSubstituteWithJunk = do renameFileE <- streamGen 3 [ FsInsufficientPermissions, FsResourceAlreadyInUse , FsResourceDoesNotExist, FsResourceInappropriateType ] + -- File I\/O with user-supplied buffers + hGetBufSomeE <- commonGetErrors + hGetBufSomeAtE <- commonGetErrors + hPutBufSomeE <- commonPutErrors + hPutBufSomeAtE <- commonPutErrors return Errors {..} + where + streamGen l = Stream.genInfinite . Stream.genMaybe' l . QC.elements + streamGen' l = Stream.genInfinite . Stream.genMaybe' l . QC.frequency + + commonGetErrors = streamGen' 20 + [ (1, return $ Left FsReachedEOF) + , (3, Right <$> arbitrary) ] + + commonPutErrors = streamGen' 5 + [ (1, Left . (FsDeviceFull, ) <$> QC.frequency + [ (2, return Nothing) + , (1, Just . PartialWrite <$> arbitrary) + , (if genSubstituteWithJunk then 1 else 0, + Just . SubstituteWithJunk <$> arbitrary) + ]) + , (if genPartialWrites then 3 else 0, Right <$> arbitrary) ] instance Arbitrary Errors where arbitrary = genErrors True True @@ -392,6 +471,11 @@ instance Arbitrary Errors where , (\s' -> err { removeDirectoryRecursiveE = s' }) <$> Stream.shrinkStream removeDirectoryRecursiveE , (\s' -> err { removeFileE = s' }) <$> Stream.shrinkStream removeFileE , (\s' -> err { renameFileE = s' }) <$> Stream.shrinkStream renameFileE + -- File I\/O with user-supplied buffers + , (\s' -> err { hGetBufSomeE = s' }) <$> Stream.shrinkStream hGetBufSomeE + , (\s' -> err { hGetBufSomeAtE = s' }) <$> Stream.shrinkStream hGetBufSomeAtE + , (\s' -> err { hPutBufSomeE = s' }) <$> Stream.shrinkStream hPutBufSomeE + , (\s' -> err { hPutBufSomeAtE = s' }) <$> Stream.shrinkStream hPutBufSomeAtE ] {------------------------------------------------------------------------------- @@ -399,23 +483,23 @@ instance Arbitrary Errors where -------------------------------------------------------------------------------} -- | Alternative to 'mkSimErrorHasFS' that creates 'TVar's internally. -mkSimErrorHasFS' :: (MonadSTM m, MonadThrow m) +mkSimErrorHasFS' :: (MonadSTM m, MonadThrow m, PrimMonad m) => MockFS -> Errors -> m (HasFS m HandleMock) mkSimErrorHasFS' mockFS errs = - mkSimErrorHasFS <$> newTVarIO mockFS <*> newTVarIO errs + mkSimErrorHasFS <$> newTMVarIO mockFS <*> newTVarIO errs -- | Introduce possibility of errors -- -- TODO: Lenses would be nice for the setters -mkSimErrorHasFS :: forall m. (MonadSTM m, MonadThrow m) - => StrictTVar m MockFS +mkSimErrorHasFS :: forall m. (MonadSTM m, MonadThrow m, PrimMonad m) + => StrictTMVar m MockFS -> StrictTVar m Errors -> HasFS m HandleMock mkSimErrorHasFS fsVar errorsVar = case Sim.simHasFS fsVar of - HasFS{..} -> HasFS{ + hfs@HasFS{..} -> HasFS{ dumpState = withErr errorsVar (mkFsPath [""]) dumpState "dumpState" dumpStateE (\e es -> es { dumpStateE = e }) @@ -465,20 +549,25 @@ mkSimErrorHasFS fsVar errorsVar = renameFileE (\e es -> es { renameFileE = e }) , mkFsErrorPath = fsToFsErrorPathUnmounted , unsafeToFilePath = error "mkSimErrorHasFS:unsafeToFilePath" + -- File I\/O with user-supplied buffers + , hGetBufSome = hGetBufSomeWithErr errorsVar hfs + , hGetBufSomeAt = hGetBufSomeAtWithErr errorsVar hfs + , hPutBufSome = hPutBufSomeWithErr errorsVar hfs + , hPutBufSomeAt = hPutBufSomeAtWithErr errorsVar hfs } -- | Runs a computation provided an 'Errors' and an initial -- 'MockFS', producing a result and the final state of the filesystem. -runSimErrorFS :: (MonadSTM m, MonadThrow m) +runSimErrorFS :: (MonadSTM m, MonadThrow m, PrimMonad m) => MockFS -> Errors -> (StrictTVar m Errors -> HasFS m HandleMock -> m a) -> m (a, MockFS) runSimErrorFS mockFS errors action = do - fsVar <- newTVarIO mockFS + fsVar <- newTMVarIO mockFS errorsVar <- newTVarIO errors a <- action errorsVar $ mkSimErrorHasFS fsVar errorsVar - fs' <- readTVarIO fsVar + fs' <- atomically $ takeTMVar fsVar return (a, fs') -- | Execute the next action using the given 'Errors'. After the action is @@ -615,3 +704,139 @@ hPutSome' errorsVar hPutSomeWrapped handle bs = } Just (Right partial) -> hPutSomeWrapped handle (partialiseByteString partial bs) + +{------------------------------------------------------------------------------- + File I\/O with user-supplied buffers +-------------------------------------------------------------------------------} + +-- | Short-hand for the type of 'hGetBufSome' +type HGetBufSome m = + Handle HandleMock + -> MutableByteArray (PrimState m) + -> BufferOffset + -> ByteCount + -> m ByteCount + +-- | Execute the wrapped 'hGetBufSome', throw an error, or simulate a partial +-- read, depending on the corresponding 'ErrorStreamGetSome' (see 'nextError'). +hGetBufSomeWithErr :: + (MonadSTM m, MonadThrow m, HasCallStack) + => StrictTVar m Errors + -> HasFS m HandleMock + -> HGetBufSome m +hGetBufSomeWithErr errorsVar hfs h buf bufOff c = + next errorsVar hGetBufSomeE (\e es -> es { hGetBufSomeE = e }) >>= \case + Nothing -> hGetBufSome hfs h buf bufOff c + Just (Left errType) -> throwIO FsError + { fsErrorType = errType + , fsErrorPath = fsToFsErrorPathUnmounted $ handlePath h + , fsErrorString = "simulated error: hGetBufSome" + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = False + } + Just (Right partial) -> + hGetBufSome hfs h buf bufOff (partialiseByteCount partial c) + +-- | Short-hand for the type of 'hGetBufSomeAt' +type HGetBufSomeAt m = + Handle HandleMock + -> MutableByteArray (PrimState m) + -> BufferOffset + -> ByteCount + -> AbsOffset + -> m ByteCount + +-- | Execute the wrapped 'hGetBufSomeAt', throw an error, or simulate a partial +-- read, depending on the corresponding 'ErrorStreamGetSome' (see 'nextError'). +hGetBufSomeAtWithErr :: + (MonadSTM m, MonadThrow m, HasCallStack) + => StrictTVar m Errors + -> HasFS m HandleMock + -> HGetBufSomeAt m +hGetBufSomeAtWithErr errorsVar hfs h buf bufOff c off = + next errorsVar hGetBufSomeAtE (\e es -> es { hGetBufSomeAtE = e }) >>= \case + Nothing -> hGetBufSomeAt hfs h buf bufOff c off + Just (Left errType) -> throwIO FsError + { fsErrorType = errType + , fsErrorPath = fsToFsErrorPathUnmounted $ handlePath h + , fsErrorString = "simulated error: hGetBufSomeAt" + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = False + } + Just (Right partial) -> + hGetBufSomeAt hfs h buf bufOff (partialiseByteCount partial c) off + +-- | Short-hand for the type of 'hPutBufSome' +type HPutBufSome m = + Handle HandleMock + -> MutableByteArray (PrimState m) + -> BufferOffset + -> ByteCount + -> m ByteCount + +-- | Execute the wrapped 'hPutBufSome', throw an error and apply possible +-- corruption to the blob to write, or simulate a partial write, depending on +-- the corresponding 'ErrorStreamPutSome' (see 'nextError'). +hPutBufSomeWithErr :: + (MonadSTM m, MonadThrow m, PrimMonad m, HasCallStack) + => StrictTVar m Errors + -> HasFS m HandleMock + -> HPutBufSome m +hPutBufSomeWithErr errorsVar hfs h buf bufOff c = + next errorsVar hPutBufSomeE (\e es -> es { hPutBufSomeE = e }) >>= \case + Nothing -> hPutBufSome hfs h buf bufOff c + Just (Left (errType, mbCorr)) -> do + for_ mbCorr $ \corr -> do + (buf', c') <- corruptBuffer buf bufOff c corr + void $ hPutBufSome hfs h buf' bufOff c' + throwIO FsError + { fsErrorType = errType + , fsErrorPath = fsToFsErrorPathUnmounted $ handlePath h + , fsErrorString = "simulated error: hPutSome" <> case mbCorr of + Nothing -> "" + Just corr -> " with corruption: " <> show corr + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = False + } + Just (Right partial) -> + hPutBufSome hfs h buf bufOff (partialiseByteCount partial c) + +-- | Short-hand for the type of 'hPutBufSomeAt' +type HPutBufSomeAt m = + Handle HandleMock + -> MutableByteArray (PrimState m) + -> BufferOffset + -> ByteCount + -> AbsOffset + -> m ByteCount + +-- | Execute the wrapped 'hPutBufSomeAt', throw an error and apply possible +-- corruption to the blob to write, or simulate a partial write, depending on +-- the corresponding 'ErrorStreamPutSome' (see 'nextError'). +hPutBufSomeAtWithErr :: + (MonadSTM m, MonadThrow m, PrimMonad m, HasCallStack) + => StrictTVar m Errors + -> HasFS m HandleMock + -> HPutBufSomeAt m +hPutBufSomeAtWithErr errorsVar hfs h buf bufOff c off = + next errorsVar hPutBufSomeAtE (\e es -> es { hPutBufSomeAtE = e }) >>= \case + Nothing -> hPutBufSomeAt hfs h buf bufOff c off + Just (Left (errType, mbCorr)) -> do + for_ mbCorr $ \corr -> do + (buf', c') <- corruptBuffer buf bufOff c corr + void $ hPutBufSomeAt hfs h buf' bufOff c' off + throwIO FsError + { fsErrorType = errType + , fsErrorPath = fsToFsErrorPathUnmounted $ handlePath h + , fsErrorString = "simulated error: hPutSome" <> case mbCorr of + Nothing -> "" + Just corr -> " with corruption: " <> show corr + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = False + } + Just (Right partial) -> + hPutBufSomeAt hfs h buf bufOff (partialiseByteCount partial c) off diff --git a/fs-sim/src/System/FS/Sim/Prim.hs b/fs-sim/src/System/FS/Sim/Prim.hs index e387a1a..23c2988 100644 --- a/fs-sim/src/System/FS/Sim/Prim.hs +++ b/fs-sim/src/System/FS/Sim/Prim.hs @@ -3,22 +3,19 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralisedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE UndecidableInstances #-} +-- | Mocked, monad transformer-based implementation of the 'HasFS' interface. module System.FS.Sim.Prim ( FSSimT , runFSSimT - , FSSim - , runFSSim - , pureHasFS - , primHasFS - , primHasBufFS + , primHasMockFS ) where import Control.Monad.Except -import Control.Monad.Identity (Identity (..)) import Control.Monad.Primitive import Control.Monad.State @@ -27,6 +24,8 @@ import System.FS.API import qualified System.FS.Sim.MockFS as Mock import System.FS.Sim.MockFS (MockFS) +-- | Monad transformer that extends a monad @m@ with pure features: (i) 'MockFS' +-- state, and (ii) throwing/catching 'FsError's. newtype FSSimT m a = PureSimFS { unFSSimT :: StateT MockFS (ExceptT FsError m) a } @@ -36,37 +35,21 @@ newtype FSSimT m a = PureSimFS { runFSSimT :: FSSimT m a -> MockFS -> m (Either FsError (a, MockFS)) runFSSimT act !st = runExceptT $ flip runStateT st $ unFSSimT act -type FSSim = FSSimT Identity - -runFSSim :: FSSim a -> MockFS -> Either FsError (a, MockFS) -runFSSim act !st = runIdentity $ runFSSimT act st - -pureHasFS :: HasFS FSSim Mock.HandleMock -pureHasFS = HasFS { - dumpState = Mock.dumpState - , hOpen = Mock.hOpen - , hClose = Mock.hClose - , hIsOpen = Mock.hIsOpen - , hSeek = Mock.hSeek - , hGetSome = Mock.hGetSome - , hGetSomeAt = Mock.hGetSomeAt - , hPutSome = Mock.hPutSome - , hTruncate = Mock.hTruncate - , hGetSize = Mock.hGetSize - , createDirectory = Mock.createDirectory - , createDirectoryIfMissing = Mock.createDirectoryIfMissing - , listDirectory = Mock.listDirectory - , doesDirectoryExist = Mock.doesDirectoryExist - , doesFileExist = Mock.doesFileExist - , removeDirectoryRecursive = Mock.removeDirectoryRecursive - , removeFile = Mock.removeFile - , renameFile = Mock.renameFile - , mkFsErrorPath = fsToFsErrorPathUnmounted - , unsafeToFilePath = \_ -> error "pureHasFS:unsafeToFilePath" - } - -primHasFS :: PrimMonad m => HasFS (FSSimT m) Mock.HandleMock -primHasFS = HasFS { +-- | Mocked, monad transformer-based implementation of the 'HasFS' interface. +-- +-- This implementation is pure when running in a monad @m@ that is +-- 'Control.Monad.ST.ST'. +-- +-- This implementation runs in a primitive monad @m@ extended with an 'FSSimT' +-- monad transformer. It is recommended to use 'System.FS.Sim.STM.simHasFS' or +-- 'System.FS.Sim.Error.mkSimErrorHasFS' instead because they hide the monad +-- transformer. The caveat is that @m@ should be IO-like. +primHasMockFS :: PrimMonad m => HasFS (FSSimT m) Mock.HandleMock +-- An alternative design could have fixed this implementation to +-- 'Control.Monad.ST.ST', and used 'Control.Monad.Class.MonadST.stToIO' to +-- convert between a pure and 'IO' version. However, it's simpler to just +-- overload this function. +primHasMockFS = HasFS { dumpState = Mock.dumpState , hOpen = Mock.hOpen , hClose = Mock.hClose @@ -87,12 +70,9 @@ primHasFS = HasFS { , renameFile = Mock.renameFile , mkFsErrorPath = fsToFsErrorPathUnmounted , unsafeToFilePath = \_ -> error "pureHasFS:unsafeToFilePath" - } - -primHasBufFS :: PrimMonad m => HasBufFS (FSSimT m) Mock.HandleMock -primHasBufFS = HasBufFS { - hGetBufSome = Mock.hGetBufSome - , hGetBufSomeAt = Mock.hGetBufSomeAt - , hPutBufSome = Mock.hPutBufSome - , hPutBufSomeAt = Mock.hPutBufSomeAt + -- File I\/O with user-supplied buffers + , hGetBufSome = Mock.hGetBufSome + , hGetBufSomeAt = Mock.hGetBufSomeAt + , hPutBufSome = Mock.hPutBufSome + , hPutBufSomeAt = Mock.hPutBufSomeAt } diff --git a/fs-sim/src/System/FS/Sim/Pure.hs b/fs-sim/src/System/FS/Sim/Pure.hs deleted file mode 100644 index b805aeb..0000000 --- a/fs-sim/src/System/FS/Sim/Pure.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -module System.FS.Sim.Pure ( - PureSimFS - -- opaque - , pureHasFS - , runPureSimFS - ) where - -import Control.Monad.Except -import Control.Monad.State -import Data.Coerce (coerce) - -import System.FS.API - -import qualified System.FS.Sim.MockFS as Mock -import System.FS.Sim.MockFS (MockFS) -import qualified System.FS.Sim.Prim as Prim - --- | Monad useful for running 'HasFS' in pure code -newtype PureSimFS a = PureSimFS (Prim.FSSim a) - deriving (Functor, Applicative, Monad, MonadState MockFS, MonadError FsError) - -runPureSimFS :: PureSimFS a -> MockFS -> Either FsError (a, MockFS) -runPureSimFS (PureSimFS act) !st = Prim.runFSSim act st - -pureHasFS :: HasFS PureSimFS Mock.HandleMock -pureHasFS = coerce Prim.pureHasFS diff --git a/fs-sim/src/System/FS/Sim/STM.hs b/fs-sim/src/System/FS/Sim/STM.hs index 15c8359..e83c699 100644 --- a/fs-sim/src/System/FS/Sim/STM.hs +++ b/fs-sim/src/System/FS/Sim/STM.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -10,6 +11,7 @@ module System.FS.Sim.STM ( import Control.Concurrent.Class.MonadSTM.Strict import Control.Monad.Class.MonadThrow +import Control.Monad.Primitive import System.FS.API @@ -24,25 +26,25 @@ import System.FS.Sim.Prim --- | Runs a computation provided an initial 'MockFS', producing a --- result, the final state of the filesystem and a sequence of actions occurred --- in the filesystem. -runSimFS :: (MonadSTM m, MonadThrow m) +runSimFS :: (MonadSTM m, MonadThrow m, PrimMonad m) => MockFS -> (HasFS m HandleMock -> m a) -> m (a, MockFS) runSimFS fs act = do - var <- newTVarIO fs + var <- newTMVarIO fs a <- act (simHasFS var) - fs' <- readTVarIO var + fs' <- atomically $ takeTMVar var return (a, fs') -- | Alternative to 'simHasFS' that creates 'TVar's internally. -simHasFS' :: (MonadSTM m, MonadThrow m) +simHasFS' :: (MonadSTM m, MonadThrow m, PrimMonad m) => MockFS -> m (HasFS m HandleMock) -simHasFS' mockFS = simHasFS <$> newTVarIO mockFS +simHasFS' mockFS = simHasFS <$> newTMVarIO mockFS -- | Equip @m@ with a @HasFs@ instance using the mock file system -simHasFS :: forall m. (MonadSTM m, MonadThrow m) - => StrictTVar m MockFS +simHasFS :: forall m. (MonadSTM m, MonadThrow m, PrimMonad m) + => StrictTMVar m MockFS -> HasFS m HandleMock simHasFS var = HasFS { dumpState = sim Mock.dumpState @@ -65,21 +67,32 @@ simHasFS var = HasFS { , renameFile = sim .: Mock.renameFile , mkFsErrorPath = fsToFsErrorPathUnmounted , unsafeToFilePath = \_ -> error "simHasFS:unsafeToFilePath" + -- File I\/O with user-supplied buffers + , hGetBufSome = sim ...: Mock.hGetBufSome + , hGetBufSomeAt = sim ....: Mock.hGetBufSomeAt + , hPutBufSome = sim ...: Mock.hPutBufSome + , hPutBufSomeAt = sim ....: Mock.hPutBufSomeAt } where - sim :: FSSim a -> m a + sim :: FSSimT m a -> m a sim m = do - eOrA <- atomically $ do - st <- readTVar var - case runFSSim m st of - Left e -> return $ Left e - Right (a, st') -> do - writeTVar var st' - return $ Right a - either throwIO return eOrA + st <- atomically $ takeTMVar var + runFSSimT m st >>= \case + Left e -> do + atomically $ putTMVar var st + throwIO e + Right (a, st') -> do + atomically $ putTMVar var st' + pure a (.:) :: (y -> z) -> (x0 -> x1 -> y) -> (x0 -> x1 -> z) (f .: g) x0 x1 = f (g x0 x1) (..:) :: (y -> z) -> (x0 -> x1 -> x2 -> y) -> (x0 -> x1 -> x2 -> z) (f ..: g) x0 x1 x2 = f (g x0 x1 x2) + + (...:) :: (y -> z) -> (x0 -> x1 -> x2 -> x3 -> y) -> (x0 -> x1 -> x2 -> x3 -> z) + (f ...: g) x0 x1 x2 x3 = f (g x0 x1 x2 x3) + + (....:) :: (y -> z) -> (x0 -> x1 -> x2 -> x3 -> x4 -> y) -> (x0 -> x1 -> x2 -> x3 -> x4 -> z) + (f ....: g) x0 x1 x2 x3 x4 = f (g x0 x1 x2 x3 x4) diff --git a/fs-sim/test/Test/System/FS/StateMachine.hs b/fs-sim/test/Test/System/FS/StateMachine.hs index eeacfa2..9dda041 100644 --- a/fs-sim/test/Test/System/FS/StateMachine.hs +++ b/fs-sim/test/Test/System/FS/StateMachine.hs @@ -193,10 +193,9 @@ data Success fp h = -- | Successful semantics run :: forall m h. (PrimMonad m, HasCallStack) => HasFS m h - -> HasBufFS m h -> Cmd FsPath (Handle h) -> m (Success FsPath (Handle h)) -run hasFS@HasFS{..} hasBufFS = go +run hasFS@HasFS{..} = go where go :: Cmd FsPath (Handle h) -> m (Success FsPath (Handle h)) go (Open pe mode) = @@ -214,11 +213,11 @@ run hasFS@HasFS{..} hasBufFS = go -- partial reads/writes, see #502. go (Get h n ) = ByteString <$> hGetSomeChecked hasFS h n go (GetAt h n o ) = ByteString <$> hGetSomeAtChecked hasFS h n o - go (GetBuf h n ) = uncurry BCBS <$> hGetBufSomeChecked hasFS hasBufFS h n - go (GetBufAt h n o ) = uncurry BCBS <$> hGetBufSomeAtChecked hasFS hasBufFS h n o + go (GetBuf h n ) = uncurry BCBS <$> hGetBufSomeChecked hasFS h n + go (GetBufAt h n o ) = uncurry BCBS <$> hGetBufSomeAtChecked hasFS h n o go (Put h bs ) = Word64 <$> hPutSomeChecked hasFS h bs - go (PutBuf h bs n ) = ByteCount <$> hPutBufSomeChecked hasBufFS h bs n - go (PutBufAt h bs n o ) = ByteCount <$> hPutBufSomeAtChecked hasBufFS h bs n o + go (PutBuf h bs n ) = ByteCount <$> hPutBufSomeChecked hasFS h bs n + go (PutBufAt h bs n o ) = ByteCount <$> hPutBufSomeAtChecked hasFS h bs n o go (Truncate h sz ) = Unit <$> hTruncate h sz go (GetSize h ) = Word64 <$> hGetSize h go (ListDirectory pe ) = withPE pe (const Strings) $ listDirectory @@ -320,9 +319,8 @@ hPutSomeChecked HasFS{..} h bytes = do hGetBufSomeChecked :: (HasCallStack, PrimMonad m) => HasFS m h - -> HasBufFS m h -> Handle h -> ByteCount -> m (ByteCount, ByteString) -hGetBufSomeChecked HasFS{..} HasBufFS{..} h n = do +hGetBufSomeChecked HasFS{..} h n = do allocaMutableByteArray (fromIntegral n) $ \buf -> do n' <- hGetBufSome h buf 0 n bs <- fromJust <$> Mock.fromBuffer buf 0 n' @@ -336,9 +334,8 @@ hGetBufSomeChecked HasFS{..} HasBufFS{..} h n = do hGetBufSomeAtChecked :: (HasCallStack, PrimMonad m) => HasFS m h - -> HasBufFS m h -> Handle h -> ByteCount -> AbsOffset -> m (ByteCount, ByteString) -hGetBufSomeAtChecked HasFS{..} HasBufFS{..} h n o = do +hGetBufSomeAtChecked HasFS{..} h n o = do allocaMutableByteArray (fromIntegral n) $ \buf -> do n' <- hGetBufSomeAt h buf 0 n o bs <- fromJust <$> Mock.fromBuffer buf 0 n' @@ -351,9 +348,9 @@ hGetBufSomeAtChecked HasFS{..} HasBufFS{..} h n o = do pure (n', bs) hPutBufSomeChecked :: (HasCallStack, PrimMonad m) - => HasBufFS m h + => HasFS m h -> Handle h -> ByteString -> ByteCount -> m ByteCount -hPutBufSomeChecked HasBufFS{..} h bs n = +hPutBufSomeChecked HasFS{..} h bs n = allocaMutableByteArray (min (fromIntegral n) (BS.length bs)) $ \buf -> do void $ Mock.intoBuffer buf 0 (BS.take (fromIntegral n) bs) n' <- hPutBufSome h buf 0 n @@ -362,9 +359,9 @@ hPutBufSomeChecked HasBufFS{..} h bs n = else return n hPutBufSomeAtChecked :: (HasCallStack, PrimMonad m) - => HasBufFS m h + => HasFS m h -> Handle h -> ByteString -> ByteCount -> AbsOffset -> m ByteCount -hPutBufSomeAtChecked HasBufFS{..} h bs n o = +hPutBufSomeAtChecked HasFS{..} h bs n o = allocaMutableByteArray (min (fromIntegral n) (BS.length bs)) $ \buf -> do void $ Mock.intoBuffer buf 0 (BS.take (fromIntegral n) bs) n' <- hPutBufSomeAt h buf 0 n o @@ -392,7 +389,7 @@ instance (Eq fp, Eq h) => Eq (Resp fp h) where runPure :: Cmd FsPath (Handle HandleMock) -> MockFS -> (Resp FsPath (Handle HandleMock), MockFS) runPure cmd mockFS = - aux $ runST $ runFSSimT (run primHasFS primHasBufFS cmd) mockFS + aux $ runST $ runFSSimT (run primHasMockFS cmd) mockFS where aux :: Either FsError (Success FsPath (Handle HandleMock), MockFS) -> (Resp FsPath (Handle HandleMock), MockFS) @@ -401,7 +398,7 @@ runPure cmd mockFS = runIO :: MountPoint -> Cmd FsPath (Handle HandleIO) -> IO (Resp FsPath (Handle HandleIO)) -runIO mount cmd = Resp <$> E.try (run (ioHasFS mount) (ioHasBufFS mount) cmd) +runIO mount cmd = Resp <$> E.try (run (ioHasFS mount) cmd) {------------------------------------------------------------------------------- Bitraversable instances