From 62d22c9e16583358712999771e05615923d5f6f7 Mon Sep 17 00:00:00 2001 From: Joris Dral Date: Tue, 23 Apr 2024 13:37:08 +0200 Subject: [PATCH] Simulation and QSM tests for `HasBufFS` The simulated version of `HasBufFS` is not yet exposed yet from the public API. This will happen in a later PR. --- fs-sim/CHANGELOG.md | 5 +- fs-sim/fs-sim.cabal | 11 +- fs-sim/src/System/FS/Sim/MockFS.hs | 282 ++++++++++++++++++--- fs-sim/src/System/FS/Sim/Prim.hs | 98 +++++++ fs-sim/src/System/FS/Sim/Pure.hs | 29 +-- fs-sim/src/System/FS/Sim/STM.hs | 8 +- fs-sim/test/Test/System/FS/StateMachine.hs | 146 ++++++++++- 7 files changed, 508 insertions(+), 71 deletions(-) create mode 100644 fs-sim/src/System/FS/Sim/Prim.hs diff --git a/fs-sim/CHANGELOG.md b/fs-sim/CHANGELOG.md index 29889d9..34e901f 100644 --- a/fs-sim/CHANGELOG.md +++ b/fs-sim/CHANGELOG.md @@ -1,8 +1,11 @@ # Revision history for fs-sim -## next release -- ????-??-?? +## next version -- ????-??-?? + +### Breaking * Orphan `Show` instance for `Foreign.C.Error.Errno` removed by `fs-api`. +* New `primitive ^>=0.9` dependency ## 0.2.1.1 -- 2023-10-30 diff --git a/fs-sim/fs-sim.cabal b/fs-sim/fs-sim.cabal index b530c06..d3dedd1 100644 --- a/fs-sim/fs-sim.cabal +++ b/fs-sim/fs-sim.cabal @@ -34,6 +34,7 @@ library System.FS.Sim.STM System.FS.Sim.Stream + other-modules: System.FS.Sim.Prim default-language: Haskell2010 build-depends: , base >=4.14 && <4.20 @@ -43,6 +44,7 @@ library , fs-api ^>=0.2 , io-classes >=0.3 && <1.5 , mtl + , primitive ^>=0.9 , QuickCheck , strict-stm >=0.3 && <1.5 , text >=1.2 && <2.2 @@ -54,9 +56,12 @@ library test-suite fs-sim-test type: exitcode-stdio-1.0 - hs-source-dirs: test + hs-source-dirs: test src main-is: Main.hs other-modules: + System.FS.Sim.FsTree + System.FS.Sim.MockFS + System.FS.Sim.Prim Test.System.FS.Sim.FsTree Test.System.FS.StateMachine Test.Util.RefEnv @@ -64,13 +69,15 @@ test-suite fs-sim-test default-language: Haskell2010 build-depends: , base + , base16-bytestring , bifunctors , bytestring , containers , fs-api - , fs-sim , generics-sop + , mtl , pretty-show + , primitive , QuickCheck , quickcheck-state-machine >=0.7.2 && <0.8 , random diff --git a/fs-sim/src/System/FS/Sim/MockFS.hs b/fs-sim/src/System/FS/Sim/MockFS.hs index 58199ac..e39a7ef 100644 --- a/fs-sim/src/System/FS/Sim/MockFS.hs +++ b/fs-sim/src/System/FS/Sim/MockFS.hs @@ -1,5 +1,4 @@ {-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} @@ -9,6 +8,7 @@ {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} -- | Mock file system implementation @@ -55,11 +55,19 @@ module System.FS.Sim.MockFS ( -- * opaque , HandleMock , MockFS + -- * HasBufFS + , fromBuffer + , intoBuffer + , hGetBufSome + , hGetBufSomeAt + , hPutBufSome + , hPutBufSomeAt ) where -import Control.Monad (unless, void, when) +import Control.Monad (forM, forM_, unless, void, when) import Control.Monad.Except (MonadError, throwError) -import Control.Monad.State (MonadState, get, gets, put) +import Control.Monad.Primitive (PrimMonad (..)) +import Control.Monad.State.Strict (MonadState, get, gets, put) import Data.Bifunctor import Data.ByteString (ByteString) import qualified Data.ByteString as BS @@ -68,12 +76,16 @@ import Data.Int (Int64) import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import Data.Maybe (mapMaybe) +import qualified Data.Primitive as P +import Data.Primitive.ByteArray import Data.Set (Set) import qualified Data.Set as S import qualified Data.Text as Text -import Data.Word (Word64) +import Data.Word (Word64, Word8) import GHC.Generics (Generic) +import System.Posix.Types (ByteCount) +import System.FS.API (BufferOffset (..)) import System.FS.API.Types import Util.CallStack @@ -610,36 +622,6 @@ hPutSome h toWrite = , fsLimitation = False } - -- Given - -- - -- > A B C - -- > |-----------|-------.-----------| - -- > n . - -- > . - -- > D . - -- > |-------| - -- - -- return A <> D <> C - replace :: Word64 -> ByteString -> ByteString -> ByteString - replace n d abc = a <> d <> c - where - (a, c) = snip (fromIntegral n) (BS.length d) abc - - -- Given - -- - -- > A B C - -- > |-----------|-------|-----------| - -- > n - -- > <-------> - -- > m - -- - -- return (A, C) - snip :: Int -> Int -> ByteString -> (ByteString, ByteString) - snip n m bs = (a, c) - where - (a, bc) = BS.splitAt n bs - c = BS.drop m bc - -- | Truncate a file -- -- NOTE: Differences from Posix: @@ -905,3 +887,235 @@ sign a | a < 0 = Negative (negate a) sign64 :: Int64 -> Sign Word64 sign64 = fmap fromIntegral . sign + +{------------------------------------------------------------------------------- + ByteString +-------------------------------------------------------------------------------} + +-- Given +-- +-- > A B C +-- > |-----------|-------.-----------| +-- > n . +-- > . +-- > D . +-- > |-------| +-- +-- return A <> D <> C +replace :: Word64 -> ByteString -> ByteString -> ByteString +replace n d abc = a <> d <> c + where + (a, c) = snip (fromIntegral n) (BS.length d) abc + +-- Given +-- +-- > A B C +-- > |-----------|-------|-----------| +-- > n +-- > <-------> +-- > m +-- +-- return (A, C) +snip :: Int -> Int -> ByteString -> (ByteString, ByteString) +snip n m bs = (a, c) + where + (a, bc) = BS.splitAt n bs + c = BS.drop m bc + +{------------------------------------------------------------------------------- + HasBufFS +-------------------------------------------------------------------------------} + +packMutableByteArray :: PrimMonad m => P.MutableByteArray (PrimState m) -> BufferOffset -> [Word8] -> m () +packMutableByteArray mba i bytes = forM_ (zip [unBufferOffset i..] bytes) $ uncurry (P.writeByteArray mba) + +intoBuffer :: PrimMonad m => P.MutableByteArray (PrimState m) -> BufferOffset -> ByteString -> m Bool +intoBuffer buf bufOff bs = do + bufSize <- P.getSizeofMutableByteArray buf + let remaining = bufSize - unBufferOffset bufOff + if BS.length bs > remaining + then pure False + else packMutableByteArray buf bufOff (BS.unpack bs) + >> pure True + +unpackMutableByteArray :: PrimMonad m => P.MutableByteArray (PrimState m) -> BufferOffset -> ByteCount -> m [Word8] +unpackMutableByteArray mba i c = forM [unBufferOffset i .. unBufferOffset i + fromIntegral c - 1] $ P.readByteArray mba + +fromBuffer :: PrimMonad m => P.MutableByteArray (PrimState m) -> BufferOffset -> ByteCount -> m (Maybe ByteString) +fromBuffer buf bufOff c = do + bufSize <- P.getSizeofMutableByteArray buf + let remaining = bufSize - unBufferOffset bufOff + if fromIntegral c > remaining + then pure Nothing + else Just . BS.pack <$> unpackMutableByteArray buf bufOff c + +hGetBufSome :: (CanSimFS m, PrimMonad m) => Handle' -> MutableByteArray (PrimState m) -> BufferOffset -> ByteCount -> m ByteCount +hGetBufSome h buf bufOff n = + withOpenHandleRead h $ \fs hs@OpenHandle{..} -> do + file <- checkFsTree $ FS.getFile openFilePath (mockFiles fs) + case openPtr of + RW r w o -> do + unless r $ throwError (errNoReadAccess openFilePath "write") + let bs = BS.take (fromIntegral n) . BS.drop (fromIntegral o) $ file + success <- intoBuffer buf bufOff bs + -- we can't read more bytes than the buffer size + unless success $ throwError (errWritePastBufEnd openFilePath) + let readBytes = fromIntegral (BS.length bs) + return (readBytes, hs { openPtr = RW True w (o + fromIntegral readBytes)}) + Append -> throwError (errNoReadAccess openFilePath "append") + where + errNoReadAccess fp mode = FsError { + fsErrorType = FsInvalidArgument + , fsErrorPath = fsToFsErrorPathUnmounted fp + , fsErrorString = "cannot hGetBufSomeAt in " <> mode <> " mode" + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = True + } + + errWritePastBufEnd fp = FsError { + fsErrorType = FsInvalidArgument + , fsErrorPath = fsToFsErrorPathUnmounted fp + , fsErrorString = "hPutBufSomeAt: writing into buffer past end not supported" + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = True + } + +hGetBufSomeAt :: (CanSimFS m, PrimMonad m) => Handle' -> MutableByteArray (PrimState m) -> BufferOffset -> ByteCount -> AbsOffset -> m ByteCount +hGetBufSomeAt h buf bufOff n o = + withOpenHandleRead h $ \fs hs@OpenHandle{..} -> do + file <- checkFsTree $ FS.getFile openFilePath (mockFiles fs) + let o' = unAbsOffset o + let fsize = fromIntegral (BS.length file) :: Word64 + case openPtr of + RW r _ _ -> do + unless r $ throwError (errNoReadAccess openFilePath "write") + -- This is the same fsLimitation we get when we seek past the end of + -- EOF, in AbsoluteSeek mode. + when (o' > fsize) $ throwError (errPastEnd openFilePath) + let bs = BS.take (fromIntegral n) . BS.drop (fromIntegral o') $ file + success <- intoBuffer buf bufOff bs + -- we can't read more bytes than the buffer size + unless success $ throwError (errWritePastBufEnd openFilePath) + return (fromIntegral (BS.length bs), hs) + Append -> throwError (errNoReadAccess openFilePath "append") + where + errNoReadAccess fp mode = FsError { + fsErrorType = FsInvalidArgument + , fsErrorPath = fsToFsErrorPathUnmounted fp + , fsErrorString = "cannot hGetBufSomeAt in " <> mode <> " mode" + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = True + } + + errPastEnd fp = FsError { + fsErrorType = FsInvalidArgument + , fsErrorPath = fsToFsErrorPathUnmounted fp + , fsErrorString = "hGetBufSomeAt offset past EOF not supported" + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = True + } + + errWritePastBufEnd fp = FsError { + fsErrorType = FsInvalidArgument + , fsErrorPath = fsToFsErrorPathUnmounted fp + , fsErrorString = "hPutBufSomeAt: writing into buffer past end not supported" + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = True + } + +hPutBufSome :: (CanSimFS m, PrimMonad m) => Handle' -> MutableByteArray (PrimState m) -> BufferOffset -> ByteCount -> m ByteCount +hPutBufSome h buf bufOff n = do + withOpenHandleModify h $ \fs hs@OpenHandle{..} -> do + file <- checkFsTree $ FS.getFile openFilePath (mockFiles fs) + case openPtr of + RW r w o -> do + unless w $ throwError (errNoWriteAccess openFilePath "read") + -- We can't write more bytes than the buffer size + toWrite <- fromBuffer buf bufOff n >>= \case + Nothing -> throwError (errReadPastBufEnd openFilePath) + Just bs -> pure bs + let file' = replace o toWrite file + files' <- checkFsTree $ FS.replace openFilePath file' (mockFiles fs) + let written = fromIntegral $ BS.length toWrite + return (written, (files', hs { openPtr = RW r w (o + fromIntegral written)})) + Append -> do + -- We can't write more bytes than the buffer size + toWrite <- fromBuffer buf bufOff n >>= \case + Nothing -> throwError (errReadPastBufEnd openFilePath) + Just bs -> pure bs + let file' = file <> toWrite + files' <- checkFsTree $ FS.replace openFilePath file' (mockFiles fs) + let written = fromIntegral $ BS.length toWrite + return (written, (files', hs)) + where + errNoWriteAccess fp mode = FsError { + fsErrorType = FsInvalidArgument + , fsErrorPath = fsToFsErrorPathUnmounted fp + , fsErrorString = "cannot hPutBufSomeAt in " <> mode <> " mode" + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = True + } + + errReadPastBufEnd fp = FsError { + fsErrorType = FsInvalidArgument + , fsErrorPath = fsToFsErrorPathUnmounted fp + , fsErrorString = "hPutBufSomeAt: reading from buffer past end not supported" + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = True + } + +hPutBufSomeAt :: (CanSimFS m, PrimMonad m) => Handle' -> MutableByteArray (PrimState m) -> BufferOffset -> ByteCount -> AbsOffset -> m ByteCount +hPutBufSomeAt h buf bufOff n o = do + withOpenHandleModify h $ \fs hs@OpenHandle{..} -> do + file <- checkFsTree $ FS.getFile openFilePath (mockFiles fs) + let o' = unAbsOffset o + let fsize = fromIntegral (BS.length file) + case openPtr of + RW _ w _ -> do + unless w $ throwError (errNoWriteAccess openFilePath "read") + -- This is the same fsLimitation we get when we seek past the end of + -- EOF, in AbsoluteSeek mode. + when (o' > fsize) $ throwError (errPastEnd openFilePath) + -- We can't write more bytes than the buffer size + toWrite <- fromBuffer buf bufOff n >>= \case + Nothing -> throwError (errReadPastBufEnd openFilePath) + Just bs -> pure bs + let file' = replace o' toWrite file + files' <- checkFsTree $ FS.replace openFilePath file' (mockFiles fs) + let written = fromIntegral $ BS.length toWrite + return (written, (files', hs)) + Append -> throwError (errNoWriteAccess openFilePath "append") + where + errNoWriteAccess fp mode = FsError { + fsErrorType = FsInvalidArgument + , fsErrorPath = fsToFsErrorPathUnmounted fp + , fsErrorString = "cannot hPutBufSomeAt in " <> mode <> " mode" + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = True + } + + errPastEnd fp = FsError { + fsErrorType = FsInvalidArgument + , fsErrorPath = fsToFsErrorPathUnmounted fp + , fsErrorString = "hPutBufSomeAt offset past EOF not supported" + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = True + } + + errReadPastBufEnd fp = FsError { + fsErrorType = FsInvalidArgument + , fsErrorPath = fsToFsErrorPathUnmounted fp + , fsErrorString = "hPutBufSomeAt: reading from buffer past end not supported" + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = True + } diff --git a/fs-sim/src/System/FS/Sim/Prim.hs b/fs-sim/src/System/FS/Sim/Prim.hs new file mode 100644 index 0000000..e387a1a --- /dev/null +++ b/fs-sim/src/System/FS/Sim/Prim.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UndecidableInstances #-} + +module System.FS.Sim.Prim ( + FSSimT + , runFSSimT + , FSSim + , runFSSim + , pureHasFS + , primHasFS + , primHasBufFS + ) where + +import Control.Monad.Except +import Control.Monad.Identity (Identity (..)) +import Control.Monad.Primitive +import Control.Monad.State + +import System.FS.API + +import qualified System.FS.Sim.MockFS as Mock +import System.FS.Sim.MockFS (MockFS) + +newtype FSSimT m a = PureSimFS { + unFSSimT :: StateT MockFS (ExceptT FsError m) a + } + deriving newtype ( Functor, Applicative, Monad + , MonadState MockFS, MonadError FsError, PrimMonad ) + +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 { + 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" + } + +primHasBufFS :: PrimMonad m => HasBufFS (FSSimT m) Mock.HandleMock +primHasBufFS = HasBufFS { + 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 index 4ccd5a8..b805aeb 100644 --- a/fs-sim/src/System/FS/Sim/Pure.hs +++ b/fs-sim/src/System/FS/Sim/Pure.hs @@ -9,39 +9,20 @@ module System.FS.Sim.Pure ( 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 (StateT MockFS (Except FsError) a) +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 = runExcept $ runStateT act st +runPureSimFS (PureSimFS act) !st = Prim.runFSSim act st pureHasFS :: HasFS PureSimFS 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" - } +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 1a9ee59..15c8359 100644 --- a/fs-sim/src/System/FS/Sim/STM.hs +++ b/fs-sim/src/System/FS/Sim/STM.hs @@ -1,5 +1,5 @@ +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -- | 'HasFS' instance using 'MockFS' stored in an STM variable module System.FS.Sim.STM ( @@ -15,7 +15,7 @@ import System.FS.API import qualified System.FS.Sim.MockFS as Mock import System.FS.Sim.MockFS (HandleMock, MockFS) -import System.FS.Sim.Pure (PureSimFS, runPureSimFS) +import System.FS.Sim.Prim {------------------------------------------------------------------------------ The simulation-related types @@ -67,11 +67,11 @@ simHasFS var = HasFS { , unsafeToFilePath = \_ -> error "simHasFS:unsafeToFilePath" } where - sim :: PureSimFS a -> m a + sim :: FSSim a -> m a sim m = do eOrA <- atomically $ do st <- readTVar var - case runPureSimFS m st of + case runFSSim m st of Left e -> return $ Left e Right (a, st') -> do writeTVar var st' diff --git a/fs-sim/test/Test/System/FS/StateMachine.hs b/fs-sim/test/Test/System/FS/StateMachine.hs index 3559a2d..8831c8a 100644 --- a/fs-sim/test/Test/System/FS/StateMachine.hs +++ b/fs-sim/test/Test/System/FS/StateMachine.hs @@ -3,8 +3,11 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} @@ -14,6 +17,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -55,6 +59,8 @@ module Test.System.FS.StateMachine ( import qualified Control.Exception as E import Control.Monad +import Control.Monad.Primitive +import Control.Monad.ST.Strict (runST) import Data.Bifoldable import Data.Bifunctor import qualified Data.Bifunctor.TH as TH @@ -67,6 +73,8 @@ import Data.List (foldl') import qualified Data.List as L import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map +import Data.Maybe (fromJust) +import Data.Primitive (MutableByteArray, newPinnedByteArray) import Data.Proxy import Data.Set (Set) import qualified Data.Set as Set @@ -77,6 +85,7 @@ import qualified Generics.SOP as SOP import GHC.Generics import GHC.Stack hiding (prettyCallStack) import System.IO.Temp (withTempDirectory) +import System.Posix.Types (ByteCount) import System.Random (getStdRandom, randomR) import Text.Read (readMaybe) import Text.Show.Pretty (ppShow) @@ -103,7 +112,7 @@ import Util.Condense import System.FS.Sim.FsTree (FsTree (..)) import qualified System.FS.Sim.MockFS as Mock import System.FS.Sim.MockFS (HandleMock, MockFS) -import System.FS.Sim.Pure +import System.FS.Sim.Prim import qualified Test.Util.RefEnv as RE import Test.Util.RefEnv (RefEnv) @@ -147,7 +156,11 @@ data Cmd fp h = | Seek h SeekMode Int64 | Get h Word64 | GetAt h Word64 AbsOffset + | GetBuf h ByteCount + | GetBufAt h ByteCount AbsOffset | Put h ByteString + | PutBuf h ByteString ByteCount + | PutBufAt h ByteString ByteCount AbsOffset | Truncate h Word64 | GetSize h | CreateDir (PathExpr fp) @@ -171,16 +184,19 @@ data Success fp h = | Path fp () | Word64 Word64 | ByteString ByteString + | ByteCount ByteCount + | BCBS ByteCount ByteString | Strings (Set String) | Bool Bool deriving (Eq, Show, Functor, Foldable) -- | Successful semantics -run :: forall m h. Monad m +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{..} = go +run hasFS@HasFS{..} hasBufFS = go where go :: Cmd FsPath (Handle h) -> m (Success FsPath (Handle h)) go (Open pe mode) = @@ -198,7 +214,11 @@ run hasFS@HasFS{..} = 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 (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 (Truncate h sz ) = Unit <$> hTruncate h sz go (GetSize h ) = Word64 <$> hGetSize h go (ListDirectory pe ) = withPE pe (const Strings) $ listDirectory @@ -224,7 +244,6 @@ run hasFS@HasFS{..} = go fp2 = evalPathExpr pe2 in r fp1 fp2 <$> f fp1 fp2 - {------------------------------------------------------------------------------- Detecting partial reads/writes of the tested IO implementation -------------------------------------------------------------------------------} @@ -299,6 +318,63 @@ hPutSomeChecked HasFS{..} h bytes = do then error "Unsupported partial write detected, see Note [Checking for partial reads/writes]" else return n +hGetBufSomeChecked :: (HasCallStack, PrimMonad m) + => HasFS m h + -> HasBufFS m h + -> Handle h -> ByteCount -> m (ByteCount, ByteString) +hGetBufSomeChecked HasFS{..} HasBufFS{..} h n = do + allocaMutableByteArray (fromIntegral n) $ \buf -> do + n' <- hGetBufSome h buf 0 n + bs <- fromJust <$> Mock.fromBuffer buf 0 n' + when (n /= n') $ do + moreBytes <- hGetSome h 1 + -- If we can actually read more bytes, the last read was partial. If we + -- cannot, we really were at EOF. + unless (BS.null moreBytes) $ + error "Unsupported partial read detected, see #502" + pure (n', bs) + +hGetBufSomeAtChecked :: (HasCallStack, PrimMonad m) + => HasFS m h + -> HasBufFS m h + -> Handle h -> ByteCount -> AbsOffset -> m (ByteCount, ByteString) +hGetBufSomeAtChecked HasFS{..} HasBufFS{..} h n o = do + allocaMutableByteArray (fromIntegral n) $ \buf -> do + n' <- hGetBufSomeAt h buf 0 n o + bs <- fromJust <$> Mock.fromBuffer buf 0 n' + when (n /= n') $ do + moreBytes <- hGetSomeAt h 1 $ o + fromIntegral n' + -- If we can actually read more bytes, the last read was partial. If we + -- cannot, we really were at EOF. + unless (BS.null moreBytes) $ + error "Unsupported partial read detected, see #502" + pure (n', bs) + +hPutBufSomeChecked :: (HasCallStack, PrimMonad m) + => HasBufFS m h + -> Handle h -> ByteString -> ByteCount -> m ByteCount +hPutBufSomeChecked HasBufFS{..} 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 + if n /= n' + then error "Unsupported partial write detected, see #502" + else return n + +hPutBufSomeAtChecked :: (HasCallStack, PrimMonad m) + => HasBufFS m h + -> Handle h -> ByteString -> ByteCount -> AbsOffset -> m ByteCount +hPutBufSomeAtChecked HasBufFS{..} 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 + if n /= n' + then error "Unsupported partial write detected, see #502" + else return n + +allocaMutableByteArray :: PrimMonad m => Int -> (MutableByteArray (PrimState m) -> m a) -> m a +allocaMutableByteArray size action = newPinnedByteArray size >>= action + {------------------------------------------------------------------------------- Instantiating the semantics -------------------------------------------------------------------------------} @@ -316,7 +392,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 $ runPureSimFS (run pureHasFS cmd) mockFS + aux $ runST $ runFSSimT (run primHasFS primHasBufFS cmd) mockFS where aux :: Either FsError (Success FsPath (Handle HandleMock), MockFS) -> (Resp FsPath (Handle HandleMock), MockFS) @@ -325,7 +401,7 @@ runPure cmd mockFS = runIO :: MountPoint -> Cmd FsPath (Handle HandleIO) -> IO (Resp FsPath (Handle HandleIO)) -runIO mount cmd = Resp <$> E.try (run (ioHasFS mount) cmd) +runIO mount cmd = Resp <$> E.try (run (ioHasFS mount) (ioHasBufFS mount) cmd) {------------------------------------------------------------------------------- Bitraversable instances @@ -511,7 +587,11 @@ generator Model{..} = oneof $ concat [ , fmap At $ Seek <$> genHandle <*> genSeekMode <*> genOffset , fmap At $ Get <$> genHandle <*> (getSmall <$> arbitrary) , fmap At $ GetAt <$> genHandle <*> (getSmall <$> arbitrary) <*> arbitrary + , fmap At $ GetBuf <$> genHandle <*> (getSmall <$> arbitrary) + , fmap At $ GetBufAt <$> genHandle <*> (getSmall <$> arbitrary) <*> arbitrary , fmap At $ Put <$> genHandle <*> (BS.pack <$> arbitrary) + , fmap At $ PutBuf <$> genHandle <*> (BS.pack <$> arbitrary) <*> (getSmall <$> arbitrary) + , fmap At $ PutBufAt <$> genHandle <*> (BS.pack <$> arbitrary) <*> (getSmall <$> arbitrary) <*> arbitrary , fmap At $ Truncate <$> genHandle <*> (getSmall . getNonNegative <$> arbitrary) , fmap At $ GetSize <$> genHandle ] @@ -639,7 +719,19 @@ shrinker Model{..} (At cmd) = GetAt h n o -> At <$> [GetAt h n o' | o' <- shrink o] <> [GetAt h n' o | n' <- shrink n] + GetBuf h n -> At <$> + [GetBuf h n' | n' <- shrink n] + GetBufAt h n o -> At <$> + [GetBufAt h n' o | n' <- shrink n] <> + [GetBufAt h n o' | o' <- shrink o] Put h bs -> At . Put h <$> shrinkBytes bs + PutBuf h bs n -> At <$> + [PutBuf h bs' n | bs' <- BS.pack <$> shrink (BS.unpack bs)] <> + [PutBuf h bs n' | n' <- shrink n] + PutBufAt h bs n o -> At <$> + [PutBufAt h bs' n o | bs' <- BS.pack <$> shrink (BS.unpack bs)] <> + [PutBufAt h bs n' o | n' <- shrink n] <> + [PutBufAt h bs n o' | o' <- shrink o] Truncate h n -> At . Truncate h <$> shrink n _otherwise -> @@ -936,6 +1028,18 @@ data Tag = -- -- > GetAt ... | TagPread + + -- Roundtrip for I/O with user-supplied buffers + -- + -- > PutBuf h bs c + -- > GetBuf h c (==bs) + | TagPutGetBuf + + -- Roundtrip for I/O with user-supplied buffers + -- + -- > PutBufAt h bs c o + -- > GetBufAt h c o (==bs) + | TagPutGetBufAt deriving (Show, Eq) -- | Predicate on events @@ -988,6 +1092,8 @@ tag = C.classify [ , tagExclusiveFail , tagReadEOF , tagPread + , tagPutGetBuf Set.empty + , tagPutGetBufAt Set.empty ] where tagCreateDirThenListDir :: Set FsPath -> EventPred @@ -1342,6 +1448,26 @@ tag = C.classify [ GetAt{} -> Left TagPread _otherwise -> Right tagPread + tagPutGetBufAt :: Set HandleMock -> EventPred + tagPutGetBufAt put = successful $ \ev _ -> + case eventMockCmd ev of + PutBufAt (Handle h _) bs c _ | BS.length bs > 0 && c > 0 -> + Right (tagPutGetBufAt (Set.insert h put)) + GetBufAt _ c _ | c > 0 -> + Left TagPutGetBufAt + _otherwise -> + Right (tagPutGetBufAt put) + + tagPutGetBuf :: Set HandleMock -> EventPred + tagPutGetBuf put = successful $ \ev _ -> + case eventMockCmd ev of + PutBuf (Handle h _) bs c | BS.length bs > 0 && c > 0 -> + Right (tagPutGetBuf (Set.insert h put)) + GetBuf _ c | c > 0 -> + Left TagPutGetBuf + _otherwise -> + Right (tagPutGetBuf put) + -- | Step the model using a 'QSM.Command' (i.e., a command associated with -- an explicit set of variables) execCmd :: Model Symbolic -> QSM.Command (At Cmd) (At Resp) -> Event Symbolic @@ -1467,6 +1593,7 @@ runCmds tmpDir cmds = QC.monadicIO $ do $ QSM.checkCommandNames cmds $ tabulate "Tags" (map show $ tag (execCmds cmds)) $ counterexample ("Mount point: " ++ tstTmpDir) + $ QSM.checkCommandNames cmds $ res === QSM.Ok tests :: FilePath -> TestTree @@ -1560,7 +1687,11 @@ instance (Condense fp, Condense h) => Condense (Cmd fp h) where go (Seek h mode o) = ["seek", condense h, condense mode, condense o] go (Get h n) = ["get", condense h, condense n] go (GetAt h n o) = ["getAt", condense h, condense n, condense o] + go (GetBuf h n) = ["getBuf", condense h, condense n] + go (GetBufAt h n o) = ["getBufAt", condense h, condense n, condense o] go (Put h bs) = ["put", condense h, condense bs] + go (PutBuf h bs n) = ["putBuf", condense h, condense bs, condense n] + go (PutBufAt h bs n o) = ["putBufAt", condense h, condense bs, condense n, condense o] go (Truncate h sz) = ["truncate", condense h, condense sz] go (GetSize h) = ["getSize", condense h] go (CreateDir fp) = ["createDir", condense fp] @@ -1581,6 +1712,9 @@ instance Condense Tag where instance Condense AbsOffset where condense = show +instance Condense ByteCount where + condense = show + {------------------------------------------------------------------------------- (Orphan) condense instance for QSM types -------------------------------------------------------------------------------}