fs-sim 0.4.1.0 → 0.5.0.0
raw patch · 16 files changed
+5281/−4681 lines, 16 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
- System.FS.Sim.Error: runSimErrorFS :: (MonadSTM m, MonadThrow m, PrimMonad m) => MockFS -> Errors -> (StrictTVar m Errors -> HasFS m HandleMock -> m a) -> m (a, MockFS)
+ System.FS.Sim.Error: runSimErrorFS :: (MonadSTM m, MonadMask m, PrimMonad m) => MockFS -> Errors -> (StrictTVar m Errors -> HasFS m HandleMock -> m a) -> m (a, MockFS)
- System.FS.Sim.Error: simErrorHasFS :: forall (m :: Type -> Type). (MonadSTM m, MonadThrow m, PrimMonad m) => StrictTMVar m MockFS -> StrictTVar m Errors -> HasFS m HandleMock
+ System.FS.Sim.Error: simErrorHasFS :: forall (m :: Type -> Type). (MonadSTM m, MonadMask m, PrimMonad m) => StrictTMVar m MockFS -> StrictTVar m Errors -> HasFS m HandleMock
- System.FS.Sim.Error: simErrorHasFS' :: (MonadSTM m, MonadThrow m, PrimMonad m) => MockFS -> Errors -> m (HasFS m HandleMock)
+ System.FS.Sim.Error: simErrorHasFS' :: (MonadSTM m, MonadMask m, PrimMonad m) => MockFS -> Errors -> m (HasFS m HandleMock)
- System.FS.Sim.STM: runSimFS :: (MonadSTM m, MonadThrow m, PrimMonad m) => MockFS -> (HasFS m HandleMock -> m a) -> m (a, MockFS)
+ System.FS.Sim.STM: runSimFS :: (MonadSTM m, MonadMask m, PrimMonad m) => MockFS -> (HasFS m HandleMock -> m a) -> m (a, MockFS)
- System.FS.Sim.STM: simHasFS :: forall (m :: Type -> Type). (MonadSTM m, MonadThrow m, PrimMonad m) => StrictTMVar m MockFS -> HasFS m HandleMock
+ System.FS.Sim.STM: simHasFS :: forall (m :: Type -> Type). (MonadSTM m, MonadMask m, PrimMonad m) => StrictTMVar m MockFS -> HasFS m HandleMock
- System.FS.Sim.STM: simHasFS' :: (MonadSTM m, MonadThrow m, PrimMonad m) => MockFS -> m (HasFS m HandleMock)
+ System.FS.Sim.STM: simHasFS' :: (MonadSTM m, MonadMask m, PrimMonad m) => MockFS -> m (HasFS m HandleMock)
Files
- CHANGELOG.md +7/−0
- fs-sim.cabal +72/−60
- src/System/FS/Sim/Error.hs +1031/−842
- src/System/FS/Sim/FsTree.hs +233/−183
- src/System/FS/Sim/MockFS.hs +1210/−1118
- src/System/FS/Sim/Prim.hs +50/−45
- src/System/FS/Sim/STM.hs +87/−71
- src/System/FS/Sim/Stream.hs +70/−60
- test/Main.hs +10/−7
- test/Test/System/FS/Sim/Error.hs +179/−154
- test/Test/System/FS/Sim/FsTree.hs +129/−90
- test/Test/System/FS/Sim/Stream.hs +110/−92
- test/Test/System/FS/StateMachine.hs +1960/−1851
- test/Test/Util.hs +11/−11
- test/Test/Util/RefEnv.hs +55/−48
- test/Test/Util/WithEntryCounter.hs +67/−49
CHANGELOG.md view
@@ -1,5 +1,12 @@ # Revision history for fs-sim +## 0.5.0.0 -- 2026-04-23++### Breaking++* Make `sim` operations exception safe by using `withMockFS`.+* Require `MonadMask` in `simHasFS`, `simHasFS'`, `runSimFS`.+ ## 0.4.1.0 -- 2025-09-29 ### Non-breaking
fs-sim.cabal view
@@ -1,39 +1,39 @@-cabal-version: 3.0-name: fs-sim-version: 0.4.1.0-synopsis: Simulated file systems-description: Simulated file systems.-license: Apache-2.0+cabal-version: 3.0+name: fs-sim+version: 0.5.0.0+synopsis: Simulated file systems+description: Simulated file systems.+license: Apache-2.0 license-files: LICENSE NOTICE -copyright: 2019-2024 Input Output Global Inc (IOG)-author: IOG Engineering Team-maintainer: operations@iohk.io, Joris Dral (joris@well-typed.com)-homepage: https://github.com/input-output-hk/fs-sim-bug-reports: https://github.com/input-output-hk/fs-sim/issues-category: Testing-build-type: Simple+copyright: 2019-2024 Input Output Global Inc (IOG)+author: IOG Engineering Team+maintainer: operations@iohk.io, Joris Dral (joris@well-typed.com)+homepage: https://github.com/input-output-hk/fs-sim+bug-reports: https://github.com/input-output-hk/fs-sim/issues+category: Testing+build-type: Simple extra-doc-files: CHANGELOG.md README.md -tested-with: GHC ==9.2 || ==9.4 || ==9.6 || ==9.8 || ==9.10 || ==9.12+tested-with: ghc ==9.2 || ==9.4 || ==9.6 || ==9.8 || ==9.10 || ==9.12 || ==9.14 source-repository head- type: git+ type: git location: https://github.com/input-output-hk/fs-sim- subdir: fs-sim+ subdir: fs-sim source-repository this- type: git+ type: git location: https://github.com/input-output-hk/fs-sim- subdir: fs-sim- tag: fs-sim-0.4.1.0+ subdir: fs-sim+ tag: fs-sim-0.5.0.0 library- hs-source-dirs: src+ hs-source-dirs: src exposed-modules: System.FS.Sim.Error System.FS.Sim.FsTree@@ -44,28 +44,34 @@ default-language: Haskell2010 build-depends:- , base >=4.16 && <4.22- , base16-bytestring ^>=0.1 || ^>=1.0- , bytestring ^>=0.10 || ^>=0.11 || ^>=0.12- , containers ^>=0.5 || ^>=0.6 || ^>=0.7 || ^>=0.8- , fs-api ^>=0.4- , io-classes ^>=1.6 || ^>=1.7 || ^>=1.8.0.1- , io-classes:strict-stm- , mtl ^>=2.2 || ^>=2.3- , primitive ^>=0.9- , QuickCheck ^>=2.13 || ^>=2.14 || ^>=2.15 || ^>=2.16- , safe-wild-cards ^>=1.0- , text ^>=1.2 || ^>=2.0 || ^>=2.1+ QuickCheck ^>=2.13 || ^>=2.14 || ^>=2.15 || ^>=2.16 || ^>=2.17,+ base >=4.16 && <4.23,+ base16-bytestring ^>=0.1 || ^>=1.0,+ bytestring ^>=0.10 || ^>=0.11 || ^>=0.12,+ containers ^>=0.5 || ^>=0.6 || ^>=0.7 || ^>=0.8,+ fs-api ^>=0.4,+ io-classes ^>=1.6 || ^>=1.7 || ^>=1.8.0.1 || ^>=1.9 || ^>=1.10,+ io-classes:strict-stm,+ mtl ^>=2.2 || ^>=2.3,+ primitive ^>=0.9,+ safe-wild-cards ^>=1.0,+ text ^>=1.2 || ^>=2.0 || ^>=2.1, ghc-options:- -Wall -Wcompat -Wincomplete-uni-patterns- -Wincomplete-record-updates -Wpartial-fields -Widentities- -Wredundant-constraints -Wmissing-export-lists -Wunused-packages+ -Wall+ -Wcompat+ -Wincomplete-uni-patterns+ -Wincomplete-record-updates+ -Wpartial-fields+ -Widentities+ -Wredundant-constraints+ -Wmissing-export-lists+ -Wunused-packages test-suite fs-sim-test- type: exitcode-stdio-1.0- hs-source-dirs: test- main-is: Main.hs+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Main.hs other-modules: Test.System.FS.Sim.Error Test.System.FS.Sim.FsTree@@ -77,28 +83,34 @@ default-language: Haskell2010 build-depends:- , base- , bifunctors- , bytestring- , containers- , deepseq- , fs-api- , fs-sim- , generics-sop- , io-classes:strict-stm- , pretty-show- , primitive- , QuickCheck- , quickcheck-state-machine >=0.10- , random- , tasty- , tasty-hunit- , tasty-quickcheck- , temporary- , text+ QuickCheck,+ base,+ bifunctors,+ bytestring,+ containers,+ deepseq,+ fs-api,+ fs-sim,+ generics-sop,+ io-classes:strict-stm,+ pretty-show,+ primitive,+ quickcheck-state-machine >=0.10,+ random,+ tasty,+ tasty-hunit,+ tasty-quickcheck,+ temporary,+ text, ghc-options:- -Wall -Wcompat -Wincomplete-uni-patterns- -Wincomplete-record-updates -Wpartial-fields -Widentities- -Wredundant-constraints -Wmissing-export-lists -Wunused-packages+ -Wall+ -Wcompat+ -Wincomplete-uni-patterns+ -Wincomplete-record-updates+ -Wpartial-fields+ -Widentities+ -Wredundant-constraints+ -Wmissing-export-lists+ -Wunused-packages -fno-ignore-asserts
src/System/FS/Sim/Error.hs view
@@ -1,842 +1,1031 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE UndecidableInstances #-}---- | 'HasFS' instance wrapping 'SimFS' that generates errors, suitable for--- testing error handling.-module System.FS.Sim.Error (- -- * Simulate Errors monad- simErrorHasFS- , simErrorHasFS'- , runSimErrorFS- , withErrors- -- * Streams- , ErrorStream- , ErrorStreamGetSome- , ErrorStreamPutSome- -- * Generating partial reads/writes- , Partial (..)- , partialiseByteCount- , partialiseWord64- , partialiseByteString- -- * Blob- , Blob (..)- , blobFromBS- , blobToBS- -- * Generating corruption for 'hPutSome'- , PutCorruption (..)- , corruptByteString- -- * Error streams for 'HasFS'- , Errors (..)- , allNull- , emptyErrors- , genErrors- , simpleErrors- ) where--import Control.Concurrent.Class.MonadSTM.Strict-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-import qualified Data.ByteString.Lazy as BL-import qualified Data.ByteString.Lazy.Char8 as LC8-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 Prelude hiding (null)-import SafeWildCards-import System.Posix.Types--import qualified Test.QuickCheck as QC-import Test.QuickCheck (ASCIIString (..), Arbitrary (..), Gen,- suchThat)--import System.FS.API-import System.FS.CallStack--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-import System.FS.Sim.Stream (Stream)--{-------------------------------------------------------------------------------- Streams of errors--------------------------------------------------------------------------------}---- | An 'ErrorStream' is a possibly infinite 'Stream' of (@Maybe@)--- @'FsErrorType'@s.------ 'Nothing' indicates that there is no error.------ Each time the 'ErrorStream' is used (see 'runErrorStream'), the first--- element ('Nothing' in case the list is empty) is taken from the list and an--- 'ErrorStream' with the remainder of the list is returned. The first element--- represents whether an error should be returned or not.------ An 'FsError' consists of a number of fields: 'fsErrorType', a--- 'fsErrorPath', etc. Only the first fields is interesting. Therefore, we--- only generate the 'FsErrorType'. The 'FsErrorType' will be used to--- construct the actual 'FsError'.-type ErrorStream = Stream FsErrorType---- | 'ErrorStream' for reading bytes from a file: an error or a partial get.-type ErrorStreamGetSome = Stream (Either FsErrorType Partial)---- | 'ErrorStream' for writing bytes to a file: an error and possibly some--- corruption, or a partial write.-type ErrorStreamPutSome =- Stream (Either (FsErrorType, Maybe PutCorruption) Partial)--{-------------------------------------------------------------------------------- Generating partial reads/writes--------------------------------------------------------------------------------}---- | A @'Partial' p@, where @p > 0@, is a number representing how many fewer--- bytes should be read or written than requested.-newtype Partial = Partial Word64- deriving (Show)--instance Arbitrary Partial where- arbitrary = Partial <$> QC.choose (1, 100)- shrink (Partial p) =- [Partial p' | p' <- [1..p]]---- | Given a requested number of bytes to read/write, compute a partial number--- of bytes to read/write.------ We subtract @p@ from the number of requested bytes. If that would result in 0--- requested bytes or less, we request 1 byte. If the number of requested bytes--- was already 0, we can't simulate a partial read so we return 0 again.-partialiseByteCount :: Partial -> ByteCount -> ByteCount-partialiseByteCount (Partial p) c- | 0 <- c' = c- | p >= c' = 1- | otherwise = c - fromIntegral p- where c' = fromIntegral c---- | Like 'partialiseByteCount', but for 'Word64'.-partialiseWord64 :: Partial -> Word64 -> Word64-partialiseWord64 (Partial p) c- | 0 <- c = c- | p >= c = 1- | otherwise = c - p---- | Given a bytestring that is requested to be written to disk, use--- 'partialiseByteCount' to compute a partial bytestring.-partialiseByteString :: Partial -> BS.ByteString -> BS.ByteString-partialiseByteString p bs = BS.take (fromIntegral $ partialiseByteCount p len) bs- where len = fromIntegral (BS.length bs)--{------------------------------------------------------------------------------- Blob-------------------------------------------------------------------------------}---- For the custom 'Show' and 'Arbitrary' instances------ A builder of a non-empty bytestring.-newtype Blob = MkBlob { getBlob :: ByteString }- deriving (Show)--instance Arbitrary Blob where- arbitrary = do- str <- (getASCIIString <$> arbitrary) `suchThat` (not . List.null)- return $ fromString str- shrink (MkBlob b) =- [ fromString s'- | let s = ASCIIString $ LC8.unpack $ BL.fromStrict b- , s' <- getASCIIString <$> shrink s- , not (List.null s') ]--blobToBS :: Blob -> ByteString-blobToBS = getBlob--blobFromBS :: ByteString -> Blob-blobFromBS = MkBlob--instance IsString Blob where- fromString = blobFromBS . C8.pack--{-------------------------------------------------------------------------------- Generating corruption for hPutSome--------------------------------------------------------------------------------}---- | Model possible corruptions that could happen to a 'hPutSome' call.-data PutCorruption- = SubstituteWithJunk Blob- -- ^ The blob to write is substituted with corrupt junk- | PartialWrite Partial- -- ^ Only perform the write partially- deriving (Show)--instance Arbitrary PutCorruption where- arbitrary = QC.oneof- [ SubstituteWithJunk <$> arbitrary- , PartialWrite <$> arbitrary- ]- shrink (SubstituteWithJunk blob) =- [SubstituteWithJunk blob' | blob' <- shrink blob]- shrink (PartialWrite partial) =- [PartialWrite partial' | partial' <- shrink partial]---- | Apply the 'PutCorruption' to the 'BS.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--------------------------------------------------------------------------------}---- | Error streams for the methods of the 'HasFS' type class.------ An 'ErrorStream' is provided for each method of the 'HasFS' type class.--- This 'ErrorStream' will be used to generate potential errors that will be--- thrown by the corresponding method.------ For 'hPutSome', an 'ErrorStreamWithCorruption' is provided to simulate--- corruption.------ An 'Errors' is used in conjunction with 'SimErrorFS', which is a layer on--- top of 'SimFS' that simulates methods throwing 'FsError's.-data Errors = Errors- { dumpStateE :: ErrorStream -- TODO remove- -- Operations on files- , hOpenE :: ErrorStream- , hCloseE :: ErrorStream- , hSeekE :: ErrorStream- , hGetSomeE :: ErrorStreamGetSome- , hGetSomeAtE :: ErrorStreamGetSome- , hPutSomeE :: ErrorStreamPutSome- , hTruncateE :: ErrorStream- , hGetSizeE :: ErrorStream- -- Operations on directories- , createDirectoryE :: ErrorStream- , createDirectoryIfMissingE :: ErrorStream- , listDirectoryE :: ErrorStream- , doesDirectoryExistE :: ErrorStream- , doesFileExistE :: ErrorStream- , 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---- | Return 'True' if all streams are empty ('null').-allNull :: Errors -> Bool-allNull $(fields 'Errors) = and [- 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 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- show $(fields 'Errors) =- "Errors {" <> intercalate ", " streams <> "}"- where- -- | Show a stream unless it is empty- s :: Show a => String -> Stream a -> Maybe String- s fld str | Stream.null str = Nothing- | otherwise = Just $ fld <> " = " <> show str-- streams :: [String]- streams = catMaybes- [ s "dumpStateE" dumpStateE- , s "hOpenE" hOpenE- , s "hCloseE" hCloseE- , s "hSeekE" hSeekE- , s "hGetSomeE" hGetSomeE- , s "hGetSomeAtE" hGetSomeAtE- , s "hPutSomeE" hPutSomeE- , s "hTruncateE" hTruncateE- , s "hGetSizeE" hGetSizeE- , s "createDirectoryE" createDirectoryE- , s "createDirectoryIfMissingE" createDirectoryIfMissingE- , s "listDirectoryE" listDirectoryE- , s "doesDirectoryExistE" doesDirectoryExistE- , s "doesFileExistE" doesFileExistE- , 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-emptyErrors = simpleErrors Stream.empty---- | Use the given 'ErrorStream' for each field/method. No corruption of--- 'hPutSome'.-simpleErrors :: ErrorStream -> Errors-simpleErrors es = Errors- { dumpStateE = es- , hOpenE = es- , hCloseE = es- , hSeekE = es- , hGetSomeE = Left <$> es- , hGetSomeAtE = Left <$> es- , hPutSomeE = Left . (, Nothing) <$> es- , hTruncateE = es- , hGetSizeE = es- , createDirectoryE = es- , createDirectoryIfMissingE = es- , listDirectoryE = es- , doesDirectoryExistE = es- , doesFileExistE = es- , 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.------ This is needed by the VolatileDB state machine tests, which try to predict--- what should happen based on the 'Errors', which is too complex sometimes.-genErrors :: Bool -- ^ 'True' -> generate partial writes- -> Bool -- ^ 'True' -> generate 'SubstituteWithJunk' corruptions- -> Gen Errors-genErrors genPartialWrites genSubstituteWithJunk = do- let -- TODO which errors are possible for these operations below (that- -- have dummy for now)?- dummy = streamGen 2 [ FsInsufficientPermissions ]- dumpStateE <- dummy- -- TODO let this one fail:- let hCloseE = Stream.empty- hTruncateE <- dummy- doesDirectoryExistE <- dummy- doesFileExistE <- dummy- hOpenE <- streamGen 1- [ FsResourceDoesNotExist, FsResourceInappropriateType- , FsResourceAlreadyInUse, FsResourceAlreadyExist- , FsInsufficientPermissions, FsTooManyOpenFiles ]- hSeekE <- streamGen 3 [ FsReachedEOF ]- hGetSomeE <- commonGetErrors- hGetSomeAtE <- commonGetErrors- hPutSomeE <- commonPutErrors- hGetSizeE <- streamGen 2 [ FsResourceDoesNotExist ]- createDirectoryE <- streamGen 3- [ FsInsufficientPermissions, FsResourceInappropriateType- , FsResourceAlreadyExist ]- createDirectoryIfMissingE <- streamGen 3- [ FsInsufficientPermissions, FsResourceInappropriateType- , FsResourceAlreadyExist ]- listDirectoryE <- streamGen 3- [ FsInsufficientPermissions, FsResourceInappropriateType- , FsResourceDoesNotExist ]- removeDirectoryRecursiveE <- streamGen 3- [ FsInsufficientPermissions, FsResourceAlreadyInUse- , FsResourceDoesNotExist, FsResourceInappropriateType ]- removeFileE <- streamGen 3- [ FsInsufficientPermissions, FsResourceAlreadyInUse- , FsResourceDoesNotExist, FsResourceInappropriateType ]- 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- genMaybe' = Stream.genMaybe 2-- streamGen l = Stream.genInfinite . genMaybe' l . QC.elements- streamGen' l = Stream.genInfinite . 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-- shrink err@($(fields 'Errors))- | allNull err = []- | otherwise = emptyErrors : concatMap (filter (not . allNull))- [ (\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 { hGetSomeE = s' }) <$> Stream.shrinkStream hGetSomeE- , (\s' -> err { hGetSomeAtE = s' }) <$> Stream.shrinkStream hGetSomeAtE- , (\s' -> err { hPutSomeE = s' }) <$> Stream.shrinkStream hPutSomeE- , (\s' -> err { hTruncateE = s' }) <$> Stream.shrinkStream hTruncateE- , (\s' -> err { hGetSizeE = s' }) <$> Stream.shrinkStream hGetSizeE- , (\s' -> err { createDirectoryE = s' }) <$> Stream.shrinkStream createDirectoryE- , (\s' -> err { createDirectoryIfMissingE = s' }) <$> Stream.shrinkStream createDirectoryIfMissingE- , (\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- -- 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- ]--{-------------------------------------------------------------------------------- Simulate Errors monad--------------------------------------------------------------------------------}---- | Alternative to 'simErrorHasFS' that creates 'TVar's internally.-simErrorHasFS' :: (MonadSTM m, MonadThrow m, PrimMonad m)- => MockFS- -> Errors- -> m (HasFS m HandleMock)-simErrorHasFS' mockFS errs =- simErrorHasFS <$> newTMVarIO mockFS <*> newTVarIO errs---- | Introduce possibility of errors-simErrorHasFS :: forall m. (MonadSTM m, MonadThrow m, PrimMonad m)- => StrictTMVar m MockFS- -> StrictTVar m Errors- -> HasFS m HandleMock-simErrorHasFS fsVar errorsVar =- -- TODO: Lenses would be nice for the setters- case Sim.simHasFS fsVar of- hfs@HasFS{..} -> HasFS{- dumpState =- withErr errorsVar (mkFsPath ["<dumpState>"]) dumpState "dumpState"- dumpStateE (\e es -> es { dumpStateE = e })- , hOpen = \p m ->- withErr errorsVar p (hOpen p m) "hOpen"- hOpenE (\e es -> es { hOpenE = e })- , hClose = \h ->- withErr' errorsVar h (hClose h) "hClose"- hCloseE (\e es -> es { hCloseE = e })- , hIsOpen = hIsOpen- , hSeek = \h m n ->- withErr' errorsVar h (hSeek h m n) "hSeek"- hSeekE (\e es -> es { hSeekE = e })- , hGetSome = hGetSome' errorsVar hGetSome- , hGetSomeAt = hGetSomeAt' errorsVar hGetSomeAt- , hPutSome = hPutSome' errorsVar hPutSome- , hTruncate = \h w ->- withErr' errorsVar h (hTruncate h w) "hTruncate"- hTruncateE (\e es -> es { hTruncateE = e })- , hGetSize = \h ->- withErr' errorsVar h (hGetSize h) "hGetSize"- hGetSizeE (\e es -> es { hGetSizeE = e })-- , createDirectory = \p ->- withErr errorsVar p (createDirectory p) "createDirectory"- createDirectoryE (\e es -> es { createDirectoryE = e })- , createDirectoryIfMissing = \b p ->- withErr errorsVar p (createDirectoryIfMissing b p) "createDirectoryIfMissing"- createDirectoryIfMissingE (\e es -> es { createDirectoryIfMissingE = e })- , listDirectory = \p ->- withErr errorsVar p (listDirectory p) "listDirectory"- listDirectoryE (\e es -> es { listDirectoryE = e })- , doesDirectoryExist = \p ->- withErr errorsVar p (doesDirectoryExist p) "doesDirectoryExist"- doesDirectoryExistE (\e es -> es { doesDirectoryExistE = e })- , doesFileExist = \p ->- withErr errorsVar p (doesFileExist p) "doesFileExist"- doesFileExistE (\e es -> es { doesFileExistE = e })- , removeDirectoryRecursive = \p ->- withErr errorsVar p (removeDirectoryRecursive p) "removeFile"- removeDirectoryRecursiveE (\e es -> es { removeDirectoryRecursiveE = e })- , removeFile = \p ->- withErr errorsVar p (removeFile p) "removeFile"- removeFileE (\e es -> es { removeFileE = e })- , renameFile = \p1 p2 ->- withErr errorsVar p1 (renameFile p1 p2) "renameFile"- renameFileE (\e es -> es { renameFileE = e })- , mkFsErrorPath = fsToFsErrorPathUnmounted- , unsafeToFilePath = error "simErrorHasFS: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, PrimMonad m)- => MockFS- -> Errors- -> (StrictTVar m Errors -> HasFS m HandleMock -> m a)- -> m (a, MockFS)-runSimErrorFS mockFS errors action = do- fsVar <- newTMVarIO mockFS- errorsVar <- newTVarIO errors- a <- action errorsVar $ simErrorHasFS fsVar errorsVar- fs' <- atomically $ takeTMVar fsVar- return (a, fs')---- | Execute the next action using the given 'Errors'. After the action is--- finished, the previous 'Errors' are restored.-withErrors :: (MonadSTM m, MonadThrow m) => StrictTVar m Errors -> Errors -> m a -> m a-withErrors errorsVar tempErrors action =- bracket- (atomically $ swapTVar errorsVar tempErrors)- (\originalErrors -> atomically $ swapTVar errorsVar originalErrors)- $ \_ -> action--{-------------------------------------------------------------------------------- Utilities--------------------------------------------------------------------------------}---- | Advance to the next error in the stream of some 'ErrorStream' in the--- 'Errors' stored in the 'StrictTVar'. Extracts the right error stream from--- the state with the @getter@ and stores the advanced error stream in the--- state with the @setter@.-next :: MonadSTM m- => StrictTVar m Errors- -> (Errors -> Stream a) -- ^ @getter@- -> (Stream a -> Errors -> Errors) -- ^ @setter@- -> m (Maybe a)-next errorsVar getter setter = do- atomically $ do- errors <- readTVar errorsVar- let (mb, s') = Stream.runStream (getter errors)- writeTVar errorsVar (setter s' errors)- return mb---- | Execute an action or throw an error, depending on the corresponding--- 'ErrorStream' (see 'nextError').-withErr :: (MonadSTM m, MonadThrow m, HasCallStack)- => StrictTVar m Errors- -> FsPath -- ^ The path for the error, if thrown- -> m a -- ^ Action in case no error is thrown- -> String -- ^ Extra message for in the 'fsErrorString'- -> (Errors -> ErrorStream) -- ^ @getter@- -> (ErrorStream -> Errors -> Errors) -- ^ @setter@- -> m a-withErr errorsVar path action msg getter setter = do- mbErr <- next errorsVar getter setter- case mbErr of- Nothing -> action- Just errType -> throwIO FsError- { fsErrorType = errType- , fsErrorPath = fsToFsErrorPathUnmounted path- , fsErrorString = "simulated error: " <> msg- , fsErrorNo = Nothing- , fsErrorStack = prettyCallStack- , fsLimitation = False- }---- | Variant of 'withErr' that works with 'Handle's.------ The path of the handle is retrieved from the 'MockFS' using 'handleFsPath'.-withErr' :: (MonadSTM m, MonadThrow m, HasCallStack)- => StrictTVar m Errors- -> Handle HandleMock -- ^ The path for the error, if thrown- -> m a -- ^ Action in case no error is thrown- -> String -- ^ Extra message for in the 'fsErrorString'- -> (Errors -> ErrorStream) -- ^ @getter@- -> (ErrorStream -> Errors -> Errors) -- ^ @setter@- -> m a-withErr' errorsVar handle action msg getter setter =- withErr errorsVar (handlePath handle) action msg getter setter---- | Execute the wrapped 'hGetSome', throw an error, or simulate a partial--- read, depending on the corresponding 'ErrorStreamGetSome' (see--- 'nextError').-hGetSome' :: (MonadSTM m, MonadThrow m, HasCallStack)- => StrictTVar m Errors- -> (Handle HandleMock -> Word64 -> m BS.ByteString) -- ^ Wrapped 'hGetSome'- -> Handle HandleMock -> Word64 -> m BS.ByteString-hGetSome' errorsVar hGetSomeWrapped handle n =- next errorsVar hGetSomeE (\e es -> es { hGetSomeE = e }) >>= \case- Nothing -> hGetSomeWrapped handle n- Just (Left errType) -> throwIO FsError- { fsErrorType = errType- , fsErrorPath = fsToFsErrorPathUnmounted $ handlePath handle- , fsErrorString = "simulated error: hGetSome"- , fsErrorNo = Nothing- , fsErrorStack = prettyCallStack- , fsLimitation = False- }- Just (Right partial) ->- hGetSomeWrapped handle (partialiseWord64 partial n)---- | In the thread safe version of 'hGetSome', we simulate exactly the same errors.-hGetSomeAt' :: (MonadSTM m, MonadThrow m, HasCallStack)- => StrictTVar m Errors- -> (Handle HandleMock -> Word64 -> AbsOffset -> m BS.ByteString) -- ^ Wrapped 'hGetSomeAt'- -> Handle HandleMock -> Word64 -> AbsOffset -> m BS.ByteString-hGetSomeAt' errorsVar hGetSomeAtWrapped handle n offset =- next errorsVar hGetSomeAtE (\e es -> es { hGetSomeAtE = e }) >>= \case- Nothing -> hGetSomeAtWrapped handle n offset- Just (Left errType) -> throwIO FsError- { fsErrorType = errType- , fsErrorPath = fsToFsErrorPathUnmounted $ handlePath handle- , fsErrorString = "simulated error: hGetSomeAt"- , fsErrorNo = Nothing- , fsErrorStack = prettyCallStack- , fsLimitation = False- }- Just (Right partial) ->- hGetSomeAtWrapped handle (partialiseWord64 partial n) offset---- | Execute the wrapped 'hPutSome', throw an error and apply possible--- corruption to the blob to write, or simulate a partial write, depending on--- the corresponding 'ErrorStreamPutSome' (see 'nextError').-hPutSome' :: (MonadSTM m, MonadThrow m, HasCallStack)- => StrictTVar m Errors- -> (Handle HandleMock -> BS.ByteString -> m Word64) -- ^ Wrapped 'hPutSome'- -> Handle HandleMock -> BS.ByteString -> m Word64-hPutSome' errorsVar hPutSomeWrapped handle bs =- next errorsVar hPutSomeE (\e es -> es { hPutSomeE = e }) >>= \case- Nothing -> hPutSomeWrapped handle bs- Just (Left (errType, mbCorr)) -> do- for_ mbCorr $ \corr ->- void $ hPutSomeWrapped handle (corruptByteString bs corr)- throwIO FsError- { fsErrorType = errType- , fsErrorPath = fsToFsErrorPathUnmounted $ handlePath handle- , fsErrorString = "simulated error: hPutSome" <> case mbCorr of- Nothing -> ""- Just corr -> " with corruption: " <> show corr- , fsErrorNo = Nothing- , fsErrorStack = prettyCallStack- , fsLimitation = False- }- 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+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE UndecidableInstances #-}++-- | 'HasFS' instance wrapping 'SimFS' that generates errors, suitable for+-- testing error handling.+module System.FS.Sim.Error+ ( -- * Simulate Errors monad+ simErrorHasFS+ , simErrorHasFS'+ , runSimErrorFS+ , withErrors++ -- * Streams+ , ErrorStream+ , ErrorStreamGetSome+ , ErrorStreamPutSome++ -- * Generating partial reads/writes+ , Partial (..)+ , partialiseByteCount+ , partialiseWord64+ , partialiseByteString++ -- * Blob+ , Blob (..)+ , blobFromBS+ , blobToBS++ -- * Generating corruption for 'hPutSome'+ , PutCorruption (..)+ , corruptByteString++ -- * Error streams for 'HasFS'+ , Errors (..)+ , allNull+ , emptyErrors+ , genErrors+ , simpleErrors+ ) where++import Control.Concurrent.Class.MonadSTM.Strict+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+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy.Char8 as LC8+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 SafeWildCards+import System.FS.API+import System.FS.CallStack+import System.FS.Sim.MockFS (HandleMock, MockFS)+import qualified System.FS.Sim.MockFS as MockFS+import qualified System.FS.Sim.STM as Sim+import System.FS.Sim.Stream (Stream)+import qualified System.FS.Sim.Stream as Stream+import System.Posix.Types+import Test.QuickCheck+ ( ASCIIString (..)+ , Arbitrary (..)+ , Gen+ , suchThat+ )+import qualified Test.QuickCheck as QC+import Prelude hiding (null)++{-------------------------------------------------------------------------------+ Streams of errors+-------------------------------------------------------------------------------}++-- | An 'ErrorStream' is a possibly infinite 'Stream' of (@Maybe@)+-- @'FsErrorType'@s.+--+-- 'Nothing' indicates that there is no error.+--+-- Each time the 'ErrorStream' is used (see 'runErrorStream'), the first+-- element ('Nothing' in case the list is empty) is taken from the list and an+-- 'ErrorStream' with the remainder of the list is returned. The first element+-- represents whether an error should be returned or not.+--+-- An 'FsError' consists of a number of fields: 'fsErrorType', a+-- 'fsErrorPath', etc. Only the first fields is interesting. Therefore, we+-- only generate the 'FsErrorType'. The 'FsErrorType' will be used to+-- construct the actual 'FsError'.+type ErrorStream = Stream FsErrorType++-- | 'ErrorStream' for reading bytes from a file: an error or a partial get.+type ErrorStreamGetSome = Stream (Either FsErrorType Partial)++-- | 'ErrorStream' for writing bytes to a file: an error and possibly some+-- corruption, or a partial write.+type ErrorStreamPutSome =+ Stream (Either (FsErrorType, Maybe PutCorruption) Partial)++{-------------------------------------------------------------------------------+ Generating partial reads/writes+-------------------------------------------------------------------------------}++-- | A @'Partial' p@, where @p > 0@, is a number representing how many fewer+-- bytes should be read or written than requested.+newtype Partial = Partial Word64+ deriving Show++instance Arbitrary Partial where+ arbitrary = Partial <$> QC.choose (1, 100)+ shrink (Partial p) =+ [Partial p' | p' <- [1 .. p]]++-- | Given a requested number of bytes to read/write, compute a partial number+-- of bytes to read/write.+--+-- We subtract @p@ from the number of requested bytes. If that would result in 0+-- requested bytes or less, we request 1 byte. If the number of requested bytes+-- was already 0, we can't simulate a partial read so we return 0 again.+partialiseByteCount :: Partial -> ByteCount -> ByteCount+partialiseByteCount (Partial p) c+ | 0 <- c' = c+ | p >= c' = 1+ | otherwise = c - fromIntegral p+ where+ c' = fromIntegral c++-- | Like 'partialiseByteCount', but for 'Word64'.+partialiseWord64 :: Partial -> Word64 -> Word64+partialiseWord64 (Partial p) c+ | 0 <- c = c+ | p >= c = 1+ | otherwise = c - p++-- | Given a bytestring that is requested to be written to disk, use+-- 'partialiseByteCount' to compute a partial bytestring.+partialiseByteString :: Partial -> BS.ByteString -> BS.ByteString+partialiseByteString p bs = BS.take (fromIntegral $ partialiseByteCount p len) bs+ where+ len = fromIntegral (BS.length bs)++{------------------------------------------------------------------------------+ Blob+------------------------------------------------------------------------------}++-- For the custom 'Show' and 'Arbitrary' instances+--+-- A builder of a non-empty bytestring.+newtype Blob = MkBlob {getBlob :: ByteString}+ deriving Show++instance Arbitrary Blob where+ arbitrary = do+ str <- (getASCIIString <$> arbitrary) `suchThat` (not . List.null)+ return $ fromString str+ shrink (MkBlob b) =+ [ fromString s'+ | let s = ASCIIString $ LC8.unpack $ BL.fromStrict b+ , s' <- getASCIIString <$> shrink s+ , not (List.null s')+ ]++blobToBS :: Blob -> ByteString+blobToBS = getBlob++blobFromBS :: ByteString -> Blob+blobFromBS = MkBlob++instance IsString Blob where+ fromString = blobFromBS . C8.pack++{-------------------------------------------------------------------------------+ Generating corruption for hPutSome+-------------------------------------------------------------------------------}++-- | Model possible corruptions that could happen to a 'hPutSome' call.+data PutCorruption+ = -- | The blob to write is substituted with corrupt junk+ SubstituteWithJunk Blob+ | -- | Only perform the write partially+ PartialWrite Partial+ deriving Show++instance Arbitrary PutCorruption where+ arbitrary =+ QC.oneof+ [ SubstituteWithJunk <$> arbitrary+ , PartialWrite <$> arbitrary+ ]+ shrink (SubstituteWithJunk blob) =+ [SubstituteWithJunk blob' | blob' <- shrink blob]+ shrink (PartialWrite partial) =+ [PartialWrite partial' | partial' <- shrink partial]++-- | Apply the 'PutCorruption' to the 'BS.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+-------------------------------------------------------------------------------}++-- | Error streams for the methods of the 'HasFS' type class.+--+-- An 'ErrorStream' is provided for each method of the 'HasFS' type class.+-- This 'ErrorStream' will be used to generate potential errors that will be+-- thrown by the corresponding method.+--+-- For 'hPutSome', an 'ErrorStreamWithCorruption' is provided to simulate+-- corruption.+--+-- An 'Errors' is used in conjunction with 'SimErrorFS', which is a layer on+-- top of 'SimFS' that simulates methods throwing 'FsError's.+data Errors = Errors+ { dumpStateE :: ErrorStream -- TODO remove+ -- Operations on files+ , hOpenE :: ErrorStream+ , hCloseE :: ErrorStream+ , hSeekE :: ErrorStream+ , hGetSomeE :: ErrorStreamGetSome+ , hGetSomeAtE :: ErrorStreamGetSome+ , hPutSomeE :: ErrorStreamPutSome+ , hTruncateE :: ErrorStream+ , hGetSizeE :: ErrorStream+ , -- Operations on directories+ createDirectoryE :: ErrorStream+ , createDirectoryIfMissingE :: ErrorStream+ , listDirectoryE :: ErrorStream+ , doesDirectoryExistE :: ErrorStream+ , doesFileExistE :: ErrorStream+ , 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++-- | Return 'True' if all streams are empty ('null').+allNull :: Errors -> Bool+allNull $(fields 'Errors) =+ and+ [ 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 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+ show $(fields 'Errors) =+ "Errors {" <> intercalate ", " streams <> "}"+ where+ -- \| Show a stream unless it is empty+ s :: Show a => String -> Stream a -> Maybe String+ s fld str+ | Stream.null str = Nothing+ | otherwise = Just $ fld <> " = " <> show str++ streams :: [String]+ streams =+ catMaybes+ [ s "dumpStateE" dumpStateE+ , s "hOpenE" hOpenE+ , s "hCloseE" hCloseE+ , s "hSeekE" hSeekE+ , s "hGetSomeE" hGetSomeE+ , s "hGetSomeAtE" hGetSomeAtE+ , s "hPutSomeE" hPutSomeE+ , s "hTruncateE" hTruncateE+ , s "hGetSizeE" hGetSizeE+ , s "createDirectoryE" createDirectoryE+ , s "createDirectoryIfMissingE" createDirectoryIfMissingE+ , s "listDirectoryE" listDirectoryE+ , s "doesDirectoryExistE" doesDirectoryExistE+ , s "doesFileExistE" doesFileExistE+ , 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+emptyErrors = simpleErrors Stream.empty++-- | Use the given 'ErrorStream' for each field/method. No corruption of+-- 'hPutSome'.+simpleErrors :: ErrorStream -> Errors+simpleErrors es =+ Errors+ { dumpStateE = es+ , hOpenE = es+ , hCloseE = es+ , hSeekE = es+ , hGetSomeE = Left <$> es+ , hGetSomeAtE = Left <$> es+ , hPutSomeE = Left . (,Nothing) <$> es+ , hTruncateE = es+ , hGetSizeE = es+ , createDirectoryE = es+ , createDirectoryIfMissingE = es+ , listDirectoryE = es+ , doesDirectoryExistE = es+ , doesFileExistE = es+ , 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.+--+-- This is needed by the VolatileDB state machine tests, which try to predict+-- what should happen based on the 'Errors', which is too complex sometimes.+genErrors ::+ -- | 'True' -> generate partial writes+ Bool ->+ -- | 'True' -> generate 'SubstituteWithJunk' corruptions+ Bool ->+ Gen Errors+genErrors genPartialWrites genSubstituteWithJunk = do+ let+ -- TODO which errors are possible for these operations below (that+ -- have dummy for now)?+ dummy = streamGen 2 [FsInsufficientPermissions]+ dumpStateE <- dummy+ -- TODO let this one fail:+ let hCloseE = Stream.empty+ hTruncateE <- dummy+ doesDirectoryExistE <- dummy+ doesFileExistE <- dummy+ hOpenE <-+ streamGen+ 1+ [ FsResourceDoesNotExist+ , FsResourceInappropriateType+ , FsResourceAlreadyInUse+ , FsResourceAlreadyExist+ , FsInsufficientPermissions+ , FsTooManyOpenFiles+ ]+ hSeekE <- streamGen 3 [FsReachedEOF]+ hGetSomeE <- commonGetErrors+ hGetSomeAtE <- commonGetErrors+ hPutSomeE <- commonPutErrors+ hGetSizeE <- streamGen 2 [FsResourceDoesNotExist]+ createDirectoryE <-+ streamGen+ 3+ [ FsInsufficientPermissions+ , FsResourceInappropriateType+ , FsResourceAlreadyExist+ ]+ createDirectoryIfMissingE <-+ streamGen+ 3+ [ FsInsufficientPermissions+ , FsResourceInappropriateType+ , FsResourceAlreadyExist+ ]+ listDirectoryE <-+ streamGen+ 3+ [ FsInsufficientPermissions+ , FsResourceInappropriateType+ , FsResourceDoesNotExist+ ]+ removeDirectoryRecursiveE <-+ streamGen+ 3+ [ FsInsufficientPermissions+ , FsResourceAlreadyInUse+ , FsResourceDoesNotExist+ , FsResourceInappropriateType+ ]+ removeFileE <-+ streamGen+ 3+ [ FsInsufficientPermissions+ , FsResourceAlreadyInUse+ , FsResourceDoesNotExist+ , FsResourceInappropriateType+ ]+ 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+ genMaybe' = Stream.genMaybe 2++ streamGen l = Stream.genInfinite . genMaybe' l . QC.elements+ streamGen' l = Stream.genInfinite . 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++ shrink err@($(fields 'Errors))+ | allNull err = []+ | otherwise =+ emptyErrors+ : concatMap+ (filter (not . allNull))+ [ (\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{hGetSomeE = s'}) <$> Stream.shrinkStream hGetSomeE+ , (\s' -> err{hGetSomeAtE = s'}) <$> Stream.shrinkStream hGetSomeAtE+ , (\s' -> err{hPutSomeE = s'}) <$> Stream.shrinkStream hPutSomeE+ , (\s' -> err{hTruncateE = s'}) <$> Stream.shrinkStream hTruncateE+ , (\s' -> err{hGetSizeE = s'}) <$> Stream.shrinkStream hGetSizeE+ , (\s' -> err{createDirectoryE = s'}) <$> Stream.shrinkStream createDirectoryE+ , (\s' -> err{createDirectoryIfMissingE = s'}) <$> Stream.shrinkStream createDirectoryIfMissingE+ , (\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+ , -- 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+ ]++{-------------------------------------------------------------------------------+ Simulate Errors monad+-------------------------------------------------------------------------------}++-- | Alternative to 'simErrorHasFS' that creates 'TVar's internally.+simErrorHasFS' ::+ (MonadSTM m, MonadMask m, PrimMonad m) =>+ MockFS ->+ Errors ->+ m (HasFS m HandleMock)+simErrorHasFS' mockFS errs =+ simErrorHasFS <$> newTMVarIO mockFS <*> newTVarIO errs++-- | Introduce possibility of errors+simErrorHasFS ::+ forall m.+ (MonadSTM m, MonadMask m, PrimMonad m) =>+ StrictTMVar m MockFS ->+ StrictTVar m Errors ->+ HasFS m HandleMock+simErrorHasFS fsVar errorsVar =+ -- TODO: Lenses would be nice for the setters+ case Sim.simHasFS fsVar of+ hfs@HasFS{..} ->+ HasFS+ { dumpState =+ withErr+ errorsVar+ (mkFsPath ["<dumpState>"])+ dumpState+ "dumpState"+ dumpStateE+ (\e es -> es{dumpStateE = e})+ , hOpen = \p m ->+ withErr+ errorsVar+ p+ (hOpen p m)+ "hOpen"+ hOpenE+ (\e es -> es{hOpenE = e})+ , hClose = \h ->+ withErr'+ errorsVar+ h+ (hClose h)+ "hClose"+ hCloseE+ (\e es -> es{hCloseE = e})+ , hIsOpen = hIsOpen+ , hSeek = \h m n ->+ withErr'+ errorsVar+ h+ (hSeek h m n)+ "hSeek"+ hSeekE+ (\e es -> es{hSeekE = e})+ , hGetSome = hGetSome' errorsVar hGetSome+ , hGetSomeAt = hGetSomeAt' errorsVar hGetSomeAt+ , hPutSome = hPutSome' errorsVar hPutSome+ , hTruncate = \h w ->+ withErr'+ errorsVar+ h+ (hTruncate h w)+ "hTruncate"+ hTruncateE+ (\e es -> es{hTruncateE = e})+ , hGetSize = \h ->+ withErr'+ errorsVar+ h+ (hGetSize h)+ "hGetSize"+ hGetSizeE+ (\e es -> es{hGetSizeE = e})+ , createDirectory = \p ->+ withErr+ errorsVar+ p+ (createDirectory p)+ "createDirectory"+ createDirectoryE+ (\e es -> es{createDirectoryE = e})+ , createDirectoryIfMissing = \b p ->+ withErr+ errorsVar+ p+ (createDirectoryIfMissing b p)+ "createDirectoryIfMissing"+ createDirectoryIfMissingE+ (\e es -> es{createDirectoryIfMissingE = e})+ , listDirectory = \p ->+ withErr+ errorsVar+ p+ (listDirectory p)+ "listDirectory"+ listDirectoryE+ (\e es -> es{listDirectoryE = e})+ , doesDirectoryExist = \p ->+ withErr+ errorsVar+ p+ (doesDirectoryExist p)+ "doesDirectoryExist"+ doesDirectoryExistE+ (\e es -> es{doesDirectoryExistE = e})+ , doesFileExist = \p ->+ withErr+ errorsVar+ p+ (doesFileExist p)+ "doesFileExist"+ doesFileExistE+ (\e es -> es{doesFileExistE = e})+ , removeDirectoryRecursive = \p ->+ withErr+ errorsVar+ p+ (removeDirectoryRecursive p)+ "removeFile"+ removeDirectoryRecursiveE+ (\e es -> es{removeDirectoryRecursiveE = e})+ , removeFile = \p ->+ withErr+ errorsVar+ p+ (removeFile p)+ "removeFile"+ removeFileE+ (\e es -> es{removeFileE = e})+ , renameFile = \p1 p2 ->+ withErr+ errorsVar+ p1+ (renameFile p1 p2)+ "renameFile"+ renameFileE+ (\e es -> es{renameFileE = e})+ , mkFsErrorPath = fsToFsErrorPathUnmounted+ , unsafeToFilePath = error "simErrorHasFS: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, MonadMask m, PrimMonad m) =>+ MockFS ->+ Errors ->+ (StrictTVar m Errors -> HasFS m HandleMock -> m a) ->+ m (a, MockFS)+runSimErrorFS mockFS errors action = do+ fsVar <- newTMVarIO mockFS+ errorsVar <- newTVarIO errors+ a <- action errorsVar $ simErrorHasFS fsVar errorsVar+ fs' <- atomically $ takeTMVar fsVar+ return (a, fs')++-- | Execute the next action using the given 'Errors'. After the action is+-- finished, the previous 'Errors' are restored.+withErrors :: (MonadSTM m, MonadThrow m) => StrictTVar m Errors -> Errors -> m a -> m a+withErrors errorsVar tempErrors action =+ bracket+ (atomically $ swapTVar errorsVar tempErrors)+ (\originalErrors -> atomically $ swapTVar errorsVar originalErrors)+ $ \_ -> action++{-------------------------------------------------------------------------------+ Utilities+-------------------------------------------------------------------------------}++-- | Advance to the next error in the stream of some 'ErrorStream' in the+-- 'Errors' stored in the 'StrictTVar'. Extracts the right error stream from+-- the state with the @getter@ and stores the advanced error stream in the+-- state with the @setter@.+next ::+ MonadSTM m =>+ StrictTVar m Errors ->+ -- | @getter@+ (Errors -> Stream a) ->+ -- | @setter@+ (Stream a -> Errors -> Errors) ->+ m (Maybe a)+next errorsVar getter setter = do+ atomically $ do+ errors <- readTVar errorsVar+ let (mb, s') = Stream.runStream (getter errors)+ writeTVar errorsVar (setter s' errors)+ return mb++-- | Execute an action or throw an error, depending on the corresponding+-- 'ErrorStream' (see 'nextError').+withErr ::+ (MonadSTM m, MonadThrow m, HasCallStack) =>+ StrictTVar m Errors ->+ -- | The path for the error, if thrown+ FsPath ->+ -- | Action in case no error is thrown+ m a ->+ -- | Extra message for in the 'fsErrorString'+ String ->+ -- | @getter@+ (Errors -> ErrorStream) ->+ -- | @setter@+ (ErrorStream -> Errors -> Errors) ->+ m a+withErr errorsVar path action msg getter setter = do+ mbErr <- next errorsVar getter setter+ case mbErr of+ Nothing -> action+ Just errType ->+ throwIO+ FsError+ { fsErrorType = errType+ , fsErrorPath = fsToFsErrorPathUnmounted path+ , fsErrorString = "simulated error: " <> msg+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = False+ }++-- | Variant of 'withErr' that works with 'Handle's.+--+-- The path of the handle is retrieved from the 'MockFS' using 'handleFsPath'.+withErr' ::+ (MonadSTM m, MonadThrow m, HasCallStack) =>+ StrictTVar m Errors ->+ -- | The path for the error, if thrown+ Handle HandleMock ->+ -- | Action in case no error is thrown+ m a ->+ -- | Extra message for in the 'fsErrorString'+ String ->+ -- | @getter@+ (Errors -> ErrorStream) ->+ -- | @setter@+ (ErrorStream -> Errors -> Errors) ->+ m a+withErr' errorsVar handle action msg getter setter =+ withErr errorsVar (handlePath handle) action msg getter setter++-- | Execute the wrapped 'hGetSome', throw an error, or simulate a partial+-- read, depending on the corresponding 'ErrorStreamGetSome' (see+-- 'nextError').+hGetSome' ::+ (MonadSTM m, MonadThrow m, HasCallStack) =>+ StrictTVar m Errors ->+ -- | Wrapped 'hGetSome'+ (Handle HandleMock -> Word64 -> m BS.ByteString) ->+ Handle HandleMock ->+ Word64 ->+ m BS.ByteString+hGetSome' errorsVar hGetSomeWrapped handle n =+ next errorsVar hGetSomeE (\e es -> es{hGetSomeE = e}) >>= \case+ Nothing -> hGetSomeWrapped handle n+ Just (Left errType) ->+ throwIO+ FsError+ { fsErrorType = errType+ , fsErrorPath = fsToFsErrorPathUnmounted $ handlePath handle+ , fsErrorString = "simulated error: hGetSome"+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = False+ }+ Just (Right partial) ->+ hGetSomeWrapped handle (partialiseWord64 partial n)++-- | In the thread safe version of 'hGetSome', we simulate exactly the same errors.+hGetSomeAt' ::+ (MonadSTM m, MonadThrow m, HasCallStack) =>+ StrictTVar m Errors ->+ -- | Wrapped 'hGetSomeAt'+ (Handle HandleMock -> Word64 -> AbsOffset -> m BS.ByteString) ->+ Handle HandleMock ->+ Word64 ->+ AbsOffset ->+ m BS.ByteString+hGetSomeAt' errorsVar hGetSomeAtWrapped handle n offset =+ next errorsVar hGetSomeAtE (\e es -> es{hGetSomeAtE = e}) >>= \case+ Nothing -> hGetSomeAtWrapped handle n offset+ Just (Left errType) ->+ throwIO+ FsError+ { fsErrorType = errType+ , fsErrorPath = fsToFsErrorPathUnmounted $ handlePath handle+ , fsErrorString = "simulated error: hGetSomeAt"+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = False+ }+ Just (Right partial) ->+ hGetSomeAtWrapped handle (partialiseWord64 partial n) offset++-- | Execute the wrapped 'hPutSome', throw an error and apply possible+-- corruption to the blob to write, or simulate a partial write, depending on+-- the corresponding 'ErrorStreamPutSome' (see 'nextError').+hPutSome' ::+ (MonadSTM m, MonadThrow m, HasCallStack) =>+ StrictTVar m Errors ->+ -- | Wrapped 'hPutSome'+ (Handle HandleMock -> BS.ByteString -> m Word64) ->+ Handle HandleMock ->+ BS.ByteString ->+ m Word64+hPutSome' errorsVar hPutSomeWrapped handle bs =+ next errorsVar hPutSomeE (\e es -> es{hPutSomeE = e}) >>= \case+ Nothing -> hPutSomeWrapped handle bs+ Just (Left (errType, mbCorr)) -> do+ for_ mbCorr $ \corr ->+ void $ hPutSomeWrapped handle (corruptByteString bs corr)+ throwIO+ FsError+ { fsErrorType = errType+ , fsErrorPath = fsToFsErrorPathUnmounted $ handlePath handle+ , fsErrorString =+ "simulated error: hPutSome" <> case mbCorr of+ Nothing -> ""+ Just corr -> " with corruption: " <> show corr+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = False+ }+ 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
src/System/FS/Sim/FsTree.hs view
@@ -1,9 +1,9 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -- | Internal part of the mock file system@@ -12,17 +12,20 @@ -- -- > import System.FS.Sim.FsTree (FsTree) -- > import qualified System.FS.Sim.FsTree as FS-module System.FS.Sim.FsTree (- -- * FsTree type and indexing functions+module System.FS.Sim.FsTree+ ( -- * FsTree type and indexing functions FsTree (..) , FsTreeError (..) , example+ -- * Construction , empty+ -- * Indexing , getDir , getFile , index+ -- * File system operations , createDirIfMissing , createDirWithParents@@ -31,24 +34,25 @@ , removeFile , renameFile , replace+ -- * Path-listing , find+ -- * Pretty-printing , pretty ) where -import Data.Functor.Const-import Data.List.NonEmpty (NonEmpty (..))-import Data.Map.Strict (Map)+import Data.Functor.Const+import Data.List.NonEmpty (NonEmpty (..))+import Data.Map.Strict (Map) import qualified Data.Map.Strict as M-import Data.Maybe (fromMaybe)-import Data.Text (Text)+import Data.Maybe (fromMaybe)+import Data.Text (Text) import qualified Data.Text as Text-import Data.Tree-import GHC.Generics (Generic)-import GHC.Stack--import System.FS.API.Types+import Data.Tree+import GHC.Generics (Generic)+import GHC.Stack+import System.FS.API.Types {------------------------------------------------------------------------------- FsTree type and general indexing functions@@ -63,125 +67,167 @@ -- | Example example :: Monoid a => FsTree a example =- Folder $ M.fromList [- ("usr", Folder $ M.fromList [- ("local", Folder $ M.fromList [- ("bin", Folder mempty)- ])- ])- , ("var", Folder $ M.fromList [- ("log", Folder mempty)- , ("mail", Folder mempty)- , ("run", Folder mempty)- , ("tmp", Folder $ M.fromList [- ("foo.txt", File mempty)- ])- ])+ Folder $+ M.fromList+ [+ ( "usr"+ , Folder $+ M.fromList+ [+ ( "local"+ , Folder $+ M.fromList+ [ ("bin", Folder mempty)+ ]+ )+ ]+ )+ ,+ ( "var"+ , Folder $+ M.fromList+ [ ("log", Folder mempty)+ , ("mail", Folder mempty)+ , ("run", Folder mempty)+ ,+ ( "tmp"+ , Folder $+ M.fromList+ [ ("foo.txt", File mempty)+ ]+ )+ ]+ ) ] -- | File access error-data FsTreeError =- -- | A path @../a/..@ where @a@ is a file rather than a dir+data FsTreeError+ = -- | A path @../a/..@ where @a@ is a file rather than a dir -- -- We record both the full path and the invalid suffix. FsExpectedDir FsPath (NonEmpty Text)-- -- | A path @../a/..@ where @a@ is a dir rather than a file+ | -- | A path @../a/..@ where @a@ is a dir rather than a file -- -- No suffix is specified (it /must/ be the last part of the file)- | FsExpectedFile FsPath-- -- | A path @../a/..@ or @../a@ where directory or file @a@ is missing+ FsExpectedFile FsPath+ | -- | A path @../a/..@ or @../a@ where directory or file @a@ is missing -- -- We record both the full path and the missing suffix.- | FsMissing FsPath (NonEmpty Text)-- -- | A file was opened with the O_EXCL flag, but it already existed.- | FsExists FsPath- deriving (Show)+ FsMissing FsPath (NonEmpty Text)+ | -- | A file was opened with the O_EXCL flag, but it already existed.+ FsExists FsPath+ deriving Show setFsTreeErrorPath :: FsPath -> FsTreeError -> FsTreeError-setFsTreeErrorPath fp (FsExpectedDir _ suffix) = FsExpectedDir fp suffix-setFsTreeErrorPath fp (FsExpectedFile _) = FsExpectedFile fp-setFsTreeErrorPath fp (FsMissing _ suffix) = FsMissing fp suffix-setFsTreeErrorPath fp (FsExists _) = FsExists fp+setFsTreeErrorPath fp (FsExpectedDir _ suffix) = FsExpectedDir fp suffix+setFsTreeErrorPath fp (FsExpectedFile _) = FsExpectedFile fp+setFsTreeErrorPath fp (FsMissing _ suffix) = FsMissing fp suffix+setFsTreeErrorPath fp (FsExists _) = FsExists fp {------------------------------------------------------------------------------- Altering -------------------------------------------------------------------------------} -- | Most general indexing function-alterF :: forall f a. Functor f- => FsPath -- ^ Path to look for- -> (FsTreeError -> f (Maybe (FsTree a))) -- ^ Action on error- -> (FsTree a -> f (Maybe (FsTree a))) -- ^ Alter the tree when found- -> (FsTree a -> f (FsTree a))+alterF ::+ forall f a.+ Functor f =>+ -- | Path to look for+ FsPath ->+ -- | Action on error+ (FsTreeError -> f (Maybe (FsTree a))) ->+ -- | Alter the tree when found+ (FsTree a -> f (Maybe (FsTree a))) ->+ (FsTree a -> f (FsTree a)) alterF fp onErr f = fmap (fromMaybe empty) . go (fsPathToList fp)- where- go :: [Text] -> FsTree a -> f (Maybe (FsTree a))- go [] t = f t- go (p:ps) (File _) = onErr (FsExpectedDir fp (p :| ps))- go (p:ps) (Folder m) = Just . Folder <$> M.alterF f' p m- where- f' :: Maybe (FsTree a) -> f (Maybe (FsTree a))- f' Nothing = onErr (FsMissing fp (p :| ps))- f' (Just t) = go ps t+ where+ go :: [Text] -> FsTree a -> f (Maybe (FsTree a))+ go [] t = f t+ go (p : ps) (File _) = onErr (FsExpectedDir fp (p :| ps))+ go (p : ps) (Folder m) = Just . Folder <$> M.alterF f' p m+ where+ f' :: Maybe (FsTree a) -> f (Maybe (FsTree a))+ f' Nothing = onErr (FsMissing fp (p :| ps))+ f' (Just t) = go ps t -alterDir :: forall f a. Functor f- => FsPath- -> (FsTreeError -> f (FsTree a)) -- ^ Action on error- -> f (Folder a) -- ^ If directory does not exist- -> (Folder a -> f (Folder a)) -- ^ If directory exists- -> (FsTree a -> f (FsTree a))+alterDir ::+ forall f a.+ Functor f =>+ FsPath ->+ -- | Action on error+ (FsTreeError -> f (FsTree a)) ->+ -- | If directory does not exist+ f (Folder a) ->+ -- | If directory exists+ (Folder a -> f (Folder a)) ->+ (FsTree a -> f (FsTree a)) alterDir p onErr onNotExists onExists =- alterDirMaybe p- (fmap Just . onErr)- (fmap Just onNotExists)- (fmap Just . onExists)+ alterDirMaybe+ p+ (fmap Just . onErr)+ (fmap Just onNotExists)+ (fmap Just . onExists) -- | alterDirMaybe might remove a directory-alterDirMaybe :: forall f a. Functor f- => FsPath- -> (FsTreeError -> f (Maybe (FsTree a))) -- ^ Action on error- -> f (Maybe (Folder a)) -- ^ If directory does not exist- -> (Folder a -> f (Maybe (Folder a))) -- ^ If directory exists- -> (FsTree a -> f (FsTree a))+alterDirMaybe ::+ forall f a.+ Functor f =>+ FsPath ->+ -- | Action on error+ (FsTreeError -> f (Maybe (FsTree a))) ->+ -- | If directory does not exist+ f (Maybe (Folder a)) ->+ -- | If directory exists+ (Folder a -> f (Maybe (Folder a))) ->+ (FsTree a -> f (FsTree a)) alterDirMaybe p onErr onNotExists onExists = alterF p onErr' f- where- onErr' :: FsTreeError -> f (Maybe (FsTree a))- onErr' (FsMissing _ (_ :| [])) = fmap Folder <$> onNotExists- onErr' err = onErr err+ where+ onErr' :: FsTreeError -> f (Maybe (FsTree a))+ onErr' (FsMissing _ (_ :| [])) = fmap Folder <$> onNotExists+ onErr' err = onErr err - f :: FsTree a -> f (Maybe (FsTree a))- f (Folder m) = fmap Folder <$> onExists m- f (File _) = onErr $ FsExpectedDir p (pathLast p :| [])+ f :: FsTree a -> f (Maybe (FsTree a))+ f (Folder m) = fmap Folder <$> onExists m+ f (File _) = onErr $ FsExpectedDir p (pathLast p :| []) -alterFileMaybe :: forall f a. Functor f- => FsPath- -> (FsTreeError -> f (Maybe (FsTree a))) -- ^ Action on error- -> f (Maybe a) -- ^ If file does not exist- -> (a -> f (Maybe a)) -- ^ If file exists- -> (FsTree a -> f (FsTree a))+alterFileMaybe ::+ forall f a.+ Functor f =>+ FsPath ->+ -- | Action on error+ (FsTreeError -> f (Maybe (FsTree a))) ->+ -- | If file does not exist+ f (Maybe a) ->+ -- | If file exists+ (a -> f (Maybe a)) ->+ (FsTree a -> f (FsTree a)) alterFileMaybe p onErr onNotExists onExists = alterF p onErr' f- where- onErr' :: FsTreeError -> f (Maybe (FsTree a))- onErr' (FsMissing _ (_ :| [])) = fmap File <$> onNotExists- onErr' err = onErr err+ where+ onErr' :: FsTreeError -> f (Maybe (FsTree a))+ onErr' (FsMissing _ (_ :| [])) = fmap File <$> onNotExists+ onErr' err = onErr err - f :: FsTree a -> f (Maybe (FsTree a))- f (File a) = fmap File <$> onExists a- f (Folder _) = onErr $ FsExpectedFile p+ f :: FsTree a -> f (Maybe (FsTree a))+ f (File a) = fmap File <$> onExists a+ f (Folder _) = onErr $ FsExpectedFile p -alterFile :: forall f a. Functor f- => FsPath- -> (FsTreeError -> f (FsTree a)) -- ^ Action on error- -> f a -- ^ If file does not exist- -> (a -> f a) -- ^ If file exists- -> (FsTree a -> f (FsTree a))+alterFile ::+ forall f a.+ Functor f =>+ FsPath ->+ -- | Action on error+ (FsTreeError -> f (FsTree a)) ->+ -- | If file does not exist+ f a ->+ -- | If file exists+ (a -> f a) ->+ (FsTree a -> f (FsTree a)) alterFile p onErr onNotExists onExists =- alterFileMaybe p (fmap Just . onErr) (fmap Just onNotExists)- (fmap Just . onExists)-+ alterFileMaybe+ p+ (fmap Just . onErr)+ (fmap Just onNotExists)+ (fmap Just . onExists) {------------------------------------------------------------------------------- Construction@@ -196,16 +242,17 @@ pathLast :: HasCallStack => FsPath -> Text pathLast fp = case fsPathSplit fp of- Nothing -> error "pathLast: empty path"- Just (_, p) -> p+ Nothing -> error "pathLast: empty path"+ Just (_, p) -> p pathInits :: FsPath -> [FsPath] pathInits = reverse . go- where- go :: FsPath -> [FsPath]- go fp = fp : case fsPathSplit fp of- Nothing -> []- Just (fp', _) -> go fp'+ where+ go :: FsPath -> [FsPath]+ go fp =+ fp : case fsPathSplit fp of+ Nothing -> []+ Just (fp', _) -> go fp' {------------------------------------------------------------------------------- Indexing@@ -217,15 +264,15 @@ getFile :: FsPath -> FsTree a -> Either FsTreeError a getFile fp =- getConst . alterFile fp (Const . Left) errNotExist (Const . Right)- where- errNotExist = Const . Left $ FsMissing fp (pathLast fp :| [])+ getConst . alterFile fp (Const . Left) errNotExist (Const . Right)+ where+ errNotExist = Const . Left $ FsMissing fp (pathLast fp :| []) getDir :: FsPath -> FsTree a -> Either FsTreeError (Folder a) getDir fp =- getConst . alterDir fp (Const . Left) errNotExist (Const . Right)- where- errNotExist = Const . Left $ FsMissing fp (pathLast fp :| [])+ getConst . alterDir fp (Const . Left) errNotExist (Const . Right)+ where+ errNotExist = Const . Left $ FsMissing fp (pathLast fp :| []) {------------------------------------------------------------------------------- Specific file system functions@@ -235,26 +282,27 @@ -- 1. It existed already while we were supposed to create it from scratch -- (when passed 'MustBeNew'). -- 2. It did not already exists when we expected to (when passed 'MustExist').-openFile :: Monoid a- => FsPath -> AllowExisting -> FsTree a -> Either FsTreeError (FsTree a)+openFile ::+ Monoid a =>+ FsPath -> AllowExisting -> FsTree a -> Either FsTreeError (FsTree a) openFile fp ex = alterFile fp Left caseDoesNotExist caseAlreadyExist- where- caseAlreadyExist a = case ex of- AllowExisting -> Right a- MustBeNew -> Left (FsExists fp)- MustExist -> Right a+ where+ caseAlreadyExist a = case ex of+ AllowExisting -> Right a+ MustBeNew -> Left (FsExists fp)+ MustExist -> Right a - caseDoesNotExist = case ex of- AllowExisting -> Right mempty- MustBeNew -> Right mempty- MustExist -> Left (FsMissing fp (pathLast fp :| []))+ caseDoesNotExist = case ex of+ AllowExisting -> Right mempty+ MustBeNew -> Right mempty+ MustExist -> Left (FsMissing fp (pathLast fp :| [])) -- | Replace the contents of the specified file (which must exist) replace :: FsPath -> a -> FsTree a -> Either FsTreeError (FsTree a) replace fp new =- alterFile fp Left errNotExist (\_old -> Right new)- where- errNotExist = Left (FsMissing fp (pathLast fp :| []))+ alterFile fp Left errNotExist (\_old -> Right new)+ where+ errNotExist = Left (FsMissing fp (pathLast fp :| [])) -- | Create a directory if it does not already exist createDirIfMissing :: FsPath -> FsTree a -> Either FsTreeError (FsTree a)@@ -263,44 +311,44 @@ -- | Create a directory and its parents if they do not already exist createDirWithParents :: FsPath -> FsTree a -> Either FsTreeError (FsTree a) createDirWithParents fp =- -- Report full path in the error, not the prefix at the point of failure- either (Left . setFsTreeErrorPath fp) Right+ -- Report full path in the error, not the prefix at the point of failure+ either (Left . setFsTreeErrorPath fp) Right . repeatedlyM createDirIfMissing (pathInits fp)- where- repeatedlyM :: Monad m => (a -> b -> m b) -> ([a] -> b -> m b)- repeatedlyM = flip . foldlM' . flip+ where+ repeatedlyM :: Monad m => (a -> b -> m b) -> ([a] -> b -> m b)+ repeatedlyM = flip . foldlM' . flip - foldlM' :: forall m a b. Monad m => (b -> a -> m b) -> b -> [a] -> m b- foldlM' f = go- where- go :: b -> [a] -> m b- go !acc [] = return acc- go !acc (x:xs) = f acc x >>= \acc' -> go acc' xs+ foldlM' :: forall m a b. Monad m => (b -> a -> m b) -> b -> [a] -> m b+ foldlM' f = go+ where+ go :: b -> [a] -> m b+ go !acc [] = return acc+ go !acc (x : xs) = f acc x >>= \acc' -> go acc' xs -- | Remove a directory (which must exist) and its contents removeDirRecursive :: FsPath -> FsTree a -> Either FsTreeError (FsTree a) removeDirRecursive fp =- alterDirMaybe fp Left errNotExist (const (Right Nothing))- where- errNotExist = Left (FsMissing fp (pathLast fp :| []))+ alterDirMaybe fp Left errNotExist (const (Right Nothing))+ where+ errNotExist = Left (FsMissing fp (pathLast fp :| [])) -- | Remove a file (which must exist) removeFile :: FsPath -> FsTree a -> Either FsTreeError (FsTree a) removeFile fp =- alterFileMaybe fp Left errNotExist (const (Right Nothing))- where- errNotExist = Left (FsMissing fp (pathLast fp :| []))+ alterFileMaybe fp Left errNotExist (const (Right Nothing))+ where+ errNotExist = Left (FsMissing fp (pathLast fp :| [])) -- | Rename the file (which must exist) from the first path to the second -- path. If there is already a file at the latter path, it is replaced by the -- new one. renameFile :: FsPath -> FsPath -> FsTree a -> Either FsTreeError (FsTree a) renameFile fpOld fpNew tree = do- oldF <- getFile fpOld tree- -- Remove the old file- tree' <- removeFile fpOld tree- -- Overwrite the new file with the old one- alterFile fpNew Left (Right oldF) (const (Right oldF)) tree'+ oldF <- getFile fpOld tree+ -- Remove the old file+ tree' <- removeFile fpOld tree+ -- Overwrite the new file with the old one+ alterFile fpNew Left (Right oldF) (const (Right oldF)) tree' {------------------------------------------------------------------------------- Path-listing@@ -330,26 +378,28 @@ -- -- If the given file system path does not exist, a (Left FsMissing{}) is -- returned.-find :: forall a . FsPath -> FsTree a -> Either FsTreeError [FsPath]+find :: forall a. FsPath -> FsTree a -> Either FsTreeError [FsPath] find fp fs = fmap (appendStartingDir . findTree) $ getDir fp fs- where- appendStartingDir :: [[Text]] -> [FsPath]- appendStartingDir fps = fmap fsPathFromList- $ fmap (fsPathToList fp <>)- $ []: fps+ where+ appendStartingDir :: [[Text]] -> [FsPath]+ appendStartingDir fps =+ fmap fsPathFromList $+ fmap (fsPathToList fp <>) $+ [] : fps - findTree :: Folder a -> [[Text]]- findTree folder = concat- $ fmap appendFileNameAndFind- $ M.toList folder- where- appendFileNameAndFind :: (Text, FsTree a) -> [[Text]]- appendFileNameAndFind (fileName, t) =- [fileName] : (fmap ([fileName] <>) $ findFsTree t)+ findTree :: Folder a -> [[Text]]+ findTree folder =+ concat $+ fmap appendFileNameAndFind $+ M.toList folder+ where+ appendFileNameAndFind :: (Text, FsTree a) -> [[Text]]+ appendFileNameAndFind (fileName, t) =+ [fileName] : (fmap ([fileName] <>) $ findFsTree t) - findFsTree :: FsTree a -> [[Text]]- findFsTree (File _ ) = []- findFsTree (Folder folder') = findTree folder'+ findFsTree :: FsTree a -> [[Text]]+ findFsTree (File _) = []+ findFsTree (Folder folder') = findTree folder' {------------------------------------------------------------------------------- Pretty-printing@@ -357,17 +407,17 @@ pretty :: forall a. (a -> String) -> FsTree a -> String pretty f = drawTree . fmap renderNode . toTree- where- renderNode :: (Text, Maybe a) -> String- renderNode (fp, Nothing) = Text.unpack fp- renderNode (fp, Just a) = Text.unpack fp ++ ": " ++ f a+ where+ renderNode :: (Text, Maybe a) -> String+ renderNode (fp, Nothing) = Text.unpack fp+ renderNode (fp, Just a) = Text.unpack fp ++ ": " ++ f a -- | Translate to a tree toTree :: FsTree a -> Tree (Text, Maybe a) toTree = \case- File _ -> error "toTree: root must be directory"- Folder m -> Node ("/", Nothing) $ map go (M.toList m)- where- go :: (Text, FsTree a) -> Tree (Text, Maybe a)- go (parent, File a) = Node (parent, Just a) []- go (parent, Folder m) = Node (parent, Nothing) $ map go (M.toList m)+ File _ -> error "toTree: root must be directory"+ Folder m -> Node ("/", Nothing) $ map go (M.toList m)+ where+ go :: (Text, FsTree a) -> Tree (Text, Maybe a)+ go (parent, File a) = Node (parent, Just a) []+ go (parent, Folder m) = Node (parent, Nothing) $ map go (M.toList m)
src/System/FS/Sim/MockFS.hs view
@@ -1,1119 +1,1211 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}---- | Mock file system implementation------ Intended for qualified import------ > import System.FS.Sim.MockFS (MockFS)--- > import qualified System.FS.Sim.MockFS as Mock-module System.FS.Sim.MockFS (- empty- , example- , handleIsOpen- , numOpenHandles- , openHandles- , pretty- -- * Debugging- , dumpState- -- * Operations on files- , hClose- , hGetSize- , hGetSome- , hGetSomeAt- , hIsOpen- , hOpen- , hPutSome- , hSeek- , hTruncate- -- * Operations on directories- , createDirectory- , createDirectoryIfMissing- , doesDirectoryExist- , doesFileExist- , listDirectory- , removeDirectoryRecursive- , removeFile- , renameFile- -- * Exported for the benefit of tests only- , Files- , mockFiles- -- ** opaque- , ClosedHandleState- , FilePtr- , HandleState- , OpenHandleState- -- * opaque- , HandleMock- , MockFS- -- * HasBufFS- , fromBuffer- , intoBuffer- , hGetBufSome- , hGetBufSomeAt- , hPutBufSome- , hPutBufSomeAt- ) where--import Control.Monad (forM, forM_, unless, when)-import Control.Monad.Except (MonadError, throwError)-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-import qualified Data.ByteString.Base16 as B16-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, Word8)-import GHC.Generics (Generic)-import System.Posix.Types (ByteCount)--import System.FS.API (BufferOffset (..))-import System.FS.API.Types-import System.FS.CallStack--import qualified System.FS.Sim.FsTree as FS-import System.FS.Sim.FsTree (FsTree (..), FsTreeError (..))--{-------------------------------------------------------------------------------- Mock FS types--------------------------------------------------------------------------------}--data MockFS = MockFS {- mockFiles :: !Files- , mockHandles :: !(Map HandleMock HandleState)- , mockNextHandle :: !HandleMock- }- deriving (Generic, Show)---- | We store the files as an 'FsTree' of the file contents-type Files = FsTree ByteString---- | A mock handle to a file on disk.------ This is only meaningful when interpreted against a 'MockFS'.-newtype HandleMock = HandleMock Int- deriving stock (Show, Eq, Ord, Generic)- deriving newtype (Enum)---- | Instantiate 'Handle' with the mock handle-type Handle' = Handle HandleMock---- | Mock handle internal state-data HandleState =- HandleOpen !OpenHandleState- | HandleClosed !ClosedHandleState- deriving (Show, Generic)--data OpenHandleState = OpenHandle {- openFilePath :: !FsPath- , openPtr :: !FilePtr- }- deriving (Show, Generic)---- | Check whether the file handle is in write/append mode.-isWriteHandle :: OpenHandleState -> Bool-isWriteHandle OpenHandle{..} = case openPtr of- RW _ True _ -> True- Append -> True- _ -> False---- | File pointer------ This is purely an internal abstraction.-data FilePtr =- -- | Read/write pointer- --- -- We record if we can read and/or write, and the current offset- RW !Bool !Bool !Word64-- -- | Append-only pointer- --- -- Offset is always the end of the file in append mode- | Append- deriving (Show, Generic)--data ClosedHandleState = ClosedHandle {- closedFilePath :: FsPath- }- deriving (Show, Generic)---- | Monads in which we can simulate the file system-type CanSimFS m = (HasCallStack, MonadState MockFS m, MonadError FsError m)--empty :: MockFS-empty = MockFS FS.empty M.empty (HandleMock 0)--example :: MockFS-example = empty { mockFiles = FS.example }--{-------------------------------------------------------------------------------- Auxiliary--------------------------------------------------------------------------------}---- | Return 'True' iff the handle is open.------ Throws an exception if the handle is unknown.-handleIsOpen :: MockFS -> HandleMock -> Bool-handleIsOpen MockFS{..} h =- case M.lookup h mockHandles of- Nothing ->- error "handleIOMode: unknown handle"- Just (HandleOpen OpenHandle{}) -> True- Just (HandleClosed _) -> False--openHandles :: MockFS -> [OpenHandleState]-openHandles MockFS{..} = mapMaybe isOpen $ M.elems mockHandles- where- isOpen :: HandleState -> Maybe OpenHandleState- isOpen (HandleOpen hs) = Just hs- isOpen (HandleClosed _ ) = Nothing---- | A set containing each file path that some open handle refers to.-openFilePaths :: MockFS -> Set FsPath-openFilePaths MockFS{..} = foldMap handleOpenFilePath $ M.elems mockHandles- where- handleOpenFilePath :: HandleState -> Set FsPath- handleOpenFilePath (HandleOpen hs) = S.singleton $ openFilePath hs- handleOpenFilePath (HandleClosed _) = S.empty---- | Number of open handles-numOpenHandles :: MockFS -> Int-numOpenHandles = length . openHandles---- | Updated file pointer------ We lift this out as a separate concept primarily for the benefit of tests.------ See 'hSeek' for limitations.-seekFilePtr :: MonadError FsError m- => MockFS -> Handle' -> SeekMode -> Int64 -> m FilePtr-seekFilePtr MockFS{..} (Handle h _) seekMode o = do- case mockHandles M.! h of- HandleClosed ClosedHandle{..} ->- throwError FsError {- fsErrorType = FsIllegalOperation- , fsErrorPath = fsToFsErrorPathUnmounted closedFilePath- , fsErrorString = "handle closed"- , fsErrorNo = Nothing- , fsErrorStack = prettyCallStack- , fsLimitation = False- }- HandleOpen OpenHandle{..} -> do- file <- checkFsTree $ FS.getFile openFilePath mockFiles- let fsize = fromIntegral (BS.length file) :: Word64- case (openPtr, seekMode, sign64 o) of- (RW r w _cur, AbsoluteSeek, Positive o') -> do- when (o' > fsize) $ throwError (errPastEnd openFilePath)- return $ RW r w o'- (_, AbsoluteSeek, Negative _) ->- throwError $ errNegative openFilePath- (RW r w cur, RelativeSeek, Positive o') -> do- let cur' = cur + o'- when (cur' > fsize) $ throwError (errPastEnd openFilePath)- return $ RW r w cur'- (RW r w cur, RelativeSeek, Negative o') -> do- when (o' > cur) $ throwError (errNegative openFilePath)- let cur' = cur - o'- return $ RW r w cur'- (RW r w _cur, SeekFromEnd, Positive 0) ->- return $ RW r w fsize- (RW _ _ _, SeekFromEnd, Positive _) ->- throwError (errPastEnd openFilePath)- (RW r w _, SeekFromEnd, Negative o') -> do- when (o' > fsize) $ throwError (errNegative openFilePath)- let cur' = fsize - o'- return $ RW r w cur'- (Append, _, _) ->- throwError (errAppend openFilePath)- where- errPastEnd fp = FsError {- fsErrorType = FsInvalidArgument- , fsErrorPath = fsToFsErrorPathUnmounted fp- , fsErrorString = "seek past EOF not supported"- , fsErrorNo = Nothing- , fsErrorStack = prettyCallStack- , fsLimitation = True- }- errAppend fp = FsError {- fsErrorType = FsInvalidArgument- , fsErrorPath = fsToFsErrorPathUnmounted fp- , fsErrorString = "seek in append mode not supported"- , fsErrorNo = Nothing- , fsErrorStack = prettyCallStack- , fsLimitation = True- }- errNegative fp = FsError {- fsErrorType = FsInvalidArgument- , fsErrorPath = fsToFsErrorPathUnmounted fp- , fsErrorString = "seek past beginning of file"- , fsErrorNo = Nothing- , fsErrorStack = prettyCallStack- , fsLimitation = False- }--{-------------------------------------------------------------------------------- Internal utilities for implementing the mock FS--------------------------------------------------------------------------------}---- | Modify the mock file system without a file handle-modifyMockFS :: CanSimFS m- => (MockFS -> m (a, MockFS)) -> m a-modifyMockFS f = do- st <- get- (a, st') <- f st- put st'- return a---- | Access but do not modify the mock file system state without a file handle-readMockFS :: CanSimFS m- => (Files -> m a) -> m a-readMockFS f = modifyMockFS (\fs -> (, fs) <$> f (mockFiles fs))---- | Require a file handle and may modify the mock file system-withHandleModify :: CanSimFS m- => Handle'- -> ( MockFS- -> HandleState- -> m (a, (Files, HandleState))- )- -> m a-withHandleModify (Handle h _) f = do- st <- get- case M.lookup h (mockHandles st) of- Just hs -> do- (a, (fs', hs')) <- f st hs- put $ st { mockHandles = M.insert h hs' (mockHandles st)- , mockFiles = fs'- }- return a- Nothing ->- error "withHandleModify: handle not found"---- | Require a file handle but do not modify the mock file system-withHandleRead :: CanSimFS m- => Handle'- -> ( MockFS- -> HandleState- -> m (a, HandleState)- )- -> m a-withHandleRead h f =- withHandleModify h $ \fs hs ->- second (mockFiles fs, ) <$> f fs hs---- | Require an open file handle to modify the mock file system-withOpenHandleModify :: CanSimFS m- => Handle'- -> ( MockFS- -> OpenHandleState- -> m (a, (Files, OpenHandleState))- )- -> m a-withOpenHandleModify h f =- withHandleModify h $ \fs -> \case- HandleOpen hs ->- second (second HandleOpen) <$> f fs hs- HandleClosed ClosedHandle{..} ->- throwError FsError {- fsErrorType = FsIllegalOperation- , fsErrorPath = fsToFsErrorPathUnmounted closedFilePath- , fsErrorString = "handle closed"- , fsErrorNo = Nothing- , fsErrorStack = prettyCallStack- , fsLimitation = False- }---- | Require an open file handle but do not modify the mock file system-withOpenHandleRead :: CanSimFS m- => Handle'- -> ( MockFS- -> OpenHandleState- -> m (a, OpenHandleState)- )- -> m a-withOpenHandleRead h f =- withHandleRead h $ \fs -> \case- HandleOpen hs ->- second HandleOpen <$> f fs hs- HandleClosed ClosedHandle{..} ->- throwError FsError {- fsErrorType = FsIllegalOperation- , fsErrorPath = fsToFsErrorPathUnmounted closedFilePath- , fsErrorString = "handle closed"- , fsErrorNo = Nothing- , fsErrorStack = prettyCallStack- , fsLimitation = False- }--{-------------------------------------------------------------------------------- Debugging--------------------------------------------------------------------------------}--dumpState :: CanSimFS m => m String-dumpState = pretty <$> get--{-------------------------------------------------------------------------------- Internal auxiliary--------------------------------------------------------------------------------}--checkFsTree' :: (MonadError FsError m, HasCallStack)- => Either FsTreeError a -> m (Either FsPath a)-checkFsTree' = go- where- go (Left (FsExpectedDir fp _)) =- throwError FsError {- fsErrorType = FsResourceInappropriateType- , fsErrorPath = fsToFsErrorPathUnmounted fp- , fsErrorString = "expected directory"- , fsErrorNo = Nothing- , fsErrorStack = prettyCallStack- , fsLimitation = False- }- go (Left (FsExpectedFile fp)) =- throwError FsError {- fsErrorType = FsResourceInappropriateType- , fsErrorPath = fsToFsErrorPathUnmounted fp- , fsErrorString = "expected file"- , fsErrorNo = Nothing- , fsErrorStack = prettyCallStack- , fsLimitation = False- }- go (Left (FsMissing fp _)) =- return (Left fp)- go (Left (FsExists fp)) =- throwError FsError {- fsErrorType = FsResourceAlreadyExist- , fsErrorPath = fsToFsErrorPathUnmounted fp- , fsErrorString = "file exists"- , fsErrorNo = Nothing- , fsErrorStack = prettyCallStack- , fsLimitation = False- }- go (Right a) =- return (Right a)--checkFsTree :: (MonadError FsError m, HasCallStack)- => Either FsTreeError a -> m a-checkFsTree ma = do- ma' <- checkFsTree' ma- case ma' of- Left fp -> throwError FsError {- fsErrorType = FsResourceDoesNotExist- , fsErrorPath = fsToFsErrorPathUnmounted fp- , fsErrorString = "does not exist"- , fsErrorNo = Nothing- , fsErrorStack = prettyCallStack- , fsLimitation = False- }- Right a -> return a--checkDoesNotExist :: (MonadError FsError m, HasCallStack)- => MockFS -> FsPath -> m ()-checkDoesNotExist fs fp = do- exists <- fmap pathExists $ checkFsTree' $ FS.index fp (mockFiles fs)- if exists- then throwError FsError {- fsErrorType = FsResourceAlreadyExist- , fsErrorPath = fsToFsErrorPathUnmounted fp- , fsErrorString = "already exists"- , fsErrorNo = Nothing- , fsErrorStack = prettyCallStack- , fsLimitation = False- }- else return ()- where- pathExists :: Either a b -> Bool- pathExists (Left _) = False- pathExists (Right _) = True--newHandle :: MockFS -> OpenHandleState -> (Handle', MockFS)-newHandle fs hs = (- Handle (mockNextHandle fs) (openFilePath hs)- , fs { mockNextHandle = succ (mockNextHandle fs)- , mockHandles = M.insert (mockNextHandle fs)- (HandleOpen hs)- (mockHandles fs)- }- )--{-------------------------------------------------------------------------------- Operations on files--------------------------------------------------------------------------------}---- | Mock implementation of 'hOpen'.------ NOTE: Differences from Posix:------ * We do not support opening directories.--- * We do not support more than one concurrent writer--- (we do however allow a writer and multiple concurrent readers)--- * We do not support create file on ReadMode.-hOpen :: CanSimFS m => FsPath -> OpenMode -> m Handle'-hOpen fp openMode = do- dirExists <- doesDirectoryExist fp- when dirExists $ throwError FsError {- fsErrorType = FsResourceInappropriateType- , fsErrorPath = fsToFsErrorPathUnmounted fp- , fsErrorString = "hOpen: directories not supported"- , fsErrorNo = Nothing- , fsErrorStack = prettyCallStack- , fsLimitation = True- }- modifyMockFS $ \fs -> do- let alreadyHasWriter =- any (\hs -> openFilePath hs == fp && isWriteHandle hs) $- openHandles fs- when (openMode /= ReadMode && alreadyHasWriter) $- throwError FsError {- fsErrorType = FsInvalidArgument- , fsErrorPath = fsToFsErrorPathUnmounted fp- , fsErrorString = "more than one concurrent writer not supported"- , fsErrorNo = Nothing- , fsErrorStack = prettyCallStack- , fsLimitation = True- }- files' <- checkFsTree $ FS.openFile fp ex (mockFiles fs)- return $ newHandle (fs { mockFiles = files' })- (OpenHandle fp (filePtr openMode))- where- ex :: AllowExisting- ex = allowExisting openMode-- filePtr :: OpenMode -> FilePtr- filePtr ReadMode = RW True False 0- filePtr (WriteMode _) = RW False True 0- filePtr (ReadWriteMode _) = RW True True 0- filePtr (AppendMode _) = Append---- | Mock implementation of 'hClose'-hClose :: CanSimFS m => Handle' -> m ()-hClose h = withHandleRead h $ \_fs -> \case- HandleOpen hs ->- return ((), HandleClosed (ClosedHandle (openFilePath hs)))- HandleClosed hs ->- return ((), HandleClosed hs)---- | Mock implementation of 'hIsOpen'-hIsOpen :: CanSimFS m => Handle' -> m Bool-hIsOpen h = gets (`handleIsOpen` handleRaw h)---- | Mock implementation of 'hSeek'------ NOTE: This is more restricted than the IO version, because seek has some--- odd properties:------ * We do not allow seeking at all on files in append mode--- * We do not allow seeking past the end of the file--- (this means that when using 'IO.SeekFromEnd', the only valid offset is 0)--- * We do /not/ return the new file offset-hSeek :: CanSimFS m- => Handle' -> SeekMode -> Int64 -> m ()-hSeek h seekMode o = withOpenHandleRead h $ \fs hs -> do- openPtr' <- seekFilePtr fs h seekMode o- return ((), hs { openPtr = openPtr' })---- | Get bytes from handle------ NOTE: Unlike real I/O, we disallow 'hGetSome' on a handle in append mode.-hGetSome :: CanSimFS m => Handle' -> Word64 -> m ByteString-hGetSome h 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- return (bs, hs { openPtr = RW True w (o + fromIntegral (BS.length bs)) })- Append -> throwError (errNoReadAccess openFilePath "append")- where- errNoReadAccess fp mode = FsError {- fsErrorType = FsInvalidArgument- , fsErrorPath = fsToFsErrorPathUnmounted fp- , fsErrorString = "cannot hGetSome in " <> mode <> " mode"- , fsErrorNo = Nothing- , fsErrorStack = prettyCallStack- , fsLimitation = True- }---- | Thread safe version of 'hGetSome', which doesn't modify or read the file--- offset.-hGetSomeAt :: CanSimFS m- => Handle'- -> Word64- -> AbsOffset- -> m ByteString-hGetSomeAt h 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")- let bs = BS.take (fromIntegral n) . BS.drop (fromIntegral o') $ file- -- This is the same fsLimitation we get when we seek past the end of- -- EOF, in AbsoluteSeek mode.- when (o' > fsize) $ throwError (errPastEnd openFilePath)- return (bs, hs)- Append -> throwError (errNoReadAccess openFilePath "append")- where- errNoReadAccess fp mode = FsError {- fsErrorType = FsInvalidArgument- , fsErrorPath = fsToFsErrorPathUnmounted fp- , fsErrorString = "cannot hGetSomeAt in " <> mode <> " mode"- , fsErrorNo = Nothing- , fsErrorStack = prettyCallStack- , fsLimitation = True- }-- errPastEnd fp = FsError {- fsErrorType = FsInvalidArgument- , fsErrorPath = fsToFsErrorPathUnmounted fp- , fsErrorString = "hGetSomeAt offset past EOF not supported"- , fsErrorNo = Nothing- , fsErrorStack = prettyCallStack- , fsLimitation = True- }--hPutSome :: CanSimFS m => Handle' -> ByteString -> m Word64-hPutSome h toWrite =- withOpenHandleModify h $ \fs hs@OpenHandle{..} -> do- case openPtr of- RW r w o -> do- unless w $ throwError (errReadOnly openFilePath)- file <- checkFsTree $ FS.getFile openFilePath (mockFiles fs)- 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- file <- checkFsTree $ FS.getFile openFilePath (mockFiles fs)- let file' = file <> toWrite- files' <- checkFsTree $ FS.replace openFilePath file' (mockFiles fs)- return (written, (files', hs))- where- written = toEnum $ BS.length toWrite-- errReadOnly fp = FsError {- fsErrorType = FsInvalidArgument- , fsErrorPath = fsToFsErrorPathUnmounted fp- , fsErrorString = "handle is read-only"- , fsErrorNo = Nothing- , fsErrorStack = prettyCallStack- , fsLimitation = False- }---- | Truncate a file------ NOTE: Differences from Posix:------ * Although this corresponds to Posix @ftruncate@, this can only be used--- to make files /smaller/, not larger.--- * We only support this in append mode. The reason is that Posix--- @ftruncate@ does not modify the file offset, and adds padding with zeroes--- on subsequent writes. This is however not behaviour we want to emulate.--- In append mode however the Posix file offset is not used (and we don't--- even record it at all), appends always happen at the end of the file.-hTruncate :: CanSimFS m => Handle' -> Word64 -> m ()-hTruncate h sz =- withOpenHandleModify h $ \fs hs@OpenHandle{..} -> do- file <- checkFsTree $ FS.getFile openFilePath (mockFiles fs)- ptr' <- case (sz > fromIntegral (BS.length file), openPtr) of- (True, _) ->- throwError FsError {- fsErrorType = FsInvalidArgument- , fsErrorPath = fsToFsErrorPathUnmounted openFilePath- , fsErrorString = "truncate cannot make the file larger"- , fsErrorNo = Nothing- , fsErrorStack = prettyCallStack- , fsLimitation = True- }- (False, RW{}) ->- throwError FsError {- fsErrorType = FsInvalidArgument- , fsErrorPath = fsToFsErrorPathUnmounted openFilePath- , fsErrorString = "truncate only supported in append mode"- , fsErrorNo = Nothing- , fsErrorStack = prettyCallStack- , fsLimitation = True- }- (False, Append) ->- return Append- let file' = BS.take (fromIntegral sz) file- files' <- checkFsTree $ FS.replace openFilePath file' (mockFiles fs)- -- TODO: Don't replace the file pointer (not changed)- return ((), (files', hs { openPtr = ptr' }))---- | Get file size------ NOTE: In the mock implementation this is thread safe, because there can be--- only one writer, so concurrent threads cannot change the size of the file.-hGetSize :: CanSimFS m => Handle' -> m Word64-hGetSize h =- withOpenHandleRead h $ \fs hs@OpenHandle{..} -> do- file <- checkFsTree $ FS.getFile openFilePath (mockFiles fs)- return (fromIntegral (BS.length file), hs)--{-------------------------------------------------------------------------------- Operations on directories--------------------------------------------------------------------------------}--createDirectory :: CanSimFS m => FsPath -> m ()-createDirectory dir = modifyMockFS $ \fs -> do- checkDoesNotExist fs dir- files' <- checkFsTree $ FS.createDirIfMissing dir (mockFiles fs)- return ((), fs { mockFiles = files' })--createDirectoryIfMissing :: CanSimFS m- => Bool -> FsPath -> m ()-createDirectoryIfMissing createParents dir = do- -- Although @createDirectoryIfMissing /a/b/c@ will fail ("inappropriate- -- type") if @b@ is a file (not a directory), for some strange reason it- -- throws "already exists" if @c@ is is a file- fileExists <- doesFileExist dir- if fileExists then- throwError FsError {- fsErrorType = FsResourceAlreadyExist- , fsErrorPath = fsToFsErrorPathUnmounted dir- , fsErrorString = "a file with that name already exists"- , fsErrorNo = Nothing- , fsErrorStack = prettyCallStack- , fsLimitation = False- }- else modifyMockFS $ \fs -> do- files' <- checkFsTree $ go createParents (mockFiles fs)- return ((), fs { mockFiles = files' })- where- go :: Bool -> Files -> Either FsTreeError Files- go True = FS.createDirWithParents dir- go False = FS.createDirIfMissing dir--listDirectory :: CanSimFS m- => FsPath -> m (Set String)-listDirectory fp = readMockFS $- fmap (S.fromList . map Text.unpack . M.keys)- . checkFsTree- . FS.getDir fp---- | Check if directory exists------ It seems real I/O maps what would be "inapproriate device" errors to False.-doesDirectoryExist :: CanSimFS m => FsPath -> m Bool-doesDirectoryExist fp = readMockFS $ \fs ->- return $ case FS.getDir fp fs of- Left _ -> False- Right _ -> True---- | Check if file exists------ See comments for 'doesDirectoryExist'.-doesFileExist :: CanSimFS m => FsPath -> m Bool-doesFileExist fp = readMockFS $ \fs ->- return $ case FS.getFile fp fs of- Left _ -> False- Right _ -> True---- | Remove a directory and its contents------ Same limitations as 'removeFile'.-removeDirectoryRecursive :: CanSimFS m => FsPath -> m ()-removeDirectoryRecursive fp = do- modifyMockFS $ \fs -> do- reachablePaths <- fmap S.fromList $ checkFsTree $ FS.find fp (mockFiles fs)- let openReachablePaths = reachablePaths `S.intersection` openFilePaths fs- case fsPathToList fp of- []- -> throwError FsError {- fsErrorType = FsIllegalOperation- , fsErrorPath = fsToFsErrorPathUnmounted fp- , fsErrorString = "cannot remove the root directory"- , fsErrorNo = Nothing- , fsErrorStack = prettyCallStack- , fsLimitation = True- }- _ | openReachablePaths /= mempty- -> throwError FsError {- fsErrorType = FsIllegalOperation- , fsErrorPath = fsToFsErrorPathUnmounted fp- , fsErrorString = "cannot remove an open file. "- ++ "The following files are reachable from "- ++ show fp- ++ "and are still open: "- ++ show openReachablePaths- , fsErrorNo = Nothing- , fsErrorStack = prettyCallStack- , fsLimitation = True- }- _ -> do- files' <- checkFsTree $ FS.removeDirRecursive fp (mockFiles fs)- return ((), fs { mockFiles = files' })---- | Remove a file------ The behaviour of @unlink@ is to remove the file after all open file handles--- that refer to it are closed. The open file handles referring to the file--- can still be used to write\/read to\/from, while at the same time, the file--- is invisible for all other operations.------ We do not implement this behaviour and consider this a limitation of the--- mock file system, and throw an error when removing a file that still has--- open file handles to it.------ In the state machine tests, removing the root directory may cause the IO--- implementation to throw an 'FsInsufficientPermissions' error, depending on--- the permissions of the temporary directory used to run the tests in. In--- theory it should throw a 'FsResourceInappropriateType' error. To avoid this--- mismatch during testing, we also consider removing the root folder a--- limitation of the mock file system.-removeFile :: CanSimFS m => FsPath -> m ()-removeFile fp =- modifyMockFS $ \fs -> case fsPathToList fp of- []- -> throwError FsError {- fsErrorType = FsIllegalOperation- , fsErrorPath = fsToFsErrorPathUnmounted fp- , fsErrorString = "cannot remove the root directory"- , fsErrorNo = Nothing- , fsErrorStack = prettyCallStack- , fsLimitation = True- }- _ | fp `S.member` openFilePaths fs- -> throwError FsError {- fsErrorType = FsIllegalOperation- , fsErrorPath = fsToFsErrorPathUnmounted fp- , fsErrorString = "cannot remove an open file"- , fsErrorNo = Nothing- , fsErrorStack = prettyCallStack- , fsLimitation = True- }- _ -> do- files' <- checkFsTree $ FS.removeFile fp (mockFiles fs)- return ((), fs { mockFiles = files' })--renameFile :: CanSimFS m => FsPath -> FsPath -> m ()-renameFile fpOld fpNew =- modifyMockFS $ \fs -> if- | not (sameDir fpOld fpNew) ->- throwError $ errDifferentDir fpOld- | fpOld `S.member` openFilePaths fs ->- throwError $ errRenameOpenFile fpOld- | fpNew `S.member` openFilePaths fs ->- throwError $ errRenameOpenFile fpNew- | Right _ <- FS.getDir fpNew (mockFiles fs) ->- throwError $ errRenameDir fpNew- | otherwise -> do- files' <- checkFsTree $ FS.renameFile fpOld fpNew (mockFiles fs)- return ((), fs { mockFiles = files' })- where- sameDir fp1 fp2 =- (fst <$> fsPathSplit fp1) == (fst <$> fsPathSplit fp2)-- errRenameOpenFile fp = FsError {- fsErrorType = FsIllegalOperation- , fsErrorPath = fsToFsErrorPathUnmounted fp- , fsErrorString = "cannot rename opened file"- , fsErrorNo = Nothing- , fsErrorStack = prettyCallStack- , fsLimitation = True- }-- errRenameDir fp = FsError {- fsErrorType = FsResourceInappropriateType- , fsErrorPath = fsToFsErrorPathUnmounted fp- , fsErrorString = "is a directory"- , fsErrorNo = Nothing- , fsErrorStack = prettyCallStack- , fsLimitation = True- }-- errDifferentDir fp = FsError {- fsErrorType = FsIllegalOperation- , fsErrorPath = fsToFsErrorPathUnmounted fp- , fsErrorString = "files must be in the same directory"- , fsErrorNo = Nothing- , fsErrorStack = prettyCallStack- , fsLimitation = True- }--{-------------------------------------------------------------------------------- Pretty-printing--------------------------------------------------------------------------------}---- | Renders the 'MockFS' in a human-readable fashion.-pretty :: MockFS -> String--- TODO: Right now does this not show the state of the handles.-pretty = FS.pretty renderFile . mockFiles- where- renderFile :: ByteString -> String- renderFile = show . hexDump . B16.encode-- hexDump :: ByteString -> ByteString- hexDump = fst- . BS.foldl' (\(acc, n) w8 ->- if n == 2 then (acc <> " " <> BS.singleton w8, 1)- else (acc <> BS.singleton w8, n + 1)- ) (mempty, 0 :: Int)--{-------------------------------------------------------------------------------- Auxiliary--------------------------------------------------------------------------------}--data Sign a = Negative a | Positive a- deriving (Functor)--sign :: (Num a, Ord a) => a -> Sign a-sign a | a < 0 = Negative (negate a)- | otherwise = Positive 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+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}++-- | Mock file system implementation+--+-- Intended for qualified import+--+-- > import System.FS.Sim.MockFS (MockFS)+-- > import qualified System.FS.Sim.MockFS as Mock+module System.FS.Sim.MockFS+ ( empty+ , example+ , handleIsOpen+ , numOpenHandles+ , openHandles+ , pretty++ -- * Debugging+ , dumpState++ -- * Operations on files+ , hClose+ , hGetSize+ , hGetSome+ , hGetSomeAt+ , hIsOpen+ , hOpen+ , hPutSome+ , hSeek+ , hTruncate++ -- * Operations on directories+ , createDirectory+ , createDirectoryIfMissing+ , doesDirectoryExist+ , doesFileExist+ , listDirectory+ , removeDirectoryRecursive+ , removeFile+ , renameFile++ -- * Exported for the benefit of tests only+ , Files+ , mockFiles++ -- ** opaque+ , ClosedHandleState+ , FilePtr+ , HandleState+ , OpenHandleState++ -- * opaque+ , HandleMock+ , MockFS++ -- * HasBufFS+ , fromBuffer+ , intoBuffer+ , hGetBufSome+ , hGetBufSomeAt+ , hPutBufSome+ , hPutBufSomeAt+ ) where++import Control.Monad (forM, forM_, unless, when)+import Control.Monad.Except (MonadError, throwError)+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+import qualified Data.ByteString.Base16 as B16+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, Word8)+import GHC.Generics (Generic)+import System.FS.API (BufferOffset (..))+import System.FS.API.Types+import System.FS.CallStack+import System.FS.Sim.FsTree (FsTree (..), FsTreeError (..))+import qualified System.FS.Sim.FsTree as FS+import System.Posix.Types (ByteCount)++{-------------------------------------------------------------------------------+ Mock FS types+-------------------------------------------------------------------------------}++data MockFS = MockFS+ { mockFiles :: !Files+ , mockHandles :: !(Map HandleMock HandleState)+ , mockNextHandle :: !HandleMock+ }+ deriving (Generic, Show)++-- | We store the files as an 'FsTree' of the file contents+type Files = FsTree ByteString++-- | A mock handle to a file on disk.+--+-- This is only meaningful when interpreted against a 'MockFS'.+newtype HandleMock = HandleMock Int+ deriving stock (Show, Eq, Ord, Generic)+ deriving newtype Enum++-- | Instantiate 'Handle' with the mock handle+type Handle' = Handle HandleMock++-- | Mock handle internal state+data HandleState+ = HandleOpen !OpenHandleState+ | HandleClosed !ClosedHandleState+ deriving (Show, Generic)++data OpenHandleState = OpenHandle+ { openFilePath :: !FsPath+ , openPtr :: !FilePtr+ }+ deriving (Show, Generic)++-- | Check whether the file handle is in write/append mode.+isWriteHandle :: OpenHandleState -> Bool+isWriteHandle OpenHandle{..} = case openPtr of+ RW _ True _ -> True+ Append -> True+ _ -> False++-- | File pointer+--+-- This is purely an internal abstraction.+data FilePtr+ = -- | Read/write pointer+ --+ -- We record if we can read and/or write, and the current offset+ RW !Bool !Bool !Word64+ | -- | Append-only pointer+ --+ -- Offset is always the end of the file in append mode+ Append+ deriving (Show, Generic)++data ClosedHandleState = ClosedHandle+ { closedFilePath :: FsPath+ }+ deriving (Show, Generic)++-- | Monads in which we can simulate the file system+type CanSimFS m = (HasCallStack, MonadState MockFS m, MonadError FsError m)++empty :: MockFS+empty = MockFS FS.empty M.empty (HandleMock 0)++example :: MockFS+example = empty{mockFiles = FS.example}++{-------------------------------------------------------------------------------+ Auxiliary+-------------------------------------------------------------------------------}++-- | Return 'True' iff the handle is open.+--+-- Throws an exception if the handle is unknown.+handleIsOpen :: MockFS -> HandleMock -> Bool+handleIsOpen MockFS{..} h =+ case M.lookup h mockHandles of+ Nothing ->+ error "handleIOMode: unknown handle"+ Just (HandleOpen OpenHandle{}) -> True+ Just (HandleClosed _) -> False++openHandles :: MockFS -> [OpenHandleState]+openHandles MockFS{..} = mapMaybe isOpen $ M.elems mockHandles+ where+ isOpen :: HandleState -> Maybe OpenHandleState+ isOpen (HandleOpen hs) = Just hs+ isOpen (HandleClosed _) = Nothing++-- | A set containing each file path that some open handle refers to.+openFilePaths :: MockFS -> Set FsPath+openFilePaths MockFS{..} = foldMap handleOpenFilePath $ M.elems mockHandles+ where+ handleOpenFilePath :: HandleState -> Set FsPath+ handleOpenFilePath (HandleOpen hs) = S.singleton $ openFilePath hs+ handleOpenFilePath (HandleClosed _) = S.empty++-- | Number of open handles+numOpenHandles :: MockFS -> Int+numOpenHandles = length . openHandles++-- | Updated file pointer+--+-- We lift this out as a separate concept primarily for the benefit of tests.+--+-- See 'hSeek' for limitations.+seekFilePtr ::+ MonadError FsError m =>+ MockFS -> Handle' -> SeekMode -> Int64 -> m FilePtr+seekFilePtr MockFS{..} (Handle h _) seekMode o = do+ case mockHandles M.! h of+ HandleClosed ClosedHandle{..} ->+ throwError+ FsError+ { fsErrorType = FsIllegalOperation+ , fsErrorPath = fsToFsErrorPathUnmounted closedFilePath+ , fsErrorString = "handle closed"+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = False+ }+ HandleOpen OpenHandle{..} -> do+ file <- checkFsTree $ FS.getFile openFilePath mockFiles+ let fsize = fromIntegral (BS.length file) :: Word64+ case (openPtr, seekMode, sign64 o) of+ (RW r w _cur, AbsoluteSeek, Positive o') -> do+ when (o' > fsize) $ throwError (errPastEnd openFilePath)+ return $ RW r w o'+ (_, AbsoluteSeek, Negative _) ->+ throwError $ errNegative openFilePath+ (RW r w cur, RelativeSeek, Positive o') -> do+ let cur' = cur + o'+ when (cur' > fsize) $ throwError (errPastEnd openFilePath)+ return $ RW r w cur'+ (RW r w cur, RelativeSeek, Negative o') -> do+ when (o' > cur) $ throwError (errNegative openFilePath)+ let cur' = cur - o'+ return $ RW r w cur'+ (RW r w _cur, SeekFromEnd, Positive 0) ->+ return $ RW r w fsize+ (RW _ _ _, SeekFromEnd, Positive _) ->+ throwError (errPastEnd openFilePath)+ (RW r w _, SeekFromEnd, Negative o') -> do+ when (o' > fsize) $ throwError (errNegative openFilePath)+ let cur' = fsize - o'+ return $ RW r w cur'+ (Append, _, _) ->+ throwError (errAppend openFilePath)+ where+ errPastEnd fp =+ FsError+ { fsErrorType = FsInvalidArgument+ , fsErrorPath = fsToFsErrorPathUnmounted fp+ , fsErrorString = "seek past EOF not supported"+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = True+ }+ errAppend fp =+ FsError+ { fsErrorType = FsInvalidArgument+ , fsErrorPath = fsToFsErrorPathUnmounted fp+ , fsErrorString = "seek in append mode not supported"+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = True+ }+ errNegative fp =+ FsError+ { fsErrorType = FsInvalidArgument+ , fsErrorPath = fsToFsErrorPathUnmounted fp+ , fsErrorString = "seek past beginning of file"+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = False+ }++{-------------------------------------------------------------------------------+ Internal utilities for implementing the mock FS+-------------------------------------------------------------------------------}++-- | Modify the mock file system without a file handle+modifyMockFS ::+ CanSimFS m =>+ (MockFS -> m (a, MockFS)) -> m a+modifyMockFS f = do+ st <- get+ (a, st') <- f st+ put st'+ return a++-- | Access but do not modify the mock file system state without a file handle+readMockFS ::+ CanSimFS m =>+ (Files -> m a) -> m a+readMockFS f = modifyMockFS (\fs -> (,fs) <$> f (mockFiles fs))++-- | Require a file handle and may modify the mock file system+withHandleModify ::+ CanSimFS m =>+ Handle' ->+ ( MockFS ->+ HandleState ->+ m (a, (Files, HandleState))+ ) ->+ m a+withHandleModify (Handle h _) f = do+ st <- get+ case M.lookup h (mockHandles st) of+ Just hs -> do+ (a, (fs', hs')) <- f st hs+ put $+ st+ { mockHandles = M.insert h hs' (mockHandles st)+ , mockFiles = fs'+ }+ return a+ Nothing ->+ error "withHandleModify: handle not found"++-- | Require a file handle but do not modify the mock file system+withHandleRead ::+ CanSimFS m =>+ Handle' ->+ ( MockFS ->+ HandleState ->+ m (a, HandleState)+ ) ->+ m a+withHandleRead h f =+ withHandleModify h $ \fs hs ->+ second (mockFiles fs,) <$> f fs hs++-- | Require an open file handle to modify the mock file system+withOpenHandleModify ::+ CanSimFS m =>+ Handle' ->+ ( MockFS ->+ OpenHandleState ->+ m (a, (Files, OpenHandleState))+ ) ->+ m a+withOpenHandleModify h f =+ withHandleModify h $ \fs -> \case+ HandleOpen hs ->+ second (second HandleOpen) <$> f fs hs+ HandleClosed ClosedHandle{..} ->+ throwError+ FsError+ { fsErrorType = FsIllegalOperation+ , fsErrorPath = fsToFsErrorPathUnmounted closedFilePath+ , fsErrorString = "handle closed"+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = False+ }++-- | Require an open file handle but do not modify the mock file system+withOpenHandleRead ::+ CanSimFS m =>+ Handle' ->+ ( MockFS ->+ OpenHandleState ->+ m (a, OpenHandleState)+ ) ->+ m a+withOpenHandleRead h f =+ withHandleRead h $ \fs -> \case+ HandleOpen hs ->+ second HandleOpen <$> f fs hs+ HandleClosed ClosedHandle{..} ->+ throwError+ FsError+ { fsErrorType = FsIllegalOperation+ , fsErrorPath = fsToFsErrorPathUnmounted closedFilePath+ , fsErrorString = "handle closed"+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = False+ }++{-------------------------------------------------------------------------------+ Debugging+-------------------------------------------------------------------------------}++dumpState :: CanSimFS m => m String+dumpState = pretty <$> get++{-------------------------------------------------------------------------------+ Internal auxiliary+-------------------------------------------------------------------------------}++checkFsTree' ::+ (MonadError FsError m, HasCallStack) =>+ Either FsTreeError a -> m (Either FsPath a)+checkFsTree' = go+ where+ go (Left (FsExpectedDir fp _)) =+ throwError+ FsError+ { fsErrorType = FsResourceInappropriateType+ , fsErrorPath = fsToFsErrorPathUnmounted fp+ , fsErrorString = "expected directory"+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = False+ }+ go (Left (FsExpectedFile fp)) =+ throwError+ FsError+ { fsErrorType = FsResourceInappropriateType+ , fsErrorPath = fsToFsErrorPathUnmounted fp+ , fsErrorString = "expected file"+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = False+ }+ go (Left (FsMissing fp _)) =+ return (Left fp)+ go (Left (FsExists fp)) =+ throwError+ FsError+ { fsErrorType = FsResourceAlreadyExist+ , fsErrorPath = fsToFsErrorPathUnmounted fp+ , fsErrorString = "file exists"+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = False+ }+ go (Right a) =+ return (Right a)++checkFsTree ::+ (MonadError FsError m, HasCallStack) =>+ Either FsTreeError a -> m a+checkFsTree ma = do+ ma' <- checkFsTree' ma+ case ma' of+ Left fp ->+ throwError+ FsError+ { fsErrorType = FsResourceDoesNotExist+ , fsErrorPath = fsToFsErrorPathUnmounted fp+ , fsErrorString = "does not exist"+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = False+ }+ Right a -> return a++checkDoesNotExist ::+ (MonadError FsError m, HasCallStack) =>+ MockFS -> FsPath -> m ()+checkDoesNotExist fs fp = do+ exists <- fmap pathExists $ checkFsTree' $ FS.index fp (mockFiles fs)+ if exists+ then+ throwError+ FsError+ { fsErrorType = FsResourceAlreadyExist+ , fsErrorPath = fsToFsErrorPathUnmounted fp+ , fsErrorString = "already exists"+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = False+ }+ else return ()+ where+ pathExists :: Either a b -> Bool+ pathExists (Left _) = False+ pathExists (Right _) = True++newHandle :: MockFS -> OpenHandleState -> (Handle', MockFS)+newHandle fs hs =+ ( Handle (mockNextHandle fs) (openFilePath hs)+ , fs+ { mockNextHandle = succ (mockNextHandle fs)+ , mockHandles =+ M.insert+ (mockNextHandle fs)+ (HandleOpen hs)+ (mockHandles fs)+ }+ )++{-------------------------------------------------------------------------------+ Operations on files+-------------------------------------------------------------------------------}++-- | Mock implementation of 'hOpen'.+--+-- NOTE: Differences from Posix:+--+-- * We do not support opening directories.+-- * We do not support more than one concurrent writer+-- (we do however allow a writer and multiple concurrent readers)+-- * We do not support create file on ReadMode.+hOpen :: CanSimFS m => FsPath -> OpenMode -> m Handle'+hOpen fp openMode = do+ dirExists <- doesDirectoryExist fp+ when dirExists $+ throwError+ FsError+ { fsErrorType = FsResourceInappropriateType+ , fsErrorPath = fsToFsErrorPathUnmounted fp+ , fsErrorString = "hOpen: directories not supported"+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = True+ }+ modifyMockFS $ \fs -> do+ let alreadyHasWriter =+ any (\hs -> openFilePath hs == fp && isWriteHandle hs) $+ openHandles fs+ when (openMode /= ReadMode && alreadyHasWriter) $+ throwError+ FsError+ { fsErrorType = FsInvalidArgument+ , fsErrorPath = fsToFsErrorPathUnmounted fp+ , fsErrorString = "more than one concurrent writer not supported"+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = True+ }+ files' <- checkFsTree $ FS.openFile fp ex (mockFiles fs)+ return $+ newHandle+ (fs{mockFiles = files'})+ (OpenHandle fp (filePtr openMode))+ where+ ex :: AllowExisting+ ex = allowExisting openMode++ filePtr :: OpenMode -> FilePtr+ filePtr ReadMode = RW True False 0+ filePtr (WriteMode _) = RW False True 0+ filePtr (ReadWriteMode _) = RW True True 0+ filePtr (AppendMode _) = Append++-- | Mock implementation of 'hClose'+hClose :: CanSimFS m => Handle' -> m ()+hClose h = withHandleRead h $ \_fs -> \case+ HandleOpen hs ->+ return ((), HandleClosed (ClosedHandle (openFilePath hs)))+ HandleClosed hs ->+ return ((), HandleClosed hs)++-- | Mock implementation of 'hIsOpen'+hIsOpen :: CanSimFS m => Handle' -> m Bool+hIsOpen h = gets (`handleIsOpen` handleRaw h)++-- | Mock implementation of 'hSeek'+--+-- NOTE: This is more restricted than the IO version, because seek has some+-- odd properties:+--+-- * We do not allow seeking at all on files in append mode+-- * We do not allow seeking past the end of the file+-- (this means that when using 'IO.SeekFromEnd', the only valid offset is 0)+-- * We do /not/ return the new file offset+hSeek ::+ CanSimFS m =>+ Handle' -> SeekMode -> Int64 -> m ()+hSeek h seekMode o = withOpenHandleRead h $ \fs hs -> do+ openPtr' <- seekFilePtr fs h seekMode o+ return ((), hs{openPtr = openPtr'})++-- | Get bytes from handle+--+-- NOTE: Unlike real I/O, we disallow 'hGetSome' on a handle in append mode.+hGetSome :: CanSimFS m => Handle' -> Word64 -> m ByteString+hGetSome h 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+ return (bs, hs{openPtr = RW True w (o + fromIntegral (BS.length bs))})+ Append -> throwError (errNoReadAccess openFilePath "append")+ where+ errNoReadAccess fp mode =+ FsError+ { fsErrorType = FsInvalidArgument+ , fsErrorPath = fsToFsErrorPathUnmounted fp+ , fsErrorString = "cannot hGetSome in " <> mode <> " mode"+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = True+ }++-- | Thread safe version of 'hGetSome', which doesn't modify or read the file+-- offset.+hGetSomeAt ::+ CanSimFS m =>+ Handle' ->+ Word64 ->+ AbsOffset ->+ m ByteString+hGetSomeAt h 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")+ let bs = BS.take (fromIntegral n) . BS.drop (fromIntegral o') $ file+ -- This is the same fsLimitation we get when we seek past the end of+ -- EOF, in AbsoluteSeek mode.+ when (o' > fsize) $ throwError (errPastEnd openFilePath)+ return (bs, hs)+ Append -> throwError (errNoReadAccess openFilePath "append")+ where+ errNoReadAccess fp mode =+ FsError+ { fsErrorType = FsInvalidArgument+ , fsErrorPath = fsToFsErrorPathUnmounted fp+ , fsErrorString = "cannot hGetSomeAt in " <> mode <> " mode"+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = True+ }++ errPastEnd fp =+ FsError+ { fsErrorType = FsInvalidArgument+ , fsErrorPath = fsToFsErrorPathUnmounted fp+ , fsErrorString = "hGetSomeAt offset past EOF not supported"+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = True+ }++hPutSome :: CanSimFS m => Handle' -> ByteString -> m Word64+hPutSome h toWrite =+ withOpenHandleModify h $ \fs hs@OpenHandle{..} -> do+ case openPtr of+ RW r w o -> do+ unless w $ throwError (errReadOnly openFilePath)+ file <- checkFsTree $ FS.getFile openFilePath (mockFiles fs)+ 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+ file <- checkFsTree $ FS.getFile openFilePath (mockFiles fs)+ let file' = file <> toWrite+ files' <- checkFsTree $ FS.replace openFilePath file' (mockFiles fs)+ return (written, (files', hs))+ where+ written = toEnum $ BS.length toWrite++ errReadOnly fp =+ FsError+ { fsErrorType = FsInvalidArgument+ , fsErrorPath = fsToFsErrorPathUnmounted fp+ , fsErrorString = "handle is read-only"+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = False+ }++-- | Truncate a file+--+-- NOTE: Differences from Posix:+--+-- * Although this corresponds to Posix @ftruncate@, this can only be used+-- to make files /smaller/, not larger.+-- * We only support this in append mode. The reason is that Posix+-- @ftruncate@ does not modify the file offset, and adds padding with zeroes+-- on subsequent writes. This is however not behaviour we want to emulate.+-- In append mode however the Posix file offset is not used (and we don't+-- even record it at all), appends always happen at the end of the file.+hTruncate :: CanSimFS m => Handle' -> Word64 -> m ()+hTruncate h sz =+ withOpenHandleModify h $ \fs hs@OpenHandle{..} -> do+ file <- checkFsTree $ FS.getFile openFilePath (mockFiles fs)+ ptr' <- case (sz > fromIntegral (BS.length file), openPtr) of+ (True, _) ->+ throwError+ FsError+ { fsErrorType = FsInvalidArgument+ , fsErrorPath = fsToFsErrorPathUnmounted openFilePath+ , fsErrorString = "truncate cannot make the file larger"+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = True+ }+ (False, RW{}) ->+ throwError+ FsError+ { fsErrorType = FsInvalidArgument+ , fsErrorPath = fsToFsErrorPathUnmounted openFilePath+ , fsErrorString = "truncate only supported in append mode"+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = True+ }+ (False, Append) ->+ return Append+ let file' = BS.take (fromIntegral sz) file+ files' <- checkFsTree $ FS.replace openFilePath file' (mockFiles fs)+ -- TODO: Don't replace the file pointer (not changed)+ return ((), (files', hs{openPtr = ptr'}))++-- | Get file size+--+-- NOTE: In the mock implementation this is thread safe, because there can be+-- only one writer, so concurrent threads cannot change the size of the file.+hGetSize :: CanSimFS m => Handle' -> m Word64+hGetSize h =+ withOpenHandleRead h $ \fs hs@OpenHandle{..} -> do+ file <- checkFsTree $ FS.getFile openFilePath (mockFiles fs)+ return (fromIntegral (BS.length file), hs)++{-------------------------------------------------------------------------------+ Operations on directories+-------------------------------------------------------------------------------}++createDirectory :: CanSimFS m => FsPath -> m ()+createDirectory dir = modifyMockFS $ \fs -> do+ checkDoesNotExist fs dir+ files' <- checkFsTree $ FS.createDirIfMissing dir (mockFiles fs)+ return ((), fs{mockFiles = files'})++createDirectoryIfMissing ::+ CanSimFS m =>+ Bool -> FsPath -> m ()+createDirectoryIfMissing createParents dir = do+ -- Although @createDirectoryIfMissing /a/b/c@ will fail ("inappropriate+ -- type") if @b@ is a file (not a directory), for some strange reason it+ -- throws "already exists" if @c@ is is a file+ fileExists <- doesFileExist dir+ if fileExists+ then+ throwError+ FsError+ { fsErrorType = FsResourceAlreadyExist+ , fsErrorPath = fsToFsErrorPathUnmounted dir+ , fsErrorString = "a file with that name already exists"+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = False+ }+ else modifyMockFS $ \fs -> do+ files' <- checkFsTree $ go createParents (mockFiles fs)+ return ((), fs{mockFiles = files'})+ where+ go :: Bool -> Files -> Either FsTreeError Files+ go True = FS.createDirWithParents dir+ go False = FS.createDirIfMissing dir++listDirectory ::+ CanSimFS m =>+ FsPath -> m (Set String)+listDirectory fp =+ readMockFS $+ fmap (S.fromList . map Text.unpack . M.keys)+ . checkFsTree+ . FS.getDir fp++-- | Check if directory exists+--+-- It seems real I/O maps what would be "inapproriate device" errors to False.+doesDirectoryExist :: CanSimFS m => FsPath -> m Bool+doesDirectoryExist fp = readMockFS $ \fs ->+ return $ case FS.getDir fp fs of+ Left _ -> False+ Right _ -> True++-- | Check if file exists+--+-- See comments for 'doesDirectoryExist'.+doesFileExist :: CanSimFS m => FsPath -> m Bool+doesFileExist fp = readMockFS $ \fs ->+ return $ case FS.getFile fp fs of+ Left _ -> False+ Right _ -> True++-- | Remove a directory and its contents+--+-- Same limitations as 'removeFile'.+removeDirectoryRecursive :: CanSimFS m => FsPath -> m ()+removeDirectoryRecursive fp = do+ modifyMockFS $ \fs -> do+ reachablePaths <- fmap S.fromList $ checkFsTree $ FS.find fp (mockFiles fs)+ let openReachablePaths = reachablePaths `S.intersection` openFilePaths fs+ case fsPathToList fp of+ [] ->+ throwError+ FsError+ { fsErrorType = FsIllegalOperation+ , fsErrorPath = fsToFsErrorPathUnmounted fp+ , fsErrorString = "cannot remove the root directory"+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = True+ }+ _+ | openReachablePaths /= mempty ->+ throwError+ FsError+ { fsErrorType = FsIllegalOperation+ , fsErrorPath = fsToFsErrorPathUnmounted fp+ , fsErrorString =+ "cannot remove an open file. "+ ++ "The following files are reachable from "+ ++ show fp+ ++ "and are still open: "+ ++ show openReachablePaths+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = True+ }+ _ -> do+ files' <- checkFsTree $ FS.removeDirRecursive fp (mockFiles fs)+ return ((), fs{mockFiles = files'})++-- | Remove a file+--+-- The behaviour of @unlink@ is to remove the file after all open file handles+-- that refer to it are closed. The open file handles referring to the file+-- can still be used to write\/read to\/from, while at the same time, the file+-- is invisible for all other operations.+--+-- We do not implement this behaviour and consider this a limitation of the+-- mock file system, and throw an error when removing a file that still has+-- open file handles to it.+--+-- In the state machine tests, removing the root directory may cause the IO+-- implementation to throw an 'FsInsufficientPermissions' error, depending on+-- the permissions of the temporary directory used to run the tests in. In+-- theory it should throw a 'FsResourceInappropriateType' error. To avoid this+-- mismatch during testing, we also consider removing the root folder a+-- limitation of the mock file system.+removeFile :: CanSimFS m => FsPath -> m ()+removeFile fp =+ modifyMockFS $ \fs -> case fsPathToList fp of+ [] ->+ throwError+ FsError+ { fsErrorType = FsIllegalOperation+ , fsErrorPath = fsToFsErrorPathUnmounted fp+ , fsErrorString = "cannot remove the root directory"+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = True+ }+ _+ | fp `S.member` openFilePaths fs ->+ throwError+ FsError+ { fsErrorType = FsIllegalOperation+ , fsErrorPath = fsToFsErrorPathUnmounted fp+ , fsErrorString = "cannot remove an open file"+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = True+ }+ _ -> do+ files' <- checkFsTree $ FS.removeFile fp (mockFiles fs)+ return ((), fs{mockFiles = files'})++renameFile :: CanSimFS m => FsPath -> FsPath -> m ()+renameFile fpOld fpNew =+ modifyMockFS $ \fs ->+ if+ | not (sameDir fpOld fpNew) ->+ throwError $ errDifferentDir fpOld+ | fpOld `S.member` openFilePaths fs ->+ throwError $ errRenameOpenFile fpOld+ | fpNew `S.member` openFilePaths fs ->+ throwError $ errRenameOpenFile fpNew+ | Right _ <- FS.getDir fpNew (mockFiles fs) ->+ throwError $ errRenameDir fpNew+ | otherwise -> do+ files' <- checkFsTree $ FS.renameFile fpOld fpNew (mockFiles fs)+ return ((), fs{mockFiles = files'})+ where+ sameDir fp1 fp2 =+ (fst <$> fsPathSplit fp1) == (fst <$> fsPathSplit fp2)++ errRenameOpenFile fp =+ FsError+ { fsErrorType = FsIllegalOperation+ , fsErrorPath = fsToFsErrorPathUnmounted fp+ , fsErrorString = "cannot rename opened file"+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = True+ }++ errRenameDir fp =+ FsError+ { fsErrorType = FsResourceInappropriateType+ , fsErrorPath = fsToFsErrorPathUnmounted fp+ , fsErrorString = "is a directory"+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = True+ }++ errDifferentDir fp =+ FsError+ { fsErrorType = FsIllegalOperation+ , fsErrorPath = fsToFsErrorPathUnmounted fp+ , fsErrorString = "files must be in the same directory"+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = True+ }++{-------------------------------------------------------------------------------+ Pretty-printing+-------------------------------------------------------------------------------}++-- | Renders the 'MockFS' in a human-readable fashion.+pretty :: MockFS -> String+-- TODO: Right now does this not show the state of the handles.+pretty = FS.pretty renderFile . mockFiles+ where+ renderFile :: ByteString -> String+ renderFile = show . hexDump . B16.encode++ hexDump :: ByteString -> ByteString+ hexDump =+ fst+ . BS.foldl'+ ( \(acc, n) w8 ->+ if n == 2+ then (acc <> " " <> BS.singleton w8, 1)+ else (acc <> BS.singleton w8, n + 1)+ )+ (mempty, 0 :: Int)++{-------------------------------------------------------------------------------+ Auxiliary+-------------------------------------------------------------------------------}++data Sign a = Negative a | Positive a+ deriving Functor++sign :: (Num a, Ord a) => a -> Sign a+sign a+ | a < 0 = Negative (negate a)+ | otherwise = Positive 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 }
src/System/FS/Sim/Prim.hs view
@@ -1,36 +1,40 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralisedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UnboxedTuples #-}-{-# LANGUAGE UndecidableInstances #-}+{-# 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+module System.FS.Sim.Prim+ ( FSSimT , runFSSimT , primHasMockFS ) where -import Control.Monad.Except-import Control.Monad.Primitive-import Control.Monad.State--import System.FS.API-+import Control.Monad.Except+import Control.Monad.Primitive+import Control.Monad.State+import System.FS.API+import System.FS.Sim.MockFS (MockFS) 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+newtype FSSimT m a = PureSimFS+ { unFSSimT :: StateT MockFS (ExceptT FsError m) a }- deriving newtype ( Functor, Applicative, Monad- , MonadState MockFS, MonadError FsError, PrimMonad )+ 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@@ -49,30 +53,31 @@ -- '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- , hIsOpen = Mock.hIsOpen- , hSeek = Mock.hSeek- , hGetSome = Mock.hGetSome- , hGetSomeAt = Mock.hGetSomeAt- , hPutSome = Mock.hPutSome- , hTruncate = Mock.hTruncate- , hGetSize = Mock.hGetSize- , createDirectory = Mock.createDirectory+primHasMockFS =+ 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+ , listDirectory = Mock.listDirectory+ , doesDirectoryExist = Mock.doesDirectoryExist+ , doesFileExist = Mock.doesFileExist , removeDirectoryRecursive = Mock.removeDirectoryRecursive- , removeFile = Mock.removeFile- , renameFile = Mock.renameFile- , mkFsErrorPath = fsToFsErrorPathUnmounted- , unsafeToFilePath = \_ -> error "pureHasFS:unsafeToFilePath"- -- File I\/O with user-supplied buffers- , hGetBufSome = Mock.hGetBufSome- , hGetBufSomeAt = Mock.hGetBufSomeAt- , hPutBufSome = Mock.hPutBufSome- , hPutBufSomeAt = Mock.hPutBufSomeAt+ , removeFile = Mock.removeFile+ , renameFile = Mock.renameFile+ , mkFsErrorPath = fsToFsErrorPathUnmounted+ , unsafeToFilePath = \_ -> error "pureHasFS:unsafeToFilePath"+ , -- File I\/O with user-supplied buffers+ hGetBufSome = Mock.hGetBufSome+ , hGetBufSomeAt = Mock.hGetBufSomeAt+ , hPutBufSome = Mock.hPutBufSome+ , hPutBufSomeAt = Mock.hPutBufSomeAt }
src/System/FS/Sim/STM.hs view
@@ -1,23 +1,21 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -- | 'HasFS' instance using 'MockFS' stored in an STM variable-module System.FS.Sim.STM (- runSimFS+module System.FS.Sim.STM+ ( runSimFS , simHasFS , simHasFS' ) where -import Control.Concurrent.Class.MonadSTM.Strict-import Control.Monad.Class.MonadThrow-import Control.Monad.Primitive--import System.FS.API-+import Control.Concurrent.Class.MonadSTM.Strict+import Control.Monad.Class.MonadThrow+import Control.Monad.Primitive+import System.FS.API+import System.FS.Sim.MockFS (HandleMock, MockFS) import qualified System.FS.Sim.MockFS as Mock-import System.FS.Sim.MockFS (HandleMock, MockFS)-import System.FS.Sim.Prim+import System.FS.Sim.Prim {------------------------------------------------------------------------------ The simulation-related types@@ -26,73 +24,91 @@ --- | 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, PrimMonad m)- => MockFS- -> (HasFS m HandleMock -> m a)- -> m (a, MockFS)+runSimFS ::+ (MonadSTM m, MonadMask m, PrimMonad m) =>+ MockFS ->+ (HasFS m HandleMock -> m a) ->+ m (a, MockFS) runSimFS fs act = do- var <- newTMVarIO fs- a <- act (simHasFS var)- fs' <- atomically $ takeTMVar var- return (a, fs')+ var <- newTMVarIO fs+ a <- act (simHasFS var)+ fs' <- atomically $ takeTMVar var+ return (a, fs') -- | Alternative to 'simHasFS' that creates 'TVar's internally.-simHasFS' :: (MonadSTM m, MonadThrow m, PrimMonad m)- => MockFS- -> m (HasFS m HandleMock)+simHasFS' ::+ (MonadSTM m, MonadMask m, PrimMonad m) =>+ MockFS ->+ m (HasFS m HandleMock) simHasFS' mockFS = simHasFS <$> newTMVarIO mockFS +-- | Bracket-style helper that holds the MockFS lock for the duration of @f@.+--+-- 'withMockFS' is not interruptible while waiting for the `MockFS` TMVar, but+-- the body @f@ runs with the caller's original masking state restored, matching+-- the behaviour of 'Control.Concurrent.MVar.withMVar'.+withMockFS ::+ (MonadSTM m, MonadMask m) =>+ StrictTMVar m MockFS ->+ (MockFS -> m (MockFS, Either FsError a)) ->+ m a+withMockFS var f = do+ result <- uninterruptibleMask $ \restore -> do+ st <- atomically $ takeTMVar var+ (st', ea) <- restore (f st) `onException` atomically (putTMVar var st)+ atomically $ putTMVar var st'+ pure ea+ either throwIO pure result+ -- | Equip @m@ with a @HasFs@ instance using the mock file system-simHasFS :: forall m. (MonadSTM m, MonadThrow m, PrimMonad m)- => StrictTMVar m MockFS- -> HasFS m HandleMock-simHasFS var = HasFS {- dumpState = sim Mock.dumpState- , hOpen = sim .: Mock.hOpen- , hClose = sim . Mock.hClose- , hIsOpen = sim . Mock.hIsOpen- , hSeek = sim ..: Mock.hSeek- , hGetSome = sim .: Mock.hGetSome- , hGetSomeAt = sim ..: Mock.hGetSomeAt- , hPutSome = sim .: Mock.hPutSome- , hTruncate = sim .: Mock.hTruncate- , hGetSize = sim . Mock.hGetSize- , createDirectory = sim . Mock.createDirectory- , createDirectoryIfMissing = sim .: Mock.createDirectoryIfMissing- , listDirectory = sim . Mock.listDirectory- , doesDirectoryExist = sim . Mock.doesDirectoryExist- , doesFileExist = sim . Mock.doesFileExist- , removeDirectoryRecursive = sim . Mock.removeDirectoryRecursive- , removeFile = sim . Mock.removeFile- , 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+simHasFS ::+ forall m.+ (MonadSTM m, MonadMask m, PrimMonad m) =>+ StrictTMVar m MockFS ->+ HasFS m HandleMock+simHasFS var =+ HasFS+ { dumpState = sim Mock.dumpState+ , hOpen = sim .: Mock.hOpen+ , hClose = sim . Mock.hClose+ , hIsOpen = sim . Mock.hIsOpen+ , hSeek = sim ..: Mock.hSeek+ , hGetSome = sim .: Mock.hGetSome+ , hGetSomeAt = sim ..: Mock.hGetSomeAt+ , hPutSome = sim .: Mock.hPutSome+ , hTruncate = sim .: Mock.hTruncate+ , hGetSize = sim . Mock.hGetSize+ , createDirectory = sim . Mock.createDirectory+ , createDirectoryIfMissing = sim .: Mock.createDirectoryIfMissing+ , listDirectory = sim . Mock.listDirectory+ , doesDirectoryExist = sim . Mock.doesDirectoryExist+ , doesFileExist = sim . Mock.doesFileExist+ , removeDirectoryRecursive = sim . Mock.removeDirectoryRecursive+ , removeFile = sim . Mock.removeFile+ , 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 :: FSSimT m a -> m a- sim m = do- 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+ where+ sim :: FSSimT m a -> m a+ sim m = withMockFS var $ \st ->+ runFSSimT m st >>= \case+ Left e -> pure (st, Left e)+ Right (a, st') -> pure (st', Right a) - (.:) :: (y -> z) -> (x0 -> x1 -> y) -> (x0 -> x1 -> z)- (f .: g) x0 x1 = f (g x0 x1)+ (.:) :: (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 -> 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 -> 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)+ (....:) :: (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)
src/System/FS/Sim/Stream.hs view
@@ -1,27 +1,32 @@-{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE ScopedTypeVariables #-} -- | Finite and infinite streams of @'Maybe' a@s.-module System.FS.Sim.Stream (- -- * Streams+module System.FS.Sim.Stream+ ( -- * Streams Stream (..) , InternalInfo (..)+ -- * Running , runStream , runStreamN , runStreamIndefinitely+ -- * Construction , always , empty , repeating , unsafeMkInfinite , unsafeMkFinite+ -- * Modify , filter+ -- * Query , null , isFinite , isInfinite+ -- * Generation and shrinking , genFinite , genFiniteN@@ -31,42 +36,42 @@ , liftShrinkStream ) where -import Control.Monad (replicateM)-import Prelude hiding (filter, isInfinite, null)-import qualified Prelude+import Control.Monad (replicateM)+import Test.QuickCheck (Gen) import qualified Test.QuickCheck as QC-import Test.QuickCheck (Gen)+import Prelude hiding (filter, isInfinite, null)+import qualified Prelude {------------------------------------------------------------------------------- Streams -------------------------------------------------------------------------------} -- | A stream of @'Maybe' a@s that can be infinite.-data Stream a =- -- | UNSAFE: when constructing, modifying, or accessing the internals of a- -- 'Stream', it is the responsibility of the user to preserve the following- -- invariant:- --- -- INVARIANT: if the stream is marked as 'Infinite', then the internal list- -- should be infinite. If the stream is marked as 'Finite', then the internal- -- list should finite.- --- -- * If the internal list is infinite but marked as 'Finite', then 'QC.shrink'- -- or 'show' on the corresponding stream will diverge.- --- -- * If the internal list is finite but marked as 'Infinite', then 'QC.shrink'- -- on the corresponding stream will degrade to an infinite list of empty- -- streams.- UnsafeStream {- -- | UNSAFE: see 'UnsafeStream' for more information.- --- -- Info about the finiteness of the stream. It is used for 'QC.shrink'ing- -- and the 'Show' instance.- unsafeStreamInternalInfo :: InternalInfo- -- | UNSAFE: see 'UnsafeStream' for more information.- --- -- The internal list underlying the stream.- , unsafeStreamList :: [Maybe a]+data Stream a+ = -- | UNSAFE: when constructing, modifying, or accessing the internals of a+ -- 'Stream', it is the responsibility of the user to preserve the following+ -- invariant:+ --+ -- INVARIANT: if the stream is marked as 'Infinite', then the internal list+ -- should be infinite. If the stream is marked as 'Finite', then the internal+ -- list should finite.+ --+ -- * If the internal list is infinite but marked as 'Finite', then 'QC.shrink'+ -- or 'show' on the corresponding stream will diverge.+ --+ -- * If the internal list is finite but marked as 'Infinite', then 'QC.shrink'+ -- on the corresponding stream will degrade to an infinite list of empty+ -- streams.+ UnsafeStream+ { unsafeStreamInternalInfo :: InternalInfo+ -- ^ UNSAFE: see 'UnsafeStream' for more information.+ --+ -- Info about the finiteness of the stream. It is used for 'QC.shrink'ing+ -- and the 'Show' instance.+ , unsafeStreamList :: [Maybe a]+ -- ^ UNSAFE: see 'UnsafeStream' for more information.+ --+ -- The internal list underlying the stream. } deriving Functor @@ -80,11 +85,12 @@ -- it is infinite. instance Show a => Show (Stream a) where showsPrec n (UnsafeStream info xs) = case info of- Infinite -> ("<infinite stream>" ++)- Finite -> (if n > 10 then ('(':) else id)- . shows xs- . (" ++ ..." ++)- . (if n > 10 then (')':) else id)+ Infinite -> ("<infinite stream>" ++)+ Finite ->+ (if n > 10 then ('(' :) else id)+ . shows xs+ . (" ++ ..." ++)+ . (if n > 10 then (')' :) else id) {------------------------------------------------------------------------------- Running@@ -95,8 +101,8 @@ -- -- Returns 'Nothing' by default if the 'Stream' is empty. runStream :: Stream a -> (Maybe a, Stream a)-runStream s@(UnsafeStream _ [] ) = (Nothing, s)-runStream (UnsafeStream info (a:as)) = (a, UnsafeStream info as)+runStream s@(UnsafeStream _ []) = (Nothing, s)+runStream (UnsafeStream info (a : as)) = (a, UnsafeStream info as) -- | \( O(n) \): like 'runStream', but advancing the stream @n@ times. --@@ -106,8 +112,8 @@ | n <= 0 = ([], s) | otherwise = let (x, s') = runStream s- (xs, s'') = runStreamN (n-1) s'- in (x:xs, s'')+ (xs, s'') = runStreamN (n - 1) s'+ in (x : xs, s'') -- | \( O(\infty) \): like 'runStream', but advancing the stream indefinitely. --@@ -164,16 +170,16 @@ -- be empty. In particular, @'null' ('always' Nothing) /= True@. null :: Stream a -> Bool null (UnsafeStream Finite []) = True-null _ = False+null _ = False -- | Check that the stream is finite isFinite :: Stream a -> Bool-isFinite (UnsafeStream Finite _) = True+isFinite (UnsafeStream Finite _) = True isFinite (UnsafeStream Infinite _) = False -- | Check that the stream is infinite isInfinite :: Stream a -> Bool-isInfinite (UnsafeStream Finite _) = False+isInfinite (UnsafeStream Finite _) = False isInfinite (UnsafeStream Infinite _) = True {-------------------------------------------------------------------------------@@ -194,14 +200,14 @@ -- finiteness. shrinkStream :: Stream a -> [Stream a] shrinkStream (UnsafeStream info xs0) = case info of- Infinite -> UnsafeStream Finite <$> [take n xs0 | n <- map (2^) [0 :: Int ..]]- Finite -> UnsafeStream Finite <$> QC.shrinkList (const []) xs0+ Infinite -> UnsafeStream Finite <$> [take n xs0 | n <- map (2 ^) [0 :: Int ..]]+ Finite -> UnsafeStream Finite <$> QC.shrinkList (const []) xs0 -- | Like 'shrinkStream', but with a custom shrinker for elements of the stream. liftShrinkStream :: (Maybe a -> [Maybe a]) -> Stream a -> [Stream a] liftShrinkStream shrinkOne (UnsafeStream info xs0) = case info of- Infinite -> UnsafeStream Finite <$> [take n xs0 | n <- map (2^) [0 :: Int ..]]- Finite -> UnsafeStream Finite <$> QC.shrinkList shrinkOne xs0+ Infinite -> UnsafeStream Finite <$> [take n xs0 | n <- map (2 ^) [0 :: Int ..]]+ Finite -> UnsafeStream Finite <$> QC.shrinkList shrinkOne xs0 -- | Make a @'Maybe' a@ generator based on an @a@ generator. --@@ -209,30 +215,34 @@ -- with the given @a@ generator (wrapped in a 'Just'). These /likelihoods/ are -- passed to 'QC.frequency'. genMaybe ::- Int -- ^ Likelihood of 'Nothing'- -> Int -- ^ Likelihood of @'Just' a@- -> Gen a- -> Gen (Maybe a)-genMaybe nLi jLi genA = QC.frequency+ -- | Likelihood of 'Nothing'+ Int ->+ -- | Likelihood of @'Just' a@+ Int ->+ Gen a ->+ Gen (Maybe a)+genMaybe nLi jLi genA =+ QC.frequency [ (nLi, return Nothing) , (jLi, Just <$> genA) ] -- | Generate a finite 'Stream' of length @n@. genFiniteN ::- Int -- ^ Requested size of finite stream.- -> Gen (Maybe a)- -> Gen (Stream a)+ -- | Requested size of finite stream.+ Int ->+ Gen (Maybe a) ->+ Gen (Stream a) genFiniteN n gen = UnsafeStream Finite <$> replicateM n gen -- | Generate a sized, finite 'Stream'. genFinite ::- Gen (Maybe a)- -> Gen (Stream a)+ Gen (Maybe a) ->+ Gen (Stream a) genFinite gen = UnsafeStream Finite <$> QC.listOf gen -- | Generate an infinite 'Stream'. genInfinite ::- Gen (Maybe a)- -> Gen (Stream a)+ Gen (Maybe a) ->+ Gen (Stream a) genInfinite gen = UnsafeStream Infinite <$> QC.infiniteListOf gen
test/Main.hs view
@@ -4,12 +4,15 @@ import qualified Test.System.FS.Sim.FsTree import qualified Test.System.FS.Sim.Stream import qualified Test.System.FS.StateMachine-import Test.Tasty+import Test.Tasty main :: IO ()-main = defaultMain $ testGroup "fs-sim-test" [- Test.System.FS.Sim.Error.tests- , Test.System.FS.Sim.FsTree.tests- , Test.System.FS.Sim.Stream.tests- , Test.System.FS.StateMachine.tests- ]+main =+ defaultMain $+ testGroup+ "fs-sim-test"+ [ Test.System.FS.Sim.Error.tests+ , Test.System.FS.Sim.FsTree.tests+ , Test.System.FS.Sim.Stream.tests+ , Test.System.FS.StateMachine.tests+ ]
test/Test/System/FS/Sim/Error.hs view
@@ -2,152 +2,166 @@ module Test.System.FS.Sim.Error (tests) where -import Control.Concurrent.Class.MonadSTM.Strict-import Control.Monad (unless, void)+import Control.Concurrent.Class.MonadSTM.Strict+import Control.Monad (unless, void) import qualified Data.ByteString as BS import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Lazy as LBS-import Data.Primitive (newPinnedByteArray)-import Data.Word-import System.FS.API+import Data.Primitive (newPinnedByteArray)+import Data.Word+import System.FS.API+import System.FS.API.Lazy (hGetExactlyAt) import qualified System.FS.API.Lazy as Lazy-import System.FS.API.Lazy (hGetExactlyAt) import qualified System.FS.API.Strict as Strict-import System.FS.Sim.Error+import System.FS.Sim.Error+import System.FS.Sim.MockFS (HandleMock) import qualified System.FS.Sim.MockFS as MockFS-import System.FS.Sim.MockFS (HandleMock) import qualified System.FS.Sim.Stream as Stream-import Test.Tasty-import Test.Tasty.QuickCheck-import Test.Util-import Test.Util.WithEntryCounter+import Test.Tasty+import Test.Tasty.QuickCheck+import Test.Util+import Test.Util.WithEntryCounter -- For simplicity:+ -- * We always use the full bytestring that is an argument to a property.+ -- * File offsets are always 0.+ -- * Byte counts are always the length of the argument bytestring.+ -- * Offsets into user-supplied buffers are always 0.+ -- * User-supplied buffers are always precisely as large as they need to be. tests :: TestTree-tests = testGroup "Test.System.FS.Sim.Error" [- -- putters- testProperty "propPutterPutsAll hPutSome (expects failure)" $ expectFailure $- let toInput = pure- in propPutterPutsAll hPutSomeC hPutSome toInput+tests =+ testGroup+ "Test.System.FS.Sim.Error"+ [ -- putters+ testProperty "propPutterPutsAll hPutSome (expects failure)" $+ expectFailure $+ let toInput = pure+ in propPutterPutsAll hPutSomeC hPutSome toInput , testProperty "propPutterPutsAll Strict.hPutAllStrict" $ let toInput = pure- in propPutterPutsAll hPutSomeC Strict.hPutAllStrict toInput+ in propPutterPutsAll hPutSomeC Strict.hPutAllStrict toInput , testProperty "propPutterPutsAll Lazy.hPutAll" $ let toInput = pure . LBS.fromStrict- in propPutterPutsAll hPutSomeC Lazy.hPutAll toInput+ in propPutterPutsAll hPutSomeC Lazy.hPutAll toInput , testProperty "propPutterPutsAll Lazy.hPut" $ let toInput = pure . BB.byteString- in propPutterPutsAll hPutSomeC Lazy.hPut toInput+ in propPutterPutsAll hPutSomeC Lazy.hPut toInput , testProperty "propPutterPutsAll hPutBufSome (expects failure)" $ expectFailure $ \p bs ->- let put hfs h mba = fromIntegral <$>- hPutBufSome hfs h mba 0 (fromIntegral $ BS.length bs)+ let put hfs h mba =+ fromIntegral+ <$> hPutBufSome hfs h mba 0 (fromIntegral $ BS.length bs) toInput _ = do- mba <- newPinnedByteArray (BS.length bs)- success <- MockFS.intoBuffer mba 0 bs- unless success $ error "toInput: should not fail"- pure mba- in propPutterPutsAll hPutBufSomeC put toInput p bs+ mba <- newPinnedByteArray (BS.length bs)+ success <- MockFS.intoBuffer mba 0 bs+ unless success $ error "toInput: should not fail"+ pure mba+ in propPutterPutsAll hPutBufSomeC put toInput p bs , testProperty "propPutterPutsAll hPutBufSomeAt (expects failure)" $ expectFailure $ \p bs ->- let put hfs h mba = fromIntegral <$>- hPutBufSomeAt hfs h mba 0 (fromIntegral $ BS.length bs) 0+ let put hfs h mba =+ fromIntegral+ <$> hPutBufSomeAt hfs h mba 0 (fromIntegral $ BS.length bs) 0 toInput _ = do- mba <- newPinnedByteArray (BS.length bs)- success <- MockFS.intoBuffer mba 0 bs- unless success $ error "toInput: should not fail"- pure mba- in propPutterPutsAll hPutBufSomeAtC put toInput p bs+ mba <- newPinnedByteArray (BS.length bs)+ success <- MockFS.intoBuffer mba 0 bs+ unless success $ error "toInput: should not fail"+ pure mba+ in propPutterPutsAll hPutBufSomeAtC put toInput p bs , testProperty "propPutterPutsAll hPutBufAll" $ \p bs ->- let put hfs h mba = fromIntegral <$>- hPutBufExactly hfs h mba 0 (fromIntegral $ BS.length bs)+ let put hfs h mba =+ fromIntegral+ <$> hPutBufExactly hfs h mba 0 (fromIntegral $ BS.length bs) toInput _ = do- mba <- newPinnedByteArray (BS.length bs)- success <- MockFS.intoBuffer mba 0 bs- unless success $ error "toInput: should not fail"- pure mba- in propPutterPutsAll hPutBufSomeC put toInput p bs+ mba <- newPinnedByteArray (BS.length bs)+ success <- MockFS.intoBuffer mba 0 bs+ unless success $ error "toInput: should not fail"+ pure mba+ in propPutterPutsAll hPutBufSomeC put toInput p bs , testProperty "propPutterPutsAll hPutBufAllAt" $ \p bs ->- let put hfs h mba = fromIntegral <$>- hPutBufExactlyAt hfs h mba 0 (fromIntegral $ BS.length bs) 0+ let put hfs h mba =+ fromIntegral+ <$> hPutBufExactlyAt hfs h mba 0 (fromIntegral $ BS.length bs) 0 toInput _ = do- mba <- newPinnedByteArray (BS.length bs)- success <- MockFS.intoBuffer mba 0 bs- unless success $ error "toInput: should not fail"- pure mba- in propPutterPutsAll hPutBufSomeAtC put toInput p bs- -- getters- , testProperty "propGetterGetsAll hGetSome (expect failure)" $ expectFailure $ \p bs ->- let get hfs h = hGetSome hfs h (fromIntegral $ BS.length bs)+ mba <- newPinnedByteArray (BS.length bs)+ success <- MockFS.intoBuffer mba 0 bs+ unless success $ error "toInput: should not fail"+ pure mba+ in propPutterPutsAll hPutBufSomeAtC put toInput p bs+ , -- getters+ testProperty "propGetterGetsAll hGetSome (expect failure)" $ expectFailure $ \p bs ->+ let get hfs h = hGetSome hfs h (fromIntegral $ BS.length bs) fromOutput = pure- in propGetterGetsAll hGetSomeC get fromOutput p bs+ in propGetterGetsAll hGetSomeC get fromOutput p bs , testProperty "propGetterGetsAll hGetSomeAt (expect failure)" $ expectFailure $ \p bs ->- let get hfs h = hGetSomeAt hfs h (fromIntegral $ BS.length bs) 0+ let get hfs h = hGetSomeAt hfs h (fromIntegral $ BS.length bs) 0 fromOutput = pure- in propGetterGetsAll hGetSomeC get fromOutput p bs+ in propGetterGetsAll hGetSomeC get fromOutput p bs , testProperty "propGetterGetsAll Lazy.hGetExactly" $ \p bs ->- let get hfs h = Lazy.hGetExactly hfs h (fromIntegral $ BS.length bs)+ let get hfs h = Lazy.hGetExactly hfs h (fromIntegral $ BS.length bs) fromOutput = pure . LBS.toStrict- in propGetterGetsAll hGetSomeC get fromOutput p bs+ in propGetterGetsAll hGetSomeC get fromOutput p bs , testProperty "propGetterGetsAll Lazy.hGetExactlyAt" $ \p bs ->- let get hfs h = Lazy.hGetExactlyAt hfs h (fromIntegral $ BS.length bs) 0+ let get hfs h = Lazy.hGetExactlyAt hfs h (fromIntegral $ BS.length bs) 0 fromOutput = pure . LBS.toStrict- in propGetterGetsAll hGetSomeAtC get fromOutput p bs+ in propGetterGetsAll hGetSomeAtC get fromOutput p bs , testProperty "propGetterGetsAll Lazy.hGetAll" $ \p bs ->- let get = Lazy.hGetAll+ let get = Lazy.hGetAll fromOutput = pure . LBS.toStrict- in propGetterGetsAll hGetSomeC get fromOutput p bs+ in propGetterGetsAll hGetSomeC get fromOutput p bs , testProperty "propGetterGetsAll Lazy.hGetAllAt" $ \p bs ->- let get hfs h = Lazy.hGetAllAt hfs h 0+ let get hfs h = Lazy.hGetAllAt hfs h 0 fromOutput = pure . LBS.toStrict- in propGetterGetsAll hGetSomeAtC get fromOutput p bs+ in propGetterGetsAll hGetSomeAtC get fromOutput p bs , testProperty "propGetterGetsAll hGetBufSome (expects failure)" $ expectFailure $ \p bs -> let get hfs h = do- mba <- newPinnedByteArray (BS.length bs)- void $ hGetBufSome hfs h mba 0 (fromIntegral $ BS.length bs)- pure mba+ mba <- newPinnedByteArray (BS.length bs)+ void $ hGetBufSome hfs h mba 0 (fromIntegral $ BS.length bs)+ pure mba fromOutput mba = do- MockFS.fromBuffer mba 0 (fromIntegral $ BS.length bs) >>=- maybe (error "fromOutput: should not fail") pure- in propGetterGetsAll hGetBufSomeC get fromOutput p bs+ MockFS.fromBuffer mba 0 (fromIntegral $ BS.length bs)+ >>= maybe (error "fromOutput: should not fail") pure+ in propGetterGetsAll hGetBufSomeC get fromOutput p bs , testProperty "propGetterGetsAll hGetBufSomeAt (expects failure)" $ expectFailure $ \p bs -> let get hfs h = do- mba <- newPinnedByteArray (BS.length bs)- void $ hGetBufSomeAt hfs h mba 0 (fromIntegral $ BS.length bs) 0- pure mba+ mba <- newPinnedByteArray (BS.length bs)+ void $ hGetBufSomeAt hfs h mba 0 (fromIntegral $ BS.length bs) 0+ pure mba fromOutput mba = do- MockFS.fromBuffer mba 0 (fromIntegral $ BS.length bs) >>=- maybe (error "fromOutput: should not fail") pure- in propGetterGetsAll hGetBufSomeAtC get fromOutput p bs+ MockFS.fromBuffer mba 0 (fromIntegral $ BS.length bs)+ >>= maybe (error "fromOutput: should not fail") pure+ in propGetterGetsAll hGetBufSomeAtC get fromOutput p bs , testProperty "propGetterGetsAll hGetBufExactly" $ \p bs -> let get hfs h = do- mba <- newPinnedByteArray (BS.length bs)- void $ hGetBufExactly hfs h mba 0 (fromIntegral $ BS.length bs)- pure mba+ mba <- newPinnedByteArray (BS.length bs)+ void $ hGetBufExactly hfs h mba 0 (fromIntegral $ BS.length bs)+ pure mba fromOutput mba = do- MockFS.fromBuffer mba 0 (fromIntegral $ BS.length bs) >>=- maybe (error "fromOutput: should not fail") pure- in propGetterGetsAll hGetBufSomeC get fromOutput p bs+ MockFS.fromBuffer mba 0 (fromIntegral $ BS.length bs)+ >>= maybe (error "fromOutput: should not fail") pure+ in propGetterGetsAll hGetBufSomeC get fromOutput p bs , testProperty "propGetterGetsAll hGetBufExactlyAt" $ \p bs -> let get hfs h = do- mba <- newPinnedByteArray (BS.length bs)- void $ hGetBufExactlyAt hfs h mba 0 (fromIntegral $ BS.length bs) 0- pure mba+ mba <- newPinnedByteArray (BS.length bs)+ void $ hGetBufExactlyAt hfs h mba 0 (fromIntegral $ BS.length bs) 0+ pure mba fromOutput mba = do- MockFS.fromBuffer mba 0 (fromIntegral $ BS.length bs) >>=- maybe (error "fromOutput: should not fail") pure- in propGetterGetsAll hGetBufSomeAtC get fromOutput p bs-- -- Generators and shrinkers+ MockFS.fromBuffer mba 0 (fromIntegral $ BS.length bs)+ >>= maybe (error "fromOutput: should not fail") pure+ in propGetterGetsAll hGetBufSomeAtC get fromOutput p bs+ , -- Generators and shrinkers - , testProperty "prop_regression_shrinkErrors"+ testProperty+ "prop_regression_shrinkErrors" prop_regression_shrinkErrors- , testProperty "prop_regression_shrinkNonEmptyErrors"+ , testProperty+ "prop_regression_shrinkNonEmptyErrors" prop_regression_shrinkNonEmptyErrors- , testProperty "prop_regression_shrinkEmptyErrors"+ , testProperty+ "prop_regression_shrinkEmptyErrors" prop_regression_shrinkEmptyErrors ] @@ -159,46 +173,49 @@ Read functions get all requested bytes -------------------------------------------------------------------------------} -newtype SometimesPartialWrites = SometimesPartialWrites {- getSometimesPartialWrites :: ErrorStreamPutSome+newtype SometimesPartialWrites = SometimesPartialWrites+ { getSometimesPartialWrites :: ErrorStreamPutSome } deriving Show instance Arbitrary SometimesPartialWrites where arbitrary = SometimesPartialWrites <$> Stream.genInfinite (fmap Right <$> (arbitrary :: Gen (Maybe Partial)))- shrink = fmap SometimesPartialWrites . Stream.shrinkStream . getSometimesPartialWrites+ shrink = fmap SometimesPartialWrites . Stream.shrinkStream . getSometimesPartialWrites type GetCounter = EntryCounters (StrictTVar IO) -> StrictTVar IO Word64 type PutFunction input = HasFS IO HandleMock -> Handle HandleMock -> input -> IO Word64 type ToInput input = BS.ByteString -> IO input propPutterPutsAll ::- GetCounter- -> PutFunction input- -> ToInput input- -> SometimesPartialWrites- -> BS.ByteString- -> Property+ GetCounter ->+ PutFunction input ->+ ToInput input ->+ SometimesPartialWrites ->+ BS.ByteString ->+ Property propPutterPutsAll getCounter put toInput (SometimesPartialWrites errStream) bs =- ioProperty $ do- fsVar <- newTMVarIO MockFS.empty- errVar <- newTVarIO onlyPutErrors- counters <- zeroEntryCounters- let hfs = withEntryCounters counters $ simErrorHasFS fsVar errVar- withFile hfs (mkFsPath ["file1"]) (ReadWriteMode MustBeNew) $ \h -> do- inp <- toInput bs- n' <- put hfs h inp- let n = fromIntegral $ BS.length bs- bs' <- LBS.toStrict <$> hGetExactlyAt hfs h n 0- putN <- readTVarIO (getCounter counters)- pure $ checkCoverage- $ tabulate "number of writes (>1 indicates partial writes)"- [showPowersOf 2 $ fromIntegral putN]- . cover 0.60 (putN > 1) "At least one partial write"- $ n === n' .&&. bs === bs'- where- onlyPutErrors = emptyErrors {- hPutSomeE = errStream+ ioProperty $ do+ fsVar <- newTMVarIO MockFS.empty+ errVar <- newTVarIO onlyPutErrors+ counters <- zeroEntryCounters+ let hfs = withEntryCounters counters $ simErrorHasFS fsVar errVar+ withFile hfs (mkFsPath ["file1"]) (ReadWriteMode MustBeNew) $ \h -> do+ inp <- toInput bs+ n' <- put hfs h inp+ let n = fromIntegral $ BS.length bs+ bs' <- LBS.toStrict <$> hGetExactlyAt hfs h n 0+ putN <- readTVarIO (getCounter counters)+ pure+ $ checkCoverage+ $ tabulate+ "number of writes (>1 indicates partial writes)"+ [showPowersOf 2 $ fromIntegral putN]+ . cover 0.60 (putN > 1) "At least one partial write"+ $ n === n' .&&. bs === bs'+ where+ onlyPutErrors =+ emptyErrors+ { hPutSomeE = errStream , hPutBufSomeE = errStream , hPutBufSomeAtE = errStream }@@ -207,46 +224,49 @@ Write functions put all requested bytes -------------------------------------------------------------------------------} -newtype SometimesPartialReads = SometimesPartialReads {- getSometimesPartialReads :: ErrorStreamGetSome+newtype SometimesPartialReads = SometimesPartialReads+ { getSometimesPartialReads :: ErrorStreamGetSome } deriving Show instance Arbitrary SometimesPartialReads where arbitrary = SometimesPartialReads <$> Stream.genInfinite (fmap Right <$> (arbitrary :: Gen (Maybe Partial)))- shrink = fmap SometimesPartialReads . Stream.shrinkStream . getSometimesPartialReads+ shrink = fmap SometimesPartialReads . Stream.shrinkStream . getSometimesPartialReads type GetFunction output = HasFS IO HandleMock -> Handle HandleMock -> IO output type FromOutput output = output -> IO BS.ByteString propGetterGetsAll ::- GetCounter- -> GetFunction output- -> FromOutput output- -> SometimesPartialReads- -> BS.ByteString- -> Property+ GetCounter ->+ GetFunction output ->+ FromOutput output ->+ SometimesPartialReads ->+ BS.ByteString ->+ Property propGetterGetsAll getCounter get fromOutput (SometimesPartialReads errStream) bs =- ioProperty $ do- fsVar <- newTMVarIO MockFS.empty- errVar <- newTVarIO onlyGetErrors- counters <- zeroEntryCounters- let hfs = withEntryCounters counters $ simErrorHasFS fsVar errVar- withFile hfs (mkFsPath ["file1"]) (ReadWriteMode MustBeNew) $ \h -> do- n' <- Strict.hPutAllStrict hfs h bs- let n = fromIntegral $ BS.length bs- hSeek hfs h AbsoluteSeek 0- outp <- get hfs h- bs' <- fromOutput outp- getN <- readTVarIO (getCounter counters)- pure $ checkCoverage- $ tabulate "number of reads (>1 indicates partial reads)"- [showPowersOf 2 $ fromIntegral getN]- . cover 60 (getN > 1) "At least one partial read"- $ n === n' .&&. bs === bs'- where- onlyGetErrors = emptyErrors {- hGetSomeE = errStream+ ioProperty $ do+ fsVar <- newTMVarIO MockFS.empty+ errVar <- newTVarIO onlyGetErrors+ counters <- zeroEntryCounters+ let hfs = withEntryCounters counters $ simErrorHasFS fsVar errVar+ withFile hfs (mkFsPath ["file1"]) (ReadWriteMode MustBeNew) $ \h -> do+ n' <- Strict.hPutAllStrict hfs h bs+ let n = fromIntegral $ BS.length bs+ hSeek hfs h AbsoluteSeek 0+ outp <- get hfs h+ bs' <- fromOutput outp+ getN <- readTVarIO (getCounter counters)+ pure+ $ checkCoverage+ $ tabulate+ "number of reads (>1 indicates partial reads)"+ [showPowersOf 2 $ fromIntegral getN]+ . cover 60 (getN > 1) "At least one partial read"+ $ n === n' .&&. bs === bs'+ where+ onlyGetErrors =+ emptyErrors+ { hGetSomeE = errStream , hGetSomeAtE = errStream , hGetBufSomeE = errStream , hGetBufSomeAtE = errStream@@ -258,22 +278,27 @@ -- | See fs-sim#84 prop_regression_shrinkErrors :: Errors -> Property-prop_regression_shrinkErrors _errs = expectFailure $+prop_regression_shrinkErrors _errs =+ expectFailure $ property False -- | See fs-sim#84 prop_regression_shrinkNonEmptyErrors :: Errors -> Property-prop_regression_shrinkNonEmptyErrors errs = expectFailure $- not (allNull errs) ==> property False+prop_regression_shrinkNonEmptyErrors errs =+ expectFailure $+ not (allNull errs) ==>+ property False newtype EmptyErrors = EmptyErrors Errors deriving Show instance Arbitrary EmptyErrors where- arbitrary = EmptyErrors <$> oneof [ pure emptyErrors ]+ arbitrary = EmptyErrors <$> oneof [pure emptyErrors] shrink (EmptyErrors errs) = EmptyErrors <$> shrink errs -- | See fs-sim#84 prop_regression_shrinkEmptyErrors :: EmptyErrors -> Property-prop_regression_shrinkEmptyErrors (EmptyErrors errs) = expectFailure $- allNull errs ==> property False+prop_regression_shrinkEmptyErrors (EmptyErrors errs) =+ expectFailure $+ allNull errs ==>+ property False
test/Test/System/FS/Sim/FsTree.hs view
@@ -2,52 +2,57 @@ module Test.System.FS.Sim.FsTree (tests) where -import Data.List ((\\))+import Data.List ((\\)) import qualified Data.Map.Strict as M-import Data.Text (Text)--import Test.Tasty (TestTree, testGroup)-import Test.Tasty.HUnit (Assertion, assertFailure, testCase, (@?))-import Text.Show.Pretty (ppShow, ppShowList)--import System.FS.API.Types (FsPath, fsPathFromList)-import System.FS.Sim.FsTree (FsTree (File, Folder),- FsTreeError (FsMissing), find)+import Data.Text (Text)+import System.FS.API.Types (FsPath, fsPathFromList)+import System.FS.Sim.FsTree+ ( FsTree (File, Folder)+ , FsTreeError (FsMissing)+ , find+ )+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (Assertion, assertFailure, testCase, (@?))+import Text.Show.Pretty (ppShow, ppShowList) tests :: TestTree tests =- testGroup "FsTree"- [ testGroup "find command returns exactly what's expected"- [ testCase "usr" $ checkResultsOfFind ["usr"] example findUsr- , testCase "var" $ checkResultsOfFind ["var"] example findVar- , testCase "var/log" $ checkResultsOfFind ["var", "log"] example findVarLog- , testCase "root" $ checkResultsOfFind [] example findRoot-- -- Bad weather- , testCase "boom" $ ["boom"] `shouldReportMissingFileIn` example- ]+ testGroup+ "FsTree"+ [ testGroup+ "find command returns exactly what's expected"+ [ testCase "usr" $ checkResultsOfFind ["usr"] example findUsr+ , testCase "var" $ checkResultsOfFind ["var"] example findVar+ , testCase "var/log" $ checkResultsOfFind ["var", "log"] example findVarLog+ , testCase "root" $ checkResultsOfFind [] example findRoot+ , -- Bad weather+ testCase "boom" $ ["boom"] `shouldReportMissingFileIn` example+ ] ] checkResultsOfFind :: [Text] -> FsTree () -> [FsPath] -> Assertion checkResultsOfFind fp fs expectedResult = do- (expectedResult \\ filePathsFound)- `shouldBeEmptyOtherwise` "Not all expected paths were found"- (filePathsFound \\ expectedResult)- `shouldBeEmptyOtherwise` "Find returned unexpected paths"- where- filePathsFound = either (error . ppShow) id- $ find (fsPathFromList fp) fs- shouldBeEmptyOtherwise x msg =- null x @? msg ++ ":\n" ++ ppShowList x+ (expectedResult \\ filePathsFound)+ `shouldBeEmptyOtherwise` "Not all expected paths were found"+ (filePathsFound \\ expectedResult)+ `shouldBeEmptyOtherwise` "Find returned unexpected paths"+ where+ filePathsFound =+ either (error . ppShow) id $+ find (fsPathFromList fp) fs+ shouldBeEmptyOtherwise x msg =+ null x @? msg ++ ":\n" ++ ppShowList x shouldReportMissingFileIn :: [Text] -> FsTree () -> Assertion shouldReportMissingFileIn fp fs =- case find (fsPathFromList fp) fs of- Left FsMissing {} -> pure ()- Left err -> assertFailure $ "Unexpected error: " ++ ppShow err- Right _ -> assertFailure $ ppShow fp- ++ " was found on this filesystem:\n"- ++ ppShow fs+ case find (fsPathFromList fp) fs of+ Left FsMissing{} -> pure ()+ Left err -> assertFailure $ "Unexpected error: " ++ ppShow err+ Right _ ->+ assertFailure $+ ppShow fp+ ++ " was found on this filesystem:\n"+ ++ ppShow fs {------------------------------------------------------------------------------- Examples and expected results@@ -55,71 +60,105 @@ example :: FsTree () example =- Folder $ M.fromList [- ("usr", Folder $ M.fromList [- ("local", Folder $ M.fromList [- ("bin", Folder mempty)- ])- ])- , ("var", Folder $ M.fromList [- ("log", Folder $ M.fromList [- ("some.log", File mempty)- , ("apt", Folder mempty)- , ("cups", Folder $ M.fromList [- ("bar.txt", File mempty)- , ("baz.txt", File mempty)- , ("buz", Folder $ M.fromList [- ("sample.log", File mempty)- ])- , ("biz", Folder mempty)- ])- ])- , ("mail", Folder mempty)- , ("run", Folder mempty)- , ("tmp", Folder $ M.fromList [- ("foo.txt", File mempty)- ])- ])+ Folder $+ M.fromList+ [+ ( "usr"+ , Folder $+ M.fromList+ [+ ( "local"+ , Folder $+ M.fromList+ [ ("bin", Folder mempty)+ ]+ )+ ]+ )+ ,+ ( "var"+ , Folder $+ M.fromList+ [+ ( "log"+ , Folder $+ M.fromList+ [ ("some.log", File mempty)+ , ("apt", Folder mempty)+ ,+ ( "cups"+ , Folder $+ M.fromList+ [ ("bar.txt", File mempty)+ , ("baz.txt", File mempty)+ ,+ ( "buz"+ , Folder $+ M.fromList+ [ ("sample.log", File mempty)+ ]+ )+ , ("biz", Folder mempty)+ ]+ )+ ]+ )+ , ("mail", Folder mempty)+ , ("run", Folder mempty)+ ,+ ( "tmp"+ , Folder $+ M.fromList+ [ ("foo.txt", File mempty)+ ]+ )+ ]+ ) ] findUsr :: [FsPath] findUsr =- fmap fsPathFromList [ ["usr"]- , ["usr", "local"]- , ["usr", "local", "bin"]- ]-+ fmap+ fsPathFromList+ [ ["usr"]+ , ["usr", "local"]+ , ["usr", "local", "bin"]+ ] findVar :: [FsPath] findVar =- fmap fsPathFromList [ ["var"]- , ["var", "log"]- , ["var", "log", "some.log"]- , ["var", "log", "apt"]- , ["var", "log", "cups"]- , ["var", "log", "cups", "bar.txt"]- , ["var", "log", "cups", "baz.txt"]- , ["var", "log", "cups", "buz"]- , ["var", "log", "cups", "buz", "sample.log"]- , ["var", "log", "cups", "biz"]- , ["var", "mail"]- , ["var", "run"]- , ["var", "tmp"]- , ["var", "tmp", "foo.txt"]- ]+ fmap+ fsPathFromList+ [ ["var"]+ , ["var", "log"]+ , ["var", "log", "some.log"]+ , ["var", "log", "apt"]+ , ["var", "log", "cups"]+ , ["var", "log", "cups", "bar.txt"]+ , ["var", "log", "cups", "baz.txt"]+ , ["var", "log", "cups", "buz"]+ , ["var", "log", "cups", "buz", "sample.log"]+ , ["var", "log", "cups", "biz"]+ , ["var", "mail"]+ , ["var", "run"]+ , ["var", "tmp"]+ , ["var", "tmp", "foo.txt"]+ ] findVarLog :: [FsPath] findVarLog =- fmap fsPathFromList [ ["var", "log"]- , ["var", "log", "some.log"]- , ["var", "log", "apt"]- , ["var", "log", "cups"]- , ["var", "log", "cups", "bar.txt"]- , ["var", "log", "cups", "baz.txt"]- , ["var", "log", "cups", "buz"]- , ["var", "log", "cups", "buz", "sample.log"]- , ["var", "log", "cups", "biz"]- ]+ fmap+ fsPathFromList+ [ ["var", "log"]+ , ["var", "log", "some.log"]+ , ["var", "log", "apt"]+ , ["var", "log", "cups"]+ , ["var", "log", "cups", "bar.txt"]+ , ["var", "log", "cups", "baz.txt"]+ , ["var", "log", "cups", "buz"]+ , ["var", "log", "cups", "buz", "sample.log"]+ , ["var", "log", "cups", "biz"]+ ] findRoot :: [FsPath] findRoot = [fsPathFromList []] <> findUsr <> findVar
test/Test/System/FS/Sim/Stream.hs view
@@ -1,11 +1,9 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-+{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-orphans #-}- -- The @base@ library throws warnings on uses of @head@ on later GHC versions. -- This is a just a test module, so we ignore the warning. {-# OPTIONS_GHC -Wno-unrecognised-warning-flags #-}@@ -13,25 +11,29 @@ module Test.System.FS.Sim.Stream (tests) where -import Control.DeepSeq-import Data.Maybe (isJust, isNothing)-import Prelude hiding (filter, isInfinite, null)+import Control.DeepSeq+import Data.Maybe (isJust, isNothing)+import System.FS.Sim.Stream+import Test.Tasty+import Test.Tasty.QuickCheck+import Test.Util+import Prelude hiding (filter, isInfinite, null) import qualified Prelude-import System.FS.Sim.Stream-import Test.Tasty-import Test.Tasty.QuickCheck-import Test.Util tests :: TestTree-tests = testGroup "Test.System.FS.Sim.Stream" [- testProperty "prop_runStream" $+tests =+ testGroup+ "Test.System.FS.Sim.Stream"+ [ testProperty "prop_runStream" $ prop_runStream @Int , testProperty "prop_runStreamN" $ prop_runStreamN @Int- , testProperty "prop_null"+ , testProperty+ "prop_null" prop_null- , testGroup "Shrinkers" [- testProperty "prop_shrinkStreamFail" $+ , testGroup+ "Shrinkers"+ [ testProperty "prop_shrinkStreamFail" $ prop_shrinkStreamFail @Int , testProperty "prop_eventuallyJust @InfiniteStream" $ \(InfiniteStream s) -> prop_eventuallyJust @Int s@@ -40,8 +42,9 @@ , testProperty "prop_eventuallyNothing @FiniteStream" $ \(FiniteStream s) -> prop_eventuallyNothing @Int s ]- , testGroup "Generators and shrinkers" [- testGroup "Stream" $+ , testGroup+ "Generators and shrinkers"+ [ testGroup "Stream" $ prop_forAllArbitraryAndShrinkSatisfy @(Stream Int) arbitrary@@ -77,18 +80,18 @@ -- | Advancing a stream behaves like a head on an equivalent list. prop_runStream :: (Eq a, Show a) => Stream a -> Property prop_runStream s =- x === head ys- where- (x, _s') = runStream s- ys = runStreamIndefinitely s+ x === head ys+ where+ (x, _s') = runStream s+ ys = runStreamIndefinitely s -- | Advancing a stream @n@ times behaves likes @take n@ on an equivalent list. prop_runStreamN :: (Eq a, Show a) => Int -> Stream a -> Property prop_runStreamN n s =- xs === take n ys- where- (xs, _s') = runStreamN n s- ys = runStreamIndefinitely s+ xs === take n ys+ where+ (xs, _s') = runStreamN n s+ ys = runStreamIndefinitely s -- | Empty streams are null prop_null :: Property@@ -101,9 +104,10 @@ -- | A simple property that is expected to fail, but should exercise the -- shrinker a little bit. prop_shrinkStreamFail :: Stream a -> Property-prop_shrinkStreamFail s = expectFailure $+prop_shrinkStreamFail s =+ expectFailure $ let xs = fst (runStreamN 10 s)- in property $ length (Prelude.filter isJust xs) /= length (Prelude.filter isNothing xs)+ in property $ length (Prelude.filter isJust xs) /= length (Prelude.filter isNothing xs) -- | A stream eventually produces a 'Just' prop_eventuallyJust :: Stream a -> Property@@ -115,12 +119,12 @@ eventually :: (Maybe a -> Bool) -> Stream a -> Property eventually p = go 1- where- go !n s =- let (x, s') = runStream s in- if p x- then tabulate "Number of elements inspected" [showPowersOf 2 n] $ property True- else go (n+1) s'+ where+ go !n s =+ let (x, s') = runStream s+ in if p x+ then tabulate "Number of elements inspected" [showPowersOf 2 n] $ property True+ else go (n + 1) s' {------------------------------------------------------------------------------- Generators and shrinkers@@ -129,25 +133,27 @@ -- | A 'Stream' is either finite or infinite prop_stream :: NFData a => Stream a -> Property prop_stream s =- prop_finiteStream s+ prop_finiteStream s .||. prop_infiniteStream s -- | A stream is finite prop_finiteStream :: NFData a => Stream a -> Property prop_finiteStream s =- property (isFinite s) .&&. property (not (isInfinite s)) .&&.- prop_deepseqStream s+ property (isFinite s)+ .&&. property (not (isInfinite s))+ .&&. prop_deepseqStream s -- | An stream is infinite prop_infiniteStream :: Stream a -> Property prop_infiniteStream s =- property (isInfinite s) .&&. property (not (isFinite s))+ property (isInfinite s) .&&. property (not (isFinite s)) -- | A stream is non-empty, and finite or infinite prop_nonEmptyStream :: NFData a => Stream a -> Property prop_nonEmptyStream s =- property $ not (null s)- .&&. prop_stream s+ property $+ not (null s)+ .&&. prop_stream s prop_deepseqStream :: NFData a => Stream a -> Property prop_deepseqStream (UnsafeStream info xs) = property (rwhnf info `seq` rnf xs)@@ -157,47 +163,55 @@ -------------------------------------------------------------------------------} prop_arbitraryAndShrinkSatisfy ::- forall a. (Arbitrary a, Show a)- => (a -> Property) -- ^ Generator property- -> (a -> Property) -- ^ Shrinker property- -> [TestTree]+ forall a.+ (Arbitrary a, Show a) =>+ -- | Generator property+ (a -> Property) ->+ -- | Shrinker property+ (a -> Property) ->+ [TestTree] prop_arbitraryAndShrinkSatisfy =- prop_forAllArbitraryAndShrinkSatisfy arbitrary shrink+ prop_forAllArbitraryAndShrinkSatisfy arbitrary shrink prop_forAllArbitraryAndShrinkSatisfy ::- forall a. Show a- => Gen a- -> (a -> [a])- -> (a -> Property) -- ^ Generator property- -> (a -> Property) -- ^ Shrinker property- -> [TestTree]+ forall a.+ Show a =>+ Gen a ->+ (a -> [a]) ->+ -- | Generator property+ (a -> Property) ->+ -- | Shrinker property+ (a -> Property) ->+ [TestTree] prop_forAllArbitraryAndShrinkSatisfy gen shr pgen pshr =- [ prop_forAllArbitrarySatisfies gen shr pgen- , prop_forAllShrinkSatisfies gen shr pshr- ]+ [ prop_forAllArbitrarySatisfies gen shr pgen+ , prop_forAllShrinkSatisfies gen shr pshr+ ] prop_forAllArbitrarySatisfies ::- forall a. Show a- => Gen a- -> (a -> [a])- -> (a -> Property)- -> TestTree+ forall a.+ Show a =>+ Gen a ->+ (a -> [a]) ->+ (a -> Property) ->+ TestTree prop_forAllArbitrarySatisfies gen shr p =- testProperty "Arbitrary satisfies property" $- forAllShrink gen shr p+ testProperty "Arbitrary satisfies property" $+ forAllShrink gen shr p prop_forAllShrinkSatisfies ::- forall a. Show a- => Gen a- -> (a -> [a])- -> (a -> Property)- -> TestTree+ forall a.+ Show a =>+ Gen a ->+ (a -> [a]) ->+ (a -> Property) ->+ TestTree prop_forAllShrinkSatisfies gen shr p =- testProperty "Shrinking satisfies property" $- forAll gen $ \x ->- case shr x of- [] -> label "no shrinks" $ property True- xs -> forAll (growingElements xs) p+ testProperty "Shrinking satisfies property" $+ forAll gen $ \x ->+ case shr x of+ [] -> label "no shrinks" $ property True+ xs -> forAll (growingElements xs) p {------------------------------------------------------------------------------- Arbitrary instances@@ -208,8 +222,9 @@ -- instance Arbitrary a => Arbitrary (Stream a) where- arbitrary = oneof [- genFinite arbitrary+ arbitrary =+ oneof+ [ genFinite arbitrary , genInfinite arbitrary ] shrink = liftShrinkStream shrink@@ -222,26 +237,29 @@ deriving stock Show instance Arbitrary a => Arbitrary (NonEmptyStream a) where- arbitrary = NonEmptyStream <$> oneof [- genFiniteNonEmpty- , genInfinite arbitrary- ]- where- genFiniteNonEmpty = do- x <- arbitrary- xs <- arbitrary- pure $ unsafeMkFinite (x : xs)+ arbitrary =+ NonEmptyStream+ <$> oneof+ [ genFiniteNonEmpty+ , genInfinite arbitrary+ ]+ where+ genFiniteNonEmpty = do+ x <- arbitrary+ xs <- arbitrary+ pure $ unsafeMkFinite (x : xs) shrink (NonEmptyStream s) =- [ NonEmptyStream s'- | s' <- shrink s- , not (Prelude.null (unsafeStreamList s')) ]+ [ NonEmptyStream s'+ | s' <- shrink s+ , not (Prelude.null (unsafeStreamList s'))+ ] -- -- FiniteStream -- -newtype FiniteStream a = FiniteStream {- getFiniteStream :: Stream a+newtype FiniteStream a = FiniteStream+ { getFiniteStream :: Stream a } deriving stock Show @@ -253,8 +271,8 @@ -- InfiniteStream -- -newtype InfiniteStream a = InfiniteStream {- getInfiniteStream :: Stream a+newtype InfiniteStream a = InfiniteStream+ { getInfiniteStream :: Stream a } deriving stock Show @@ -271,4 +289,4 @@ instance Arbitrary (Tiny Int) where arbitrary = Tiny <$> choose (0, 5)- shrink (Tiny x) = [ Tiny x' | x' <- shrink x, 0 <= x', x' <= 5]+ shrink (Tiny x) = [Tiny x' | x' <- shrink x, 0 <= x', x' <= 5]
test/Test/System/FS/StateMachine.hs view
@@ -1,1851 +1,1960 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE StandaloneKindSignatures #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UnboxedTuples #-}-{-# LANGUAGE UndecidableInstances #-}--{-# OPTIONS_GHC -Wno-orphans #-}-{- HLINT ignore "Use camelCase" -}---- | Tests for our filesystem abstractions.------ The blogpost [An in-depth look at __quickcheck-state-machine__](http://www.well-typed.com/blog/2019/01/qsm-in-depth/)--- uses these tests of the file system abstraction as a case study and outlines the--- general approach. Like all of the model based tests, this consists of------ 1. A set of commands--- 2. A model against which we execute those commands--- 3. An interpreter of those commands against the real implementation--- 4. A generator and a shrinker for sequences of these commands--- 5. A way to /label/ generated sequences so that we can verify that the tests--- are covering what we think they should be covering.------ The sequences generated are then executed against both the model and the--- implementation, and the results are compared.------ In this particular case, the commands are file system operations such as--- create a directory, open a file, write some bytes, etc. The model is a very--- simple one: we simply model a file system as a tree of 'ByteString's (the raw--- bytes in the files). The goal of the model, of course, is not to provide one--- that mirrors the low-level details of the real implementation, but rather one--- that abstracts over such details and provides a /specification/.------ The file system abstraction however is a bit of an unusual test in that this--- is really "reverse model testing": the tests compare the model to the real--- file system, but we are of course not developing a file system. Instead, the--- tests serve to make sure that we got the model right, which we can then use--- in the tests of the rest of the consensus layer.----module Test.System.FS.StateMachine (- showLabelledExamples- , tests- ) where--#if __GLASGOW_HASKELL__<910-import Data.Foldable (foldl')-#endif--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-import Data.Bitraversable-import Data.ByteString (ByteString)-import qualified Data.ByteString as BS-import Data.Functor.Classes-import Data.Int (Int64)-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-import qualified Data.Text as Text-import Data.Word (Word64)-import qualified Generics.SOP as SOP-import GHC.Generics-import GHC.Stack hiding (prettyCallStack)-import System.IO.Temp (withSystemTempDirectory)-import System.Posix.Types (ByteCount)-import System.Random (getStdRandom, randomR)-import Test.StateMachine.TreeDiff-import Text.Read (readMaybe)-import Text.Show.Pretty (ppShow)--import Test.QuickCheck-import qualified Test.QuickCheck.Monadic as QC-import Test.QuickCheck.Random (mkQCGen)-import qualified Test.StateMachine as QSM-import Test.StateMachine (Concrete, Symbolic)-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, localOption, testGroup)-import Test.Tasty.QuickCheck--import System.FS.API-import System.FS.CallStack-import System.FS.Condense-import System.FS.IO--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.Prim--import qualified Test.Util.RefEnv as RE-import Test.Util.RefEnv (RefEnv)--{-------------------------------------------------------------------------------- Path expressions--------------------------------------------------------------------------------}--data PathExpr fp =- PExpPath FsPath- | PExpRef fp- | PExpParentOf fp- deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)--evalPathExpr :: PathExpr FsPath -> FsPath-evalPathExpr (PExpPath fp) = fp-evalPathExpr (PExpRef fp) = fp-evalPathExpr (PExpParentOf fp) = fsPathInit fp--{-------------------------------------------------------------------------------- Abstract model--------------------------------------------------------------------------------}---- | Commands------ We will be interested in three different instantiations of @h@:------ > Cmd HandleMock--- > Cmd (Reference (Opaque (FsHandle IOFSE)) Concrete)--- > Cmd (Reference (Opaque (FsHandle IOFSE)) Symbolic)------ Key idea is that all this infrastructure will be applicable both to--- the model and to the system under test.------ TODO: Program such as "copy what you read" is currently not expressible--- in our language. Does this matter?-data Cmd fp h =- Open (PathExpr fp) OpenMode- | Close h- | IsOpen 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)- | CreateDirIfMissing Bool (PathExpr fp)- | ListDirectory (PathExpr fp)- | DoesDirectoryExist (PathExpr fp)- | DoesFileExist (PathExpr fp)- | RemoveDirRecursive (PathExpr fp)- | RemoveFile (PathExpr fp)- | RenameFile (PathExpr fp) (PathExpr fp)- deriving (Generic, Show, Functor, Foldable, Traversable)--deriving instance SOP.Generic (Cmd fp h)-deriving instance SOP.HasDatatypeInfo (Cmd fp h)---- | Successful result-data Success fp h =- WHandle fp h- | RHandle h- | Unit ()- | Path fp ()- | Word64 Word64- | ByteString ByteString- | ByteCount ByteCount -- PutBuf, PutBufAt- | BCBS ByteCount ByteString -- GetBuf, GetBufAt- | Strings (Set String)- | Bool Bool- deriving (Eq, Show, Functor, Foldable)---- | Successful semantics-run :: forall m h. (PrimMonad m, HasCallStack)- => HasFS m h- -> Cmd FsPath (Handle h)- -> m (Success FsPath (Handle h))-run hasFS@HasFS{..} = go- where- go :: Cmd FsPath (Handle h) -> m (Success FsPath (Handle h))- go (Open pe mode) =- case mode of- ReadMode -> withPE pe (\_ -> RHandle) $ \fp -> hOpen fp mode- _otherwise -> withPE pe WHandle $ \fp -> hOpen fp mode-- go (CreateDir pe) = withPE pe Path $ createDirectory- go (CreateDirIfMissing b pe) = withPE pe Path $ createDirectoryIfMissing b- go (IsOpen h ) = Bool <$> hIsOpen h- go (Close h ) = Unit <$> hClose h- go (Seek h mode sz ) = Unit <$> hSeek h mode sz- -- 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.- 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 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 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- go (DoesDirectoryExist pe ) = withPE pe (const Bool) $ doesDirectoryExist- go (DoesFileExist pe ) = withPE pe (const Bool) $ doesFileExist- go (RemoveDirRecursive pe ) = withPE pe (const Unit) $ removeDirectoryRecursive- go (RemoveFile pe ) = withPE pe (const Unit) $ removeFile- go (RenameFile pe1 pe2 ) = withPEs pe1 pe2 (\_ _ -> Unit) $ renameFile-- withPE :: PathExpr FsPath- -> (FsPath -> a -> Success FsPath (Handle h))- -> (FsPath -> m a)- -> m (Success FsPath (Handle h))- withPE pe r f = let fp = evalPathExpr pe in r fp <$> f fp-- withPEs :: PathExpr FsPath- -> PathExpr FsPath- -> (FsPath -> FsPath -> a -> Success FsPath (Handle h))- -> (FsPath -> FsPath -> m a)- -> m (Success FsPath (Handle h))- withPEs pe1 pe2 r f =- let fp1 = evalPathExpr pe1- fp2 = evalPathExpr pe2- in r fp1 fp2 <$> f fp1 fp2--{-------------------------------------------------------------------------------- Detecting partial reads/writes of the tested IO implementation--------------------------------------------------------------------------------}--{- Note [Checking for partial reads/writes]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-- The functions 'hGetSome', 'hGetSomeAt' and 'hPutSome' might perform partial- reads/writes, depending on the underlying implementation, see- [ouroboros-network#277](https://github.com/IntersectMBO/ouroboros-network/issues/277).- While the model will always perform complete reads/writes, the real IO- implementation we are testing /might/ actually perform partial reads/writes.- This testsuite will fail when such a partial read or write is performed in the- real IO implementation, as these are undeterministic and the model will no- longer correspond to the real implementation. See- [ouroboros-network#502](https://github.com/IntersectMBO/ouroboros-network/issues/502)- were we tracked this issue.-- So far, on all systems the tests have been run on, no partial reads/writes- have ever been noticed. However, we cannot be sure that the tests will never- be run on a system or file-system that might result in partial reads/writes.- Therefore, we use checked variants of 'hGetSome', 'hGetSomeAt' and 'hPutSome'- that detect partial reads/writes and that will signal an error so that the- developer noticing the failing test doesn't waste any time debugging the- implementation while the failing test was actually due to an unexpected- partial read/write.-- For compound functions like 'hGetExactly' and 'hPutAll', this is not a good- solution. However, since we are only testing primitives, the solution is fine- for our purposes.-- The problem with compound functions is that to run a single 'Cmd', we now have- to run multiple primitive 'HasFS' functions. Each of those primitive functions- might update the state of the model and the real world. Now when the second,- third, ..., or n-th primitive functions fails (while running a single 'Cmd'),- the whole 'Cmd' failed and the model is not updated. This means that we- continue with the model as it was /before/ running the 'Cmd'. However, these- primitive functions might have changed the model /and/ the state of the real- implementation. In that case, we can no longer guarantee that the model and- the real implementation are in sync.--}--hGetSomeChecked :: (Monad m, HasCallStack)- => HasFS m h -> Handle h -> Word64 -> m ByteString-hGetSomeChecked HasFS{..} h n = do- bytes <- hGetSome h n- when (fromIntegral (BS.length bytes) /= 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 Note [Checking for partial reads/writes]"- return bytes--hGetSomeAtChecked :: (Monad m, HasCallStack)- => HasFS m h -> Handle h -> Word64 -> AbsOffset -> m ByteString-hGetSomeAtChecked HasFS{..} h n o = do- bytes <- hGetSomeAt h n o- when (fromIntegral (BS.length bytes) /= n) $ do- moreBytes <- hGetSomeAt h 1 $ o + fromIntegral (BS.length bytes)- -- 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 Note [Checking for partial reads/writes]"- return bytes--hPutSomeChecked :: (Monad m, HasCallStack)- => HasFS m h -> Handle h -> ByteString -> m Word64-hPutSomeChecked HasFS{..} h bytes = do- n <- hPutSome h bytes- if fromIntegral (BS.length bytes) /= n- then error "Unsupported partial write detected, see Note [Checking for partial reads/writes]"- else return n--hGetBufSomeChecked :: (HasCallStack, PrimMonad m)- => HasFS m h- -> Handle h -> ByteCount -> m (ByteCount, ByteString)-hGetBufSomeChecked HasFS{..} 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- -> Handle h -> ByteCount -> AbsOffset -> m (ByteCount, ByteString)-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'- 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)- => HasFS m h- -> Handle h -> ByteString -> ByteCount -> m ByteCount-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- if n /= n'- then error "Unsupported partial write detected, see #502"- else return n--hPutBufSomeAtChecked :: (HasCallStack, PrimMonad m)- => HasFS m h- -> Handle h -> ByteString -> ByteCount -> AbsOffset -> m ByteCount-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- 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--------------------------------------------------------------------------------}---- | For some error types, our mock FS implementation, which is based on--- (Ubuntu) Linux might throw different errors than the actual file system. In--- particular, this problem occurs when the file system under test is a Windows--- or MacOS one. In these cases, the 'sameError' comparison function, which is--- used to compare the 'FsError's that the mock throws against the 'FsError's--- that the SUT throws, is more lenient than the default 'sameFsError'.-sameError :: FsError -> FsError -> Bool-#if defined(mingw32_HOST_OS)--- For the following error types, our mock FS implementation (and the Posix--- implementation) throw the same errors:------ * 'FsReachedEOF'--- * 'FsDeviceFull'--- * 'FsResourceAlreadyInUse'------ For other cases, Windows throws different errors than the mock FS--- implementation.-sameError e1 e2 = fsErrorPath e1 == fsErrorPath e2- && sameFsErrorType (fsErrorType e1) (fsErrorType e2)- where- sameFsErrorType ty1 ty2 = case (ty1, ty2) of- (FsReachedEOF, FsReachedEOF) -> True- (FsReachedEOF, _) -> False- (_, FsReachedEOF) -> False- (FsDeviceFull, FsDeviceFull) -> True- (FsDeviceFull, _) -> False- (_, FsDeviceFull) -> False- (FsResourceAlreadyInUse, FsResourceAlreadyInUse) -> True- (FsResourceAlreadyInUse, _) -> False- (_, FsResourceAlreadyInUse) -> False- (_, _) -> True-#elif defined(darwin_HOST_OS)--- Check default implementation first using 'sameFsError', and otherwise permit--- some combinations of error types that are not structurally equal.-sameError e1 e2 = sameFsError e1 e2- || (fsErrorPath e1 == fsErrorPath e2- && permitted (fsErrorType e1) (fsErrorType e2))- where- -- error types that are permitted to differ for technical reasons- permitted ty1 ty2 = case (ty1, ty2) of- (FsInsufficientPermissions , FsResourceInappropriateType) -> True- (FsResourceInappropriateType, FsInsufficientPermissions ) -> True- (_ , _ ) -> False-#else--- treat every other distribution like it is (Ubuntu) Linux-sameError = sameFsError-#endif---- | Responses are either successful termination or an error-newtype Resp fp h = Resp { getResp :: Either FsError (Success fp h) }- deriving (Show, Functor, Foldable)---- | The 'Eq' instance for 'Resp' uses 'sameError'-instance (Eq fp, Eq h) => Eq (Resp fp h) where- Resp (Left e) == Resp (Left e') = sameError e e'- Resp (Right a) == Resp (Right a') = a == a'- _ == _ = False--runPure :: Cmd FsPath (Handle HandleMock)- -> MockFS -> (Resp FsPath (Handle HandleMock), MockFS)-runPure cmd mockFS =- aux $ runST $ runFSSimT (run primHasMockFS cmd) mockFS- where- aux :: Either FsError (Success FsPath (Handle HandleMock), MockFS)- -> (Resp FsPath (Handle HandleMock), MockFS)- aux (Left e) = (Resp (Left e), mockFS)- aux (Right (r, mockFS')) = (Resp (Right r), mockFS')--runIO :: HasFS IO HandleIO- -> Cmd FsPath (Handle HandleIO) -> IO (Resp FsPath (Handle HandleIO))-runIO hfs cmd = Resp <$> E.try (run hfs cmd)--{-------------------------------------------------------------------------------- Bitraversable instances--------------------------------------------------------------------------------}--TH.deriveBifunctor ''Cmd-TH.deriveBifoldable ''Cmd-TH.deriveBitraversable ''Cmd--TH.deriveBifunctor ''Success-TH.deriveBifoldable ''Success-TH.deriveBitraversable ''Success--TH.deriveBifunctor ''Resp-TH.deriveBifoldable ''Resp-TH.deriveBitraversable ''Resp--{-------------------------------------------------------------------------------- Collect arguments--------------------------------------------------------------------------------}--paths :: Bitraversable t => t fp h -> [fp]-paths = bifoldMap (:[]) (const [])--handles :: Bitraversable t => t fp h -> [h]-handles = bifoldMap (const []) (:[])--{-------------------------------------------------------------------------------- Model--------------------------------------------------------------------------------}---- | Concrete or symbolic reference to a path-type PathRef = QSM.Reference FsPath---- | Concrete or symbolic reference to an IO file handle-type HandleRef = QSM.Reference (Handle HandleIO)---- | Mapping between real IO file handles and mock file handles-type KnownHandles = RefEnv (Handle HandleIO) (Handle HandleMock)---- | Mapping between path references and paths-type KnownPaths = RefEnv FsPath FsPath--resolvePathExpr :: Eq1 r => KnownPaths r -> PathExpr (PathRef r) -> FsPath-resolvePathExpr knownPaths = evalPathExpr . fmap (knownPaths RE.!)---- | Execution model-data Model r = Model {- mockFS :: MockFS- , knownPaths :: KnownPaths r- , knownHandles :: KnownHandles r- }- deriving (Show, Generic)---- | Initial model-initModel :: Model r-initModel = Model Mock.empty RE.empty RE.empty---- | Key property of the model is that we can go from real to mock responses-toMock :: (Bifunctor t, Eq1 r)- => Model r -> t :@ r -> t FsPath (Handle HandleMock)-toMock Model{..} (At r) = bimap (knownPaths RE.!) (knownHandles RE.!) r---- | Step the mock semantics------ We cannot step the whole Model here (see 'Event', below)-step :: Eq1 r- => Model r -> Cmd :@ r -> (Resp FsPath (Handle HandleMock), MockFS)-step model@Model{..} cmd = runPure (toMock model cmd) mockFS---- | Open read handles-openHandles :: Model r -> [Handle HandleMock]-openHandles Model{..} =- filter isOpen (RE.elems knownHandles)- where- isOpen :: Handle HandleMock -> Bool- isOpen (Handle h _) = Mock.handleIsOpen mockFS h--{-------------------------------------------------------------------------------- Wrapping in quickcheck-state-machine references--------------------------------------------------------------------------------}---- | Instantiate functor @f@ to @f (PathRef r) (HandleRef r)@------ > Cmd :@ Concrete ~ Cmd (PathRef Concrete) (HandleRef Concrete)-newtype At t r = At {unAt :: (t (PathRef r) (HandleRef r))}- deriving (Generic)---- | Alias for 'At'-type (:@) t r = At t r--deriving instance Show1 r => Show (Cmd :@ r)-deriving instance Show1 r => Show (Resp :@ r)-deriving instance Eq1 r => Eq (Resp :@ r)--instance Bifoldable t => Rank2.Foldable (At t) where- foldMap = \f (At x) -> bifoldMap (app f) (app f) x- where- app :: (r x -> m) -> QSM.Reference x r -> m- app f (QSM.Reference x) = f x--instance Bifunctor t => Rank2.Functor (At t) where- fmap = \f (At x) -> At (bimap (app f) (app f) x)- where- app :: (r x -> r' x) -> QSM.Reference x r -> QSM.Reference x r'- app f (QSM.Reference x) = QSM.Reference (f x)--instance Bitraversable t => Rank2.Traversable (At t) where- traverse = \f (At x) -> At <$> bitraverse (app f) (app f) x- where- app :: Functor f- => (r x -> f (r' x)) -> QSM.Reference x r -> f (QSM.Reference x r')- app f (QSM.Reference x) = QSM.Reference <$> f x--{-------------------------------------------------------------------------------- Events--------------------------------------------------------------------------------}---- | An event records the model before and after a command along with the--- command itself and its response-data Event r = Event {- eventBefore :: Model r- , eventCmd :: Cmd :@ r- , eventAfter :: Model r- , eventMockResp :: Resp FsPath (Handle HandleMock)- }- deriving (Show)--eventMockCmd :: Eq1 r => Event r -> Cmd FsPath (Handle HandleMock)-eventMockCmd Event{..} = toMock eventBefore eventCmd---- | Construct an event------ When we execute both the model and the real implementation in lockstep,--- we get two responses: this suffices to update the model.-lockstep :: forall r. (Show1 r, Ord1 r, HasCallStack)- => Model r- -> Cmd :@ r- -> Resp :@ r- -> Event r-lockstep model@Model{..} cmd (At resp) = Event {- eventBefore = model- , eventCmd = cmd- , eventAfter = Model {- mockFS = mockFS'- , knownPaths = knownPaths `RE.union` newPaths- , knownHandles = knownHandles `RE.union` newHandles- }- , eventMockResp = resp'- }- where- (resp', mockFS') = step model cmd- newPaths = RE.fromList $ zip (paths resp) (paths resp')- newHandles = RE.fromList $ zip (handles resp) (handles resp')--{-------------------------------------------------------------------------------- Generator--------------------------------------------------------------------------------}--generator :: Model Symbolic -> Gen (Cmd :@ Symbolic)-generator Model{..} = oneof $ concat [- withoutHandle- , if RE.null knownHandles then [] else withHandle- ]- where- withoutHandle :: [Gen (Cmd :@ Symbolic)]- withoutHandle = [- fmap At $ genOpen- , fmap At $ CreateDir <$> genPathExpr- , fmap At $ CreateDirIfMissing <$> arbitrary <*> genPathExpr- , fmap At $ ListDirectory <$> genPathExpr- , fmap At $ DoesDirectoryExist <$> genPathExpr- , fmap At $ DoesFileExist <$> genPathExpr- , fmap At $ RemoveDirRecursive <$> genPathExpr- , fmap At $ RemoveFile <$> genPathExpr- , fmap At $ RenameFile <$> genPathExpr <*> genPathExpr- ]-- withHandle :: [Gen (Cmd :@ Symbolic)]- withHandle = [- fmap At $ Close <$> genHandle- , fmap At $ IsOpen <$> genHandle- , 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- ]-- genOpen :: Gen (Cmd (PathRef Symbolic) (HandleRef Symbolic))- genOpen = do- path <- genPath- mode <- genMode $ elem path (RE.elems knownPaths)- return $ Open (PExpPath path) mode-- -- Wrap path in a simple path expression- -- (References are generated during shrinking only)- genPathExpr :: Gen (PathExpr fp)- genPathExpr = PExpPath <$> genPath-- -- We choose from a small list of names so that we reuse names often- -- We use the same set of files and directories so that we can test- -- things like trying to open a directory as if it were a file- genPath :: Gen FsPath- genPath = do- n <- choose (0, 3)- mkFsPath <$> replicateM n (elements ["x", "y", "z"])-- genHandle :: Gen (HandleRef Symbolic)- genHandle = elements (RE.keys knownHandles)-- genMode :: Bool -> Gen OpenMode- genMode fileExists = frequency [- (rf, return ReadMode)- , (wf, WriteMode <$> genAllowExisting)- , (wf, AppendMode <$> genAllowExisting)- , (wf, ReadWriteMode <$> genAllowExisting)- ]- where- -- we try to avoid 'ReadMode' when the file does not exist.- (rf, wf) = if fileExists then (10,3) else (1,3)-- genAllowExisting :: Gen AllowExisting- genAllowExisting = elements [AllowExisting, MustBeNew, MustExist]-- genSeekMode :: Gen SeekMode- genSeekMode = elements [- AbsoluteSeek- , RelativeSeek- , SeekFromEnd- ]-- genOffset :: Gen Int64- genOffset = oneof- [ return 0- , choose (1, 10)- , choose (-1, -10)- ]--instance Arbitrary AbsOffset where- arbitrary = AbsOffset . getSmall <$> arbitrary- shrink ao = AbsOffset <$> shrink (unAbsOffset ao)--{-------------------------------------------------------------------------------- Temporary files (used in shrinking)--------------------------------------------------------------------------------}---- | Temp files are numbered from 1-newtype TempFile = TempFile Int- deriving (Show)--instance Condense TempFile where -- basically GNTD- condense (TempFile n) = condense n--tempToExpr :: TempFile -> PathExpr fp-tempToExpr (TempFile n) = PExpPath (mkFsPath ['t' : show n])--tempFromPath :: FsPath -> Maybe TempFile-tempFromPath fp =- case map Text.unpack (fsPathToList fp) of- ['t' : suf] -> do n <- readMaybe suf- guard (n >= 1)- return $ TempFile n- _otherwise -> Nothing--{-------------------------------------------------------------------------------- Shrinking--------------------------------------------------------------------------------}---- | When we replace one reference with another, we are careful to impose an--- order so that we don't end up flipping between references. Since shrinking is--- greedy this does mean that the choice of reference may influence how much we--- can shrink later. This is hard to avoid in greedy algorithms.-shrinker :: Model Symbolic -> Cmd :@ Symbolic -> [Cmd :@ Symbolic]-shrinker Model{..} (At cmd) =- case cmd of- Open pe mode -> concat [- case tempFromPath fp of- Just n ->- map (\n' -> At $ Open (tempToExpr n') mode)- $ shrinkTempFile n- Nothing ->- let mode' = case mode of- ReadMode -> ReadWriteMode AllowExisting- _otherwise -> mode- in [At $ Open (tempToExpr (TempFile numTempFiles)) mode']- , case mode of- ReadWriteMode ex -> [- At $ Open pe ReadMode- , At $ Open pe (WriteMode ex)- ]- _otherwise ->- []- , map (\pe' -> At $ Open pe' mode) $- replaceWithRef pe (== fp) PExpRef- ]- where- fp :: FsPath- fp = resolvePathExpr knownPaths pe-- ListDirectory pe -> concat [- map (At . ListDirectory) $- replaceWithRef pe ((== fp) . fsPathInit) PExpParentOf- ]- where- fp :: FsPath- fp = resolvePathExpr knownPaths pe-- Get h n -> At . Get h <$> shrink n- 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 ->- []- where- -- Replace path with reference- --- -- If we are replacing one reference with another, be careful to impose- -- an ordering so that we don't end up toggling between references.- replaceWithRef :: PathExpr (PathRef Symbolic)- -- current- -> (FsPath -> Bool)- -- evaluate candidate- -> (PathRef Symbolic -> PathExpr (PathRef Symbolic))- -- construct replacement- -> [PathExpr (PathRef Symbolic)]- replaceWithRef pe p f =- filter (canReplace pe) $ map f $ RE.reverseLookup p knownPaths- where- canReplace :: PathExpr (PathRef Symbolic) -- current- -> PathExpr (PathRef Symbolic) -- candidate- -> Bool- canReplace (PExpRef ref) (PExpRef ref') = ref' < ref- canReplace (PExpParentOf ref) (PExpParentOf ref') = ref' < ref- canReplace _ _ = True-- shrinkTempFile :: TempFile -> [TempFile]- shrinkTempFile (TempFile n) = TempFile . getPositive <$> shrink (Positive n)-- shrinkBytes :: ByteString -> [ByteString]- shrinkBytes = map BS.pack . shrink . BS.unpack-- numTempFiles :: Int- numTempFiles = 100--{-------------------------------------------------------------------------------- Limitations/known bugs--------------------------------------------------------------------------------}---- | Known limitations/bugs that we don't want to test for------ NOTE: Can assume all used handles are in known in the model.-knownLimitation :: Model Symbolic -> Cmd :@ Symbolic -> QSM.Logic-knownLimitation model cmd =- case getResp resp of- Left FsError{..} -> QSM.Boolean fsLimitation- _otherwise -> QSM.Bot- where- (resp, _mockFS') = step model cmd--{-------------------------------------------------------------------------------- The final state machine--------------------------------------------------------------------------------}---- | Mock a response------ We do this by running the pure semantics and then generating mock--- references for any new handles.-mock :: Model Symbolic- -> Cmd :@ Symbolic- -> QSM.GenSym (Resp :@ Symbolic)-mock model cmd = At <$> bitraverse (const QSM.genSym) (const QSM.genSym) resp- where- (resp, _mockFS') = step model cmd--precondition :: Model Symbolic -> Cmd :@ Symbolic -> QSM.Logic-precondition m@Model{..} (At cmd) =- QSM.forAll (handles cmd) (`QSM.member` RE.keys knownHandles)- QSM.:&& QSM.Boolean (Mock.numOpenHandles mockFS < maxNumOpenHandles)- QSM.:&& QSM.Not (knownLimitation m (At cmd))- where- -- Limit number of open handles to avoid exceeding OS limits- maxNumOpenHandles = 100---- | Step the model------ NOTE: This function /must/ be polymorphic in @r@.-transition :: (Show1 r, Ord1 r) => Model r -> Cmd :@ r -> Resp :@ r -> Model r-transition model cmd = eventAfter . lockstep model cmd--postcondition :: Model Concrete- -> Cmd :@ Concrete- -> Resp :@ Concrete- -> QSM.Logic-postcondition model cmd resp =- toMock (eventAfter ev) resp QSM..== eventMockResp ev- QSM..&& errorHasMountPoint (getResp $ unAt resp)- where- ev = lockstep model cmd resp-- errorHasMountPoint :: Either FsError a -> QSM.Logic- errorHasMountPoint (Right _) = QSM.Top- errorHasMountPoint (Left fsError) = QSM.Boolean $ hasMountPoint fsError--semantics :: HasFS IO HandleIO -> Cmd :@ Concrete -> IO (Resp :@ Concrete)-semantics hfs (At cmd) =- At . bimap QSM.reference QSM.reference <$>- runIO hfs (bimap QSM.concrete QSM.concrete cmd)---- | The state machine proper-sm :: HasFS IO HandleIO -> QSM.StateMachine Model (At Cmd) IO (At Resp)-sm hfs = QSM.StateMachine {- initModel = initModel- , transition = transition- , precondition = precondition- , postcondition = postcondition- , generator = Just . generator- , shrinker = shrinker- , semantics = semantics hfs- , mock = mock- , cleanup = QSM.noCleanup- , invariant = Nothing- }--{-------------------------------------------------------------------------------- Labelling--------------------------------------------------------------------------------}--data Tag =- -- | Create directory then list its parent- --- -- > CreateDir [x, .., y, z]- -- > ListDirectory [x, .., y]- TagCreateDirThenListDir-- -- | Create a directory with its parents, then list its parents- --- -- > CreateDirIfMissing True [x, .., y, z]- -- > ListDirectory [x, .., y]- --- -- Note that this implies all directories must have been created.- | TagCreateDirWithParentsThenListDir-- -- | Have a least N open files- --- -- > Open ..- -- > .. --- -- > Open ..- --- -- (with not too many Close calls in between).- | TagAtLeastNOpenFiles Int-- -- | Write, then truncate, then write again- --- -- > Put ..- -- > Truncate .. (deleting some but not all of the bytes already written)- -- > Put (write some different bytes)- --- -- Verifies that we correctly modify the file pointer.- | TagPutTruncatePut-- -- | Concurrent writer and reader- --- -- > h1 <- Open fp WriteMode ..- -- > h2 <- Open fp ReadMode ..- -- > Put h1 ..- -- > Get h2 ..- | TagConcurrentWriterReader-- -- | Writing many times should append the bytes.- --- -- > h1 <- Open fp WriteMode .. | > h2 <- Open fp ReadMode ..- -- > Put h1 .. |- -- > Put h1 .. |-- -- > Get h2 ..- | TagWriteWriteRead-- -- | Try to open a directory- --- -- > CreateDirectoryIfMissing True fp- -- > Open hp IO.WriteMode- | TagOpenDirectory-- -- | Write to a file- --- -- > Put h1- | TagWrite-- -- | Seek from end of a file- --- -- > Seek h IO.SeekFromEnd n (n<0)- | TagSeekFromEnd-- -- | Create a directory- --- -- > CreateDirIfMissing True ..- | TagCreateDirectory-- -- | DoesFileExistOK returns True- | TagDoesFileExistOK-- -- | DoesFileExistOK returns False- | TagDoesFileExistKO-- -- | DoesDirectoryExistOK returns True- | TagDoesDirectoryExistOK-- -- | DoesDirectoryExistOK returns False- | TagDoesDirectoryExistKO-- -- | Remove a directory recursively- --- -- > RemoveDirRecursively fe- -- > DoesFileExist fe- | TagRemoveDirectoryRecursive-- -- | Remove a file- --- -- > RemoveFile fe- -- > DoesFileExist fe- | TagRemoveFile-- -- | Rename a file- --- -- > _ <- Open fe1 WriteMode- -- > RenameFile fe2 fe2- | TagRenameFile-- -- | Put truncate and Get- --- -- > Put ..- -- > Truncate ..- -- > Get ..- | TagPutTruncateGet-- -- | Close a handle 2 times- --- -- > h <- Open ..- -- > close h- -- > close h- | TagClosedTwice-- -- | Open an existing file with ReadMode and then with WriteMode- --- -- > open fp ReadMode- -- > open fp Write- | TagOpenReadThenWrite-- -- | Open 2 Readers of a file.- --- -- > open fp ReadMode- -- > open fp ReadMode- | TagOpenReadThenRead-- -- | ListDir on a non empty dirextory.- --- -- > CreateDirIfMissing True a/b- -- > ListDirectory a- | TagCreateDirWithParentsThenListDirNotNull-- -- | Read from an AppendMode file- --- -- > h <- Open fp AppendMode- -- > Read h ..- | TagReadInvalid-- -- | Write to a read only file- --- -- > h <- Open fp ReadMode- -- > Put h ..- | TagWriteInvalid-- -- | Put Seek and Get- --- -- > Put ..- -- > Seek ..- -- > Get ..- | TagPutSeekGet-- -- | Put Seek (negative) and Get- --- -- > Put ..- -- > Seek .. (negative)- -- > Get ..- | TagPutSeekNegGet-- -- | Open with MustBeNew (O_EXCL flag), but the file already existed.- --- -- > h <- Open fp (AppendMode _)- -- > Close h- -- > Open fp (AppendMode MustBeNew)- | TagExclusiveFail-- -- | Open a file in read mode successfully- --- -- > h <- Open fp (WriteMode _)- -- > Close h- -- > h <- Open fp ReadMode- | TagReadModeMustExist-- -- | Open a file in read mode, but it fails because the file does not exist.- --- -- > h <- Open fp ReadMode- | TagReadModeMustExistFail-- -- | Open a file in non-read mode with 'MustExist' successfully.- --- -- > h <- Open fp (_ MustBeNew)- -- > Close h- -- > h <- Open fp (_ MustExist)- | TagFileMustExist-- -- | Open a file in non-read mode with 'MustExist', but it fails because the- -- files does not exist.- --- -- > h <- Open fp (_ MustExist)- | TagFileMustExistFail-- -- | Reading returns an empty bytestring when EOF- --- -- > h <- open fp ReadMode- -- > Get h 1 == ""- | TagReadEOF-- -- | GetAt- --- -- > 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-type EventPred = C.Predicate (Event Symbolic) Tag---- | Convenience combinator for creating classifiers for successful commands------ For convenience we pair handles with the paths they refer to-successful :: ( Event Symbolic- -> Success FsPath (Handle HandleMock)- -> Either Tag EventPred- )- -> EventPred-successful f = C.predicate $ \ev ->- case eventMockResp ev of- Resp (Left _ ) -> Right $ successful f- Resp (Right ok) -> f ev ok---- | Tag commands------ Tagging works on symbolic events, so that we can tag without doing real IO.-tag :: [Event Symbolic] -> [Tag]-tag = C.classify [- tagCreateDirThenListDir Set.empty- , tagCreateDirWithParentsThenListDir Set.empty- , tagAtLeastNOpenFiles 0- , tagPutTruncatePut Map.empty Map.empty Map.empty- , tagConcurrentWriterReader Map.empty- , tagWriteWriteRead Map.empty- , tagOpenDirectory Set.empty- , tagWrite- , tagSeekFromEnd- , tagCreateDirectory- , tagDoesFileExistOK- , tagDoesFileExistKO- , tagDoesDirectoryExistOK- , tagDoesDirectoryExistKO- , tagRemoveDirectoryRecursive Set.empty- , tagRemoveFile Set.empty- , tagRenameFile- , tagPutTruncateGet Map.empty Set.empty- , tagClosedTwice Set.empty- , tagOpenReadThenWrite Set.empty- , tagOpenReadThenRead Set.empty- , tagCreateDirWithParentsThenListDirNotNull Set.empty- , tagReadInvalid Set.empty- , tagWriteInvalid Set.empty- , tagPutSeekGet Set.empty Set.empty- , tagPutSeekNegGet Set.empty Set.empty- , tagExclusiveFail- , tagReadModeMustExist- , tagReadModeMustExistFail- , tagFileMustExist- , tagFileMustExistFail- , tagReadEOF- , tagPread- , tagPutGetBuf Set.empty- , tagPutGetBufAt Set.empty- ]- where- tagCreateDirThenListDir :: Set FsPath -> EventPred- tagCreateDirThenListDir created = successful $ \ev _ ->- case eventMockCmd ev of- CreateDir fe ->- Right $ tagCreateDirThenListDir (Set.insert fp created)- where- fp = evalPathExpr fe- ListDirectory fe | fp `Set.member` (Set.map fsPathInit created) ->- Left TagCreateDirThenListDir- where- fp = evalPathExpr fe- _otherwise ->- Right $ tagCreateDirThenListDir created-- tagCreateDirWithParentsThenListDir :: Set FsPath -> EventPred- tagCreateDirWithParentsThenListDir created = successful $ \ev _ ->- case eventMockCmd ev of- CreateDirIfMissing True fe | length (fsPathToList fp) > 1 ->- Right $ tagCreateDirWithParentsThenListDir (Set.insert fp created)- where- fp = evalPathExpr fe- ListDirectory fe | fp `Set.member` (Set.map fsPathInit created) ->- Left TagCreateDirWithParentsThenListDir- where- fp = evalPathExpr fe- _otherwise ->- Right $ tagCreateDirWithParentsThenListDir created-- tagCreateDirWithParentsThenListDirNotNull :: Set FsPath -> EventPred- tagCreateDirWithParentsThenListDirNotNull created = successful $ \ev suc ->- case (eventMockCmd ev, suc) of- (CreateDirIfMissing True fe, _) | length (fsPathToList fp) > 1 ->- Right $ tagCreateDirWithParentsThenListDirNotNull (Set.insert fp created)- where- fp = evalPathExpr fe- (ListDirectory fe, Strings set) | fp `Set.member` (Set.map fsPathInit created)- && not (Set.null set) ->- Left TagCreateDirWithParentsThenListDirNotNull- where- fp = evalPathExpr fe- _otherwise ->- Right $ tagCreateDirWithParentsThenListDirNotNull created--- -- TODO: It turns out we never hit the 10 (or higher) open handles case- -- Not sure if this is a problem or not.- tagAtLeastNOpenFiles :: Int -> EventPred- tagAtLeastNOpenFiles maxNumOpen = C.Predicate {- predApply = \ev ->- let maxNumOpen' = max maxNumOpen (countOpen (eventAfter ev))- in Right $ tagAtLeastNOpenFiles maxNumOpen'- , predFinish = case maxNumOpen of- 0 -> Nothing- 1 -> Just $ TagAtLeastNOpenFiles 1- 2 -> Just $ TagAtLeastNOpenFiles 2- n | n < 10 -> Just $ TagAtLeastNOpenFiles 3- n -> Just $ TagAtLeastNOpenFiles (n `div` 10 * 10)- }- where- countOpen :: Model r -> Int- countOpen = Mock.numOpenHandles . mockFS-- tagPutTruncateGet :: Map (HandleMock, FsPath) Int- -> Set (HandleMock, FsPath)- -> EventPred- tagPutTruncateGet put truncated = successful $ \ev _ ->- case eventMockCmd ev of- Put (Handle h fp) bs | BS.length bs /= 0 ->- let- f Nothing = Just $ BS.length bs- f (Just n) = Just $ (BS.length bs) + n- put' = Map.alter f (h, fp) put- in Right $ tagPutTruncateGet put' truncated- Truncate (Handle h fp) sz | sz > 0 -> case Map.lookup (h, fp) put of- Just p | fromIntegral sz < p ->- let truncated' = Set.insert (h, fp) truncated- in Right $ tagPutTruncateGet put truncated'- _otherwise -> Right $ tagPutTruncateGet put truncated- Get (Handle h fp) n | n > 0 && (not $ Set.null $- Set.filter (\(hRead, fp') -> fp' == fp && not (hRead == h)) truncated) ->- Left TagPutTruncateGet- GetAt (Handle h fp) n _ | n > 0 && (not $ Set.null $- Set.filter (\(hRead, fp') -> fp' == fp && not (hRead == h)) truncated) ->- Left TagPutTruncateGet- _otherwise -> Right $ tagPutTruncateGet put truncated-- tagPutTruncatePut :: Map HandleMock ByteString- -> Map HandleMock ByteString- -> Map HandleMock ByteString- -> EventPred- tagPutTruncatePut before truncated after = successful $ \ev _ ->- case eventMockCmd ev of- Put (Handle h _) bs | BS.length bs /= 0 ->- case Map.lookup h truncated of- Nothing -> -- not yet truncated- let before' = Map.alter (appTo bs) h before in- Right $ tagPutTruncatePut before' truncated after- Just deleted ->- let putAfter = Map.findWithDefault mempty h after <> bs- after' = Map.insert h putAfter after in- if deleted /= BS.take (BS.length deleted) putAfter- then Left $ TagPutTruncatePut- else Right $ tagPutTruncatePut before truncated after'- Truncate (Handle h _) sz | sz > 0 ->- let putBefore = Map.findWithDefault mempty h before- (putBefore', deleted) = BS.splitAt (fromIntegral sz) putBefore- before' = Map.insert h putBefore' before- truncated' = Map.insert h deleted truncated- after' = Map.delete h after- in Right $ tagPutTruncatePut before' truncated' after'- _otherwise ->- Right $ tagPutTruncatePut before truncated after- where- appTo :: Monoid a => a -> Maybe a -> Maybe a- appTo b Nothing = Just b- appTo b (Just a) = Just (a <> b)-- tagConcurrentWriterReader :: Map HandleMock (Set HandleMock) -> EventPred- tagConcurrentWriterReader put = successful $ \ev@Event{..} _ ->- case eventMockCmd ev of- Put (Handle h fp) bs | BS.length bs > 0 ->- -- Remember the other handles to the same file open at this time- let readHs :: Set HandleMock- readHs = Set.fromList- $ map handleRaw- $ filter (\(Handle h' fp') -> h /= h' && fp == fp')- $ openHandles eventBefore-- put' :: Map HandleMock (Set HandleMock)- put' = Map.alter (Just . maybe readHs (Set.union readHs)) h put-- in Right $ tagConcurrentWriterReader put'- Close (Handle h _) ->- Right $ tagConcurrentWriterReader (Map.delete h put)- Get (Handle h _) n | h `elem` Set.unions (Map.elems put), n > 0 ->- Left TagConcurrentWriterReader- GetAt (Handle h _) n _ | h `elem` Set.unions (Map.elems put), n > 0 ->- Left TagConcurrentWriterReader- _otherwise ->- Right $ tagConcurrentWriterReader put-- tagOpenReadThenWrite :: Set FsPath -> EventPred- tagOpenReadThenWrite readOpen = successful $ \ev _ ->- case eventMockCmd ev of- Open (PExpPath fp) ReadMode ->- Right $ tagOpenReadThenWrite $ Set.insert fp readOpen- Open (PExpPath fp) (WriteMode _) | Set.member fp readOpen ->- Left TagOpenReadThenWrite- _otherwise -> Right $ tagOpenReadThenWrite readOpen-- tagOpenReadThenRead :: Set FsPath -> EventPred- tagOpenReadThenRead readOpen = successful $ \ev _ ->- case eventMockCmd ev of- Open (PExpPath fp) ReadMode | Set.member fp readOpen ->- Left TagOpenReadThenRead- Open (PExpPath fp) ReadMode ->- Right $ tagOpenReadThenRead $ Set.insert fp readOpen- _otherwise -> Right $ tagOpenReadThenRead readOpen-- tagWriteWriteRead :: Map (HandleMock, FsPath) Int -> EventPred- tagWriteWriteRead wr = successful $ \ev _ ->- case eventMockCmd ev of- Put (Handle h fp) bs | BS.length bs > 0 ->- let f Nothing = Just 0- f (Just x) = Just $ x + 1- in Right $ tagWriteWriteRead $ Map.alter f (h, fp) wr- Get (Handle hRead fp) n | n > 1 ->- if not $ Map.null $ Map.filterWithKey (\(hWrite, fp') times -> fp' == fp && times > 1 && not (hWrite == hRead)) wr- then Left TagWriteWriteRead- else Right $ tagWriteWriteRead wr- GetAt (Handle hRead fp) n _ | n > 1 ->- if not $ Map.null $ Map.filterWithKey (\(hWrite, fp') times -> fp' == fp && times > 1 && not (hWrite == hRead)) wr- then Left TagWriteWriteRead- else Right $ tagWriteWriteRead wr- _otherwise ->- Right $ tagWriteWriteRead wr-- -- this never succeeds because of an fsLimitation- tagOpenDirectory :: Set FsPath -> EventPred- tagOpenDirectory created = C.predicate $ \ev ->- case (eventMockCmd ev, eventMockResp ev) of- (CreateDir fe, Resp (Right _)) ->- Right $ tagOpenDirectory (Set.insert fp created)- where- fp = evalPathExpr fe- (CreateDirIfMissing True fe, Resp (Right _)) ->- Right $ tagOpenDirectory (Set.insert fp created)- where- fp = evalPathExpr fe- (Open fe _mode, _) | Set.member (evalPathExpr fe) created ->- Left TagOpenDirectory- _otherwise ->- Right $ tagOpenDirectory created-- tagWrite :: EventPred- tagWrite = successful $ \ev _ ->- case eventMockCmd ev of- Put _ bs | BS.length bs > 0 ->- Left TagWrite- _otherwise -> Right tagWrite-- tagSeekFromEnd :: EventPred- tagSeekFromEnd = successful $ \ev _ ->- case eventMockCmd ev of- Seek _ SeekFromEnd n | n < 0 -> Left TagSeekFromEnd- _otherwise -> Right tagSeekFromEnd-- tagCreateDirectory :: EventPred- tagCreateDirectory = successful $ \ev _ ->- case eventMockCmd ev of- CreateDirIfMissing True (PExpPath fp) | length (fsPathToList fp) > 1 ->- Left TagCreateDirectory- _otherwise ->- Right tagCreateDirectory-- tagDoesFileExistOK :: EventPred- tagDoesFileExistOK = successful $ \ev suc ->- case (eventMockCmd ev, suc) of- (DoesFileExist _, Bool True) -> Left TagDoesFileExistOK- _otherwise -> Right tagDoesFileExistOK-- tagDoesFileExistKO :: EventPred- tagDoesFileExistKO = successful $ \ev suc ->- case (eventMockCmd ev, suc) of- (DoesFileExist _, Bool False) -> Left TagDoesFileExistKO- _otherwise -> Right tagDoesFileExistKO-- tagDoesDirectoryExistOK :: EventPred- tagDoesDirectoryExistOK = successful $ \ev suc ->- case (eventMockCmd ev, suc) of- (DoesDirectoryExist (PExpPath fp), Bool True) | not (fp == mkFsPath ["/"])- -> Left TagDoesDirectoryExistOK- _otherwise -> Right tagDoesDirectoryExistOK-- tagDoesDirectoryExistKO :: EventPred- tagDoesDirectoryExistKO = successful $ \ev suc ->- case (eventMockCmd ev, suc) of- (DoesDirectoryExist _, Bool False) -> Left TagDoesDirectoryExistKO- _otherwise -> Right tagDoesDirectoryExistKO-- tagRemoveDirectoryRecursive :: Set FsPath -> EventPred- tagRemoveDirectoryRecursive removed = successful $ \ev _suc ->- case eventMockCmd ev of- RemoveDirRecursive fe -> Right $ tagRemoveDirectoryRecursive $ Set.insert fp removed- where- fp = evalPathExpr fe- DoesFileExist fe -> if Set.member fp removed- then Left TagRemoveDirectoryRecursive- else Right $ tagRemoveDirectoryRecursive removed- where- fp = evalPathExpr fe- _otherwise -> Right $ tagRemoveDirectoryRecursive removed-- tagRemoveFile :: Set FsPath -> EventPred- tagRemoveFile removed = successful $ \ev _suc ->- case eventMockCmd ev of- RemoveFile fe -> Right $ tagRemoveFile $ Set.insert fp removed- where- fp = evalPathExpr fe- DoesFileExist fe -> if Set.member fp removed- then Left TagRemoveFile- else Right $ tagRemoveFile removed- where- fp = evalPathExpr fe- _otherwise -> Right $ tagRemoveFile removed-- tagRenameFile :: EventPred- tagRenameFile = successful $ \ev _suc ->- case eventMockCmd ev of- RenameFile {} -> Left TagRenameFile- _otherwise -> Right tagRenameFile-- tagClosedTwice :: Set HandleMock -> EventPred- tagClosedTwice closed = successful $ \ev _suc ->- case eventMockCmd ev of- Close (Handle h _) | Set.member h closed -> Left TagClosedTwice- Close (Handle h _) -> Right $ tagClosedTwice $ Set.insert h closed- _otherwise -> Right $ tagClosedTwice closed-- -- this never succeeds because of an fsLimitation- tagReadInvalid :: Set HandleMock -> EventPred- tagReadInvalid openAppend = C.predicate $ \ev ->- case (eventMockCmd ev, eventMockResp ev) of- (Open _ (AppendMode _), Resp (Right (WHandle _ (Handle h _)))) ->- Right $ tagReadInvalid $ Set.insert h openAppend- (Close (Handle h _), Resp (Right _)) ->- Right $ tagReadInvalid $ Set.delete h openAppend- (Get (Handle h _) _, Resp (Left _)) | Set.member h openAppend ->- Left TagReadInvalid- (GetAt (Handle h _) _ _, Resp (Left _)) | Set.member h openAppend ->- Left TagReadInvalid- _otherwise -> Right $ tagReadInvalid openAppend-- tagWriteInvalid :: Set HandleMock -> EventPred- tagWriteInvalid openRead = C.predicate $ \ev ->- case (eventMockCmd ev, eventMockResp ev) of- (Open _ ReadMode, Resp (Right (RHandle (Handle h _)))) ->- Right $ tagWriteInvalid $ Set.insert h openRead- (Close (Handle h _), Resp (Right _)) ->- Right $ tagWriteInvalid $ Set.delete h openRead- (Put (Handle h _) _, _) | Set.member h openRead ->- Left TagWriteInvalid- _otherwise -> Right $ tagWriteInvalid openRead-- tagPutSeekGet :: Set HandleMock -> Set HandleMock -> EventPred- tagPutSeekGet put seek = successful $ \ev _suc ->- case eventMockCmd ev of- Put (Handle h _) bs | BS.length bs > 0 ->- Right $ tagPutSeekGet (Set.insert h put) seek- Seek (Handle h _) RelativeSeek n | n > 0 && Set.member h put ->- Right $ tagPutSeekGet put (Set.insert h seek)- Get (Handle h _) n | n > 0 && Set.member h seek ->- Left TagPutSeekGet- GetAt (Handle h _) n _ | n > 0 && Set.member h seek ->- Left TagPutSeekGet- _otherwise -> Right $ tagPutSeekGet put seek-- tagPutSeekNegGet :: Set HandleMock -> Set HandleMock -> EventPred- tagPutSeekNegGet put seek = successful $ \ev _suc ->- case eventMockCmd ev of- Put (Handle h _) bs | BS.length bs > 0 ->- Right $ tagPutSeekNegGet (Set.insert h put) seek- Seek (Handle h _) RelativeSeek n | n < 0 && Set.member h put ->- Right $ tagPutSeekNegGet put (Set.insert h seek)- Get (Handle h _) n | n > 0 && Set.member h seek ->- Left TagPutSeekNegGet- GetAt (Handle h _) n _ | n > 0 && Set.member h seek ->- Left TagPutSeekNegGet- _otherwise -> Right $ tagPutSeekNegGet put seek-- tagExclusiveFail :: EventPred- tagExclusiveFail = C.predicate $ \ev ->- case (eventMockCmd ev, eventMockResp ev) of- (Open _ mode, Resp (Left fsError))- | MustBeNew <- allowExisting mode- , fsErrorType fsError == FsResourceAlreadyExist ->- Left TagExclusiveFail- _otherwise -> Right tagExclusiveFail-- tagReadModeMustExist :: EventPred- tagReadModeMustExist = C.predicate $ \ev ->- case (eventMockCmd ev, eventMockResp ev) of- (Open _ ReadMode, Resp (Right (RHandle _))) -> Left TagReadModeMustExist- _otherwise -> Right tagReadModeMustExist-- tagReadModeMustExistFail :: EventPred- tagReadModeMustExistFail = C.predicate $ \ev ->- case (eventMockCmd ev, eventMockResp ev) of- (Open _ ReadMode, Resp (Left fsError))- | fsErrorType fsError == FsResourceDoesNotExist ->- Left TagReadModeMustExistFail- _otherwise -> Right tagReadModeMustExistFail-- tagFileMustExist :: EventPred- tagFileMustExist = C.predicate $ \ev ->- case (eventMockCmd ev, eventMockResp ev) of- (Open _ mode, Resp (Right (WHandle _ _)))- | MustExist <- allowExisting mode- , mode /= ReadMode- -> Left TagFileMustExist- _otherwise -> Right tagFileMustExist-- tagFileMustExistFail :: EventPred- tagFileMustExistFail = C.predicate $ \ev ->- case (eventMockCmd ev, eventMockResp ev) of- (Open _ mode, Resp (Left fsError))- | MustExist <- allowExisting mode- , mode /= ReadMode- , fsErrorType fsError == FsResourceDoesNotExist ->- Left TagFileMustExistFail- _otherwise -> Right tagFileMustExistFail-- tagReadEOF :: EventPred- tagReadEOF = successful $ \ev suc ->- case (eventMockCmd ev, suc) of- (Get _ n, ByteString bl)- | n > 0, BS.null bl -> Left TagReadEOF- _otherwise -> Right tagReadEOF-- tagPread :: EventPred- tagPread = successful $ \ev _ ->- case eventMockCmd ev of- 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-execCmd model (QSM.Command cmd resp _vars) = lockstep model cmd resp---- | 'execCmds' is just the repeated form of 'execCmd'-execCmds :: QSM.Commands (At Cmd) (At Resp) -> [Event Symbolic]-execCmds = \(QSM.Commands cs) -> go initModel cs- where- go :: Model Symbolic -> [QSM.Command (At Cmd) (At Resp)] -> [Event Symbolic]- go _ [] = []- go m (c : cs) = let ev = execCmd m c in ev : go (eventAfter ev) cs--{-------------------------------------------------------------------------------- Required instances-- The 'ToExpr' constraints come from "Data.TreeDiff".--------------------------------------------------------------------------------}--constrInfo :: SOP.HasDatatypeInfo a- => proxy a- -> SOP.NP SOP.ConstructorInfo (SOP.Code a)-constrInfo = SOP.constructorInfo . SOP.datatypeInfo--constrName :: forall a. SOP.HasDatatypeInfo a => a -> String-constrName a =- SOP.hcollapse $ SOP.hliftA2 go (constrInfo p) (SOP.unSOP (SOP.from a))- where- go :: SOP.ConstructorInfo b -> SOP.NP SOP.I b -> SOP.K String b- go nfo _ = SOP.K $ SOP.constructorName nfo-- p = Proxy @a--constrNames :: SOP.HasDatatypeInfo a => proxy a -> [String]-constrNames p =- SOP.hcollapse $ SOP.hmap go (constrInfo p)- where- go :: SOP.ConstructorInfo a -> SOP.K String a- go nfo = SOP.K $ SOP.constructorName nfo---instance QSM.CommandNames (At Cmd) where- cmdName (At cmd) = constrName cmd- cmdNames _ = constrNames (Proxy @(Cmd () ()))--deriving instance ToExpr a => ToExpr (FsTree a)-deriving instance ToExpr fp => ToExpr (PathExpr fp)--deriving instance ToExpr HandleMock-deriving instance ToExpr MockFS-deriving instance ToExpr Mock.HandleState-deriving instance ToExpr Mock.OpenHandleState-deriving instance ToExpr Mock.ClosedHandleState-deriving instance ToExpr Mock.FilePtr-deriving instance ToExpr FsPath--instance ToExpr (Handle h) where- toExpr = defaultExprViaShow--deriving instance ToExpr (Model Concrete)--{-------------------------------------------------------------------------------- Top-level tests--------------------------------------------------------------------------------}---- | Show minimal examples for each of the generated tags------ TODO: The examples listed are not always minimal. I'm not entirely sure why.-showLabelledExamples' :: Maybe Int- -- ^ Seed- -> Int- -- ^ Number of tests to run to find examples- -> (Tag -> Bool)- -- ^ Tag filter (can be @const True@)- -> IO ()-showLabelledExamples' mReplay numTests focus = do- replaySeed <- case mReplay of- Nothing -> getStdRandom (randomR (1,999999))- Just seed -> return seed-- labelledExamplesWith (stdArgs { replay = Just (mkQCGen replaySeed, 0)- , maxSuccess = numTests- }) $- forAllShrinkShow (QSM.generateCommands sm' Nothing)- (QSM.shrinkCommands sm')- pp $ \cmds ->- collects (filter focus . tag . execCmds $ cmds) $- property True-- putStrLn $ "Used replaySeed " ++ show replaySeed- where- sm' = sm unusedHasFS- pp = \x -> ppShow x ++ "\n" ++ condense x-- collects :: Show a => [a] -> Property -> Property- collects = repeatedly collect- where- repeatedly :: (a -> b -> b) -> ([a] -> b -> b)- repeatedly = flip . foldl' . flip--showLabelledExamples :: IO ()-showLabelledExamples = showLabelledExamples' Nothing 1000 (const True)--prop_sequential :: Property-prop_sequential = withMaxSuccess 1000 $- QSM.forAllCommands (sm unusedHasFS) Nothing $ runCmds--runCmds :: QSM.Commands (At Cmd) (At Resp) -> Property-runCmds cmds = QC.monadicIO $ do- (tstTmpDir, hist, res) <- QC.run $- withSystemTempDirectory "StateMachine" $ \tstTmpDir -> do- let mount = MountPoint tstTmpDir- hfs = ioHasFS mount- sm' = sm hfs-- (hist, model, res) <- QSM.runCommands' sm' cmds-- -- Close all open handles- forM_ (RE.keys (knownHandles model)) $ hClose hfs . QSM.concrete-- return (tstTmpDir, hist, res)-- QSM.prettyCommands (sm unusedHasFS) hist- $ QSM.checkCommandNames cmds- $ tabulate "Tags" (map show $ tag (execCmds cmds))- $ counterexample ("Mount point: " ++ tstTmpDir)- $ res === QSM.Ok--tests :: TestTree-tests = testGroup "Test.System.FS.StateMachine" [- testProperty "q-s-m" $ prop_sequential- , localOption (QuickCheckTests 1)- $ testProperty "regression_removeFileOnDir" $ runCmds regression_removeFileOnDir- ]---- | Unused HasFS------ 'forAllCommands' wants the entire state machine as argument, but we need the--- HasFS only when /executing/ the commands in IO. We can therefore generate the--- commands with a dummy HasFS, and then inside the property construct a--- temporary directory which we can use for execution.-unusedHasFS :: HasFS m h-unusedHasFS = error "HasFS not used during command generation"---- | The error numbers returned by Linux vs. MacOS differ when using--- 'removeFile' on a directory. The model mainly mimicks Linux-style errors,--- which results in an 'FsResourceInappropriateType' error, whereas on MacOS it--- results in an 'FsInsufficientPermissions' error. The implementation of--- 'F.sameError' was made more lenient for MacOS in fs-sim#41 to allow this--- model-SUT discrepancy to occur without making the tests fail. We might revist--- this /temporary/ fix in the future, see fs-sim#45.-regression_removeFileOnDir :: QSM.Commands (At Cmd) (At Resp)-regression_removeFileOnDir = QSM.Commands {unCommands = [- QSM.Command- (At {unAt =- CreateDirIfMissing- True- (PExpPath (mkFsPath ["x"]))})- (At {unAt = Resp {getResp =- Right (Path (QSM.Reference (QSM.Symbolic (QSM.Var 0))) ())}})- [QSM.Var 0]- , QSM.Command- (At {unAt =- RemoveFile- (PExpPath (mkFsPath ["x"]))})- (At {unAt = Resp {getResp =- Left (FsError {- fsErrorType = FsResourceInappropriateType- , fsErrorPath = FsErrorPath Nothing (mkFsPath ["x"])- , fsErrorString = "expected file"- , fsErrorNo = Nothing- , fsErrorStack = prettyCallStack, fsLimitation = False})}})- []- ]}--{-------------------------------------------------------------------------------- Debugging--------------------------------------------------------------------------------}---- | Debugging: show @n@ levels of shrink steps (with some required tags)------ This can be useful when debugging the shrinker-_showTaggedShrinks :: ([Tag] -> Bool) -- ^ Required tags- -> Int -- ^ Number of shrink steps- -> QSM.Commands (At Cmd) (At Resp)- -> IO ()-_showTaggedShrinks hasRequiredTags numLevels = go 0- where- go :: Int -> QSM.Commands (At Cmd) (At Resp) -> IO ()- go n _ | n == numLevels = return ()- go n cmds = do- if hasRequiredTags tags then do- putStrLn $ replicate n '\t' ++ condense (cmds, tags)- forM_ shrinks $ go (n + 1)- else- return ()- where- tags = tag $ execCmds cmds- shrinks = QSM.shrinkCommands (sm unusedHasFS) cmds--{-------------------------------------------------------------------------------- Pretty-printing--------------------------------------------------------------------------------}--instance Condense fp => Condense (PathExpr fp) where- condense (PExpPath fp) = condense fp- condense (PExpRef fp) = condense fp- condense (PExpParentOf fp) = condense fp ++ "/.."--instance (Condense fp, Condense h) => Condense (Cmd fp h) where- condense = L.intercalate " " . go- where- go (Open fp mode) = ["open", condense fp, condense mode]- 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 (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]- go (CreateDirIfMissing p fp) = ["createDirIfMissing", condense p, condense fp]- go (ListDirectory fp) = ["listDirectory", condense fp]- go (DoesDirectoryExist fp) = ["doesDirectoryExist", condense fp]- go (DoesFileExist fp) = ["doesFileExist", condense fp]- go (RemoveDirRecursive fp) = ["removeDirectoryRecursive", condense fp]- go (RemoveFile fp) = ["removeFile", condense fp]- go (RenameFile fp1 fp2) = ["renameFile", condense fp1, condense fp2]--instance Condense1 r => Condense (Cmd :@ r) where- condense (At cmd) = condense cmd--instance Condense Tag where- condense = show--instance Condense AbsOffset where- condense = show--instance Condense ByteCount where- condense = show--{-------------------------------------------------------------------------------- (Orphan) condense instance for QSM types--------------------------------------------------------------------------------}--instance Condense QSM.Var where- condense (QSM.Var i) = "x" ++ condense i--instance Condense1 Symbolic where- liftCondense _ (QSM.Symbolic a) = condense a--instance Condense (QSM.Opaque a) where- condense _ = "<>"--instance (Condense1 r, Condense a) => Condense (QSM.Reference a r) where- condense (QSM.Reference ra) = condense1 ra--instance Condense (cmd Symbolic) => Condense (QSM.Command cmd resp) where- condense = \(QSM.Command cmd _resp vars) ->- L.intercalate " " $ go cmd vars- where- go :: cmd Symbolic -> [QSM.Var] -> [String]- go cmd [] = [condense cmd]- go cmd xs = [condense xs, "<-", condense cmd]--instance Condense (cmd Symbolic) => Condense (QSM.Commands cmd resp) where- condense (QSM.Commands cmds) = unlines $ "do" : map (indent . condense) cmds- where- indent :: String -> String- indent = (" " ++)+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-orphans #-}++{- HLINT ignore "Use camelCase" -}++-- | Tests for our filesystem abstractions.+--+-- The blogpost [An in-depth look at __quickcheck-state-machine__](http://www.well-typed.com/blog/2019/01/qsm-in-depth/)+-- uses these tests of the file system abstraction as a case study and outlines the+-- general approach. Like all of the model based tests, this consists of+--+-- 1. A set of commands+-- 2. A model against which we execute those commands+-- 3. An interpreter of those commands against the real implementation+-- 4. A generator and a shrinker for sequences of these commands+-- 5. A way to /label/ generated sequences so that we can verify that the tests+-- are covering what we think they should be covering.+--+-- The sequences generated are then executed against both the model and the+-- implementation, and the results are compared.+--+-- In this particular case, the commands are file system operations such as+-- create a directory, open a file, write some bytes, etc. The model is a very+-- simple one: we simply model a file system as a tree of 'ByteString's (the raw+-- bytes in the files). The goal of the model, of course, is not to provide one+-- that mirrors the low-level details of the real implementation, but rather one+-- that abstracts over such details and provides a /specification/.+--+-- The file system abstraction however is a bit of an unusual test in that this+-- is really "reverse model testing": the tests compare the model to the real+-- file system, but we are of course not developing a file system. Instead, the+-- tests serve to make sure that we got the model right, which we can then use+-- in the tests of the rest of the consensus layer.+module Test.System.FS.StateMachine+ ( showLabelledExamples+ , tests+ ) where++#if __GLASGOW_HASKELL__<910+import Data.Foldable (foldl')+#endif++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+import Data.Bitraversable+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import Data.Functor.Classes+import Data.Int (Int64)+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+import qualified Data.Text as Text+import Data.Word (Word64)+import GHC.Generics+import GHC.Stack hiding (prettyCallStack)+import qualified Generics.SOP as SOP+import System.FS.API+import System.FS.CallStack+import System.FS.Condense+import System.FS.IO+import System.FS.Sim.FsTree (FsTree (..))+import System.FS.Sim.MockFS (HandleMock, MockFS)+import qualified System.FS.Sim.MockFS as Mock+import System.FS.Sim.Prim+import System.IO.Temp (withSystemTempDirectory)+import System.Posix.Types (ByteCount)+import System.Random (getStdRandom, randomR)+import Test.QuickCheck+import qualified Test.QuickCheck.Monadic as QC+import Test.QuickCheck.Random (mkQCGen)+import Test.StateMachine (Concrete, Symbolic)+import qualified Test.StateMachine as QSM+import qualified Test.StateMachine.Labelling as C+import qualified Test.StateMachine.Sequential as QSM+import Test.StateMachine.TreeDiff+import qualified Test.StateMachine.Types as QSM+import qualified Test.StateMachine.Types.Rank2 as Rank2+import Test.Tasty (TestTree, localOption, testGroup)+import Test.Tasty.QuickCheck+import Test.Util.RefEnv (RefEnv)+import qualified Test.Util.RefEnv as RE+import Text.Read (readMaybe)+import Text.Show.Pretty (ppShow)++{-------------------------------------------------------------------------------+ Path expressions+-------------------------------------------------------------------------------}++data PathExpr fp+ = PExpPath FsPath+ | PExpRef fp+ | PExpParentOf fp+ deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)++evalPathExpr :: PathExpr FsPath -> FsPath+evalPathExpr (PExpPath fp) = fp+evalPathExpr (PExpRef fp) = fp+evalPathExpr (PExpParentOf fp) = fsPathInit fp++{-------------------------------------------------------------------------------+ Abstract model+-------------------------------------------------------------------------------}++-- | Commands+--+-- We will be interested in three different instantiations of @h@:+--+-- > Cmd HandleMock+-- > Cmd (Reference (Opaque (FsHandle IOFSE)) Concrete)+-- > Cmd (Reference (Opaque (FsHandle IOFSE)) Symbolic)+--+-- Key idea is that all this infrastructure will be applicable both to+-- the model and to the system under test.+--+-- TODO: Program such as "copy what you read" is currently not expressible+-- in our language. Does this matter?+data Cmd fp h+ = Open (PathExpr fp) OpenMode+ | Close h+ | IsOpen 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)+ | CreateDirIfMissing Bool (PathExpr fp)+ | ListDirectory (PathExpr fp)+ | DoesDirectoryExist (PathExpr fp)+ | DoesFileExist (PathExpr fp)+ | RemoveDirRecursive (PathExpr fp)+ | RemoveFile (PathExpr fp)+ | RenameFile (PathExpr fp) (PathExpr fp)+ deriving (Generic, Show, Functor, Foldable, Traversable)++deriving instance SOP.Generic (Cmd fp h)+deriving instance SOP.HasDatatypeInfo (Cmd fp h)++-- | Successful result+data Success fp h+ = WHandle fp h+ | RHandle h+ | Unit ()+ | Path fp ()+ | Word64 Word64+ | ByteString ByteString+ | ByteCount ByteCount -- PutBuf, PutBufAt+ | BCBS ByteCount ByteString -- GetBuf, GetBufAt+ | Strings (Set String)+ | Bool Bool+ deriving (Eq, Show, Functor, Foldable)++-- | Successful semantics+run ::+ forall m h.+ (PrimMonad m, HasCallStack) =>+ HasFS m h ->+ Cmd FsPath (Handle h) ->+ m (Success FsPath (Handle h))+run hasFS@HasFS{..} = go+ where+ go :: Cmd FsPath (Handle h) -> m (Success FsPath (Handle h))+ go (Open pe mode) =+ case mode of+ ReadMode -> withPE pe (\_ -> RHandle) $ \fp -> hOpen fp mode+ _otherwise -> withPE pe WHandle $ \fp -> hOpen fp mode+ go (CreateDir pe) = withPE pe Path $ createDirectory+ go (CreateDirIfMissing b pe) = withPE pe Path $ createDirectoryIfMissing b+ go (IsOpen h) = Bool <$> hIsOpen h+ go (Close h) = Unit <$> hClose h+ go (Seek h mode sz) = Unit <$> hSeek h mode sz+ -- 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.+ 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 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 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+ go (DoesDirectoryExist pe) = withPE pe (const Bool) $ doesDirectoryExist+ go (DoesFileExist pe) = withPE pe (const Bool) $ doesFileExist+ go (RemoveDirRecursive pe) = withPE pe (const Unit) $ removeDirectoryRecursive+ go (RemoveFile pe) = withPE pe (const Unit) $ removeFile+ go (RenameFile pe1 pe2) = withPEs pe1 pe2 (\_ _ -> Unit) $ renameFile++ withPE ::+ PathExpr FsPath ->+ (FsPath -> a -> Success FsPath (Handle h)) ->+ (FsPath -> m a) ->+ m (Success FsPath (Handle h))+ withPE pe r f = let fp = evalPathExpr pe in r fp <$> f fp++ withPEs ::+ PathExpr FsPath ->+ PathExpr FsPath ->+ (FsPath -> FsPath -> a -> Success FsPath (Handle h)) ->+ (FsPath -> FsPath -> m a) ->+ m (Success FsPath (Handle h))+ withPEs pe1 pe2 r f =+ let fp1 = evalPathExpr pe1+ fp2 = evalPathExpr pe2+ in r fp1 fp2 <$> f fp1 fp2++{-------------------------------------------------------------------------------+ Detecting partial reads/writes of the tested IO implementation+-------------------------------------------------------------------------------}++{- Note [Checking for partial reads/writes]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++ The functions 'hGetSome', 'hGetSomeAt' and 'hPutSome' might perform partial+ reads/writes, depending on the underlying implementation, see+ [ouroboros-network#277](https://github.com/IntersectMBO/ouroboros-network/issues/277).+ While the model will always perform complete reads/writes, the real IO+ implementation we are testing /might/ actually perform partial reads/writes.+ This testsuite will fail when such a partial read or write is performed in the+ real IO implementation, as these are undeterministic and the model will no+ longer correspond to the real implementation. See+ [ouroboros-network#502](https://github.com/IntersectMBO/ouroboros-network/issues/502)+ were we tracked this issue.++ So far, on all systems the tests have been run on, no partial reads/writes+ have ever been noticed. However, we cannot be sure that the tests will never+ be run on a system or file-system that might result in partial reads/writes.+ Therefore, we use checked variants of 'hGetSome', 'hGetSomeAt' and 'hPutSome'+ that detect partial reads/writes and that will signal an error so that the+ developer noticing the failing test doesn't waste any time debugging the+ implementation while the failing test was actually due to an unexpected+ partial read/write.++ For compound functions like 'hGetExactly' and 'hPutAll', this is not a good+ solution. However, since we are only testing primitives, the solution is fine+ for our purposes.++ The problem with compound functions is that to run a single 'Cmd', we now have+ to run multiple primitive 'HasFS' functions. Each of those primitive functions+ might update the state of the model and the real world. Now when the second,+ third, ..., or n-th primitive functions fails (while running a single 'Cmd'),+ the whole 'Cmd' failed and the model is not updated. This means that we+ continue with the model as it was /before/ running the 'Cmd'. However, these+ primitive functions might have changed the model /and/ the state of the real+ implementation. In that case, we can no longer guarantee that the model and+ the real implementation are in sync.+-}++hGetSomeChecked ::+ (Monad m, HasCallStack) =>+ HasFS m h -> Handle h -> Word64 -> m ByteString+hGetSomeChecked HasFS{..} h n = do+ bytes <- hGetSome h n+ when (fromIntegral (BS.length bytes) /= 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 Note [Checking for partial reads/writes]"+ return bytes++hGetSomeAtChecked ::+ (Monad m, HasCallStack) =>+ HasFS m h -> Handle h -> Word64 -> AbsOffset -> m ByteString+hGetSomeAtChecked HasFS{..} h n o = do+ bytes <- hGetSomeAt h n o+ when (fromIntegral (BS.length bytes) /= n) $ do+ moreBytes <- hGetSomeAt h 1 $ o + fromIntegral (BS.length bytes)+ -- 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 Note [Checking for partial reads/writes]"+ return bytes++hPutSomeChecked ::+ (Monad m, HasCallStack) =>+ HasFS m h -> Handle h -> ByteString -> m Word64+hPutSomeChecked HasFS{..} h bytes = do+ n <- hPutSome h bytes+ if fromIntegral (BS.length bytes) /= n+ then error "Unsupported partial write detected, see Note [Checking for partial reads/writes]"+ else return n++hGetBufSomeChecked ::+ (HasCallStack, PrimMonad m) =>+ HasFS m h ->+ Handle h ->+ ByteCount ->+ m (ByteCount, ByteString)+hGetBufSomeChecked HasFS{..} 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 ->+ Handle h ->+ ByteCount ->+ AbsOffset ->+ m (ByteCount, ByteString)+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'+ 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) =>+ HasFS m h ->+ Handle h ->+ ByteString ->+ ByteCount ->+ m ByteCount+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+ if n /= n'+ then error "Unsupported partial write detected, see #502"+ else return n++hPutBufSomeAtChecked ::+ (HasCallStack, PrimMonad m) =>+ HasFS m h ->+ Handle h ->+ ByteString ->+ ByteCount ->+ AbsOffset ->+ m ByteCount+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+ 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+-------------------------------------------------------------------------------}++-- | For some error types, our mock FS implementation, which is based on+-- (Ubuntu) Linux might throw different errors than the actual file system. In+-- particular, this problem occurs when the file system under test is a Windows+-- or MacOS one. In these cases, the 'sameError' comparison function, which is+-- used to compare the 'FsError's that the mock throws against the 'FsError's+-- that the SUT throws, is more lenient than the default 'sameFsError'.+sameError :: FsError -> FsError -> Bool+#if defined(mingw32_HOST_OS)+-- For the following error types, our mock FS implementation (and the Posix+-- implementation) throw the same errors:+--+-- * 'FsReachedEOF'+-- * 'FsDeviceFull'+-- * 'FsResourceAlreadyInUse'+--+-- For other cases, Windows throws different errors than the mock FS+-- implementation.+sameError e1 e2 = fsErrorPath e1 == fsErrorPath e2+ && sameFsErrorType (fsErrorType e1) (fsErrorType e2)+ where+ sameFsErrorType ty1 ty2 = case (ty1, ty2) of+ (FsReachedEOF, FsReachedEOF) -> True+ (FsReachedEOF, _) -> False+ (_, FsReachedEOF) -> False+ (FsDeviceFull, FsDeviceFull) -> True+ (FsDeviceFull, _) -> False+ (_, FsDeviceFull) -> False+ (FsResourceAlreadyInUse, FsResourceAlreadyInUse) -> True+ (FsResourceAlreadyInUse, _) -> False+ (_, FsResourceAlreadyInUse) -> False+ (_, _) -> True+#elif defined(darwin_HOST_OS)+-- Check default implementation first using 'sameFsError', and otherwise permit+-- some combinations of error types that are not structurally equal.+sameError e1 e2 = sameFsError e1 e2+ || (fsErrorPath e1 == fsErrorPath e2+ && permitted (fsErrorType e1) (fsErrorType e2))+ where+ -- error types that are permitted to differ for technical reasons+ permitted ty1 ty2 = case (ty1, ty2) of+ (FsInsufficientPermissions , FsResourceInappropriateType) -> True+ (FsResourceInappropriateType, FsInsufficientPermissions ) -> True+ (_ , _ ) -> False+#else+-- treat every other distribution like it is (Ubuntu) Linux+sameError = sameFsError+#endif++-- | Responses are either successful termination or an error+newtype Resp fp h = Resp {getResp :: Either FsError (Success fp h)}+ deriving (Show, Functor, Foldable)++-- | The 'Eq' instance for 'Resp' uses 'sameError'+instance (Eq fp, Eq h) => Eq (Resp fp h) where+ Resp (Left e) == Resp (Left e') = sameError e e'+ Resp (Right a) == Resp (Right a') = a == a'+ _ == _ = False++runPure ::+ Cmd FsPath (Handle HandleMock) ->+ MockFS ->+ (Resp FsPath (Handle HandleMock), MockFS)+runPure cmd mockFS =+ aux $ runST $ runFSSimT (run primHasMockFS cmd) mockFS+ where+ aux ::+ Either FsError (Success FsPath (Handle HandleMock), MockFS) ->+ (Resp FsPath (Handle HandleMock), MockFS)+ aux (Left e) = (Resp (Left e), mockFS)+ aux (Right (r, mockFS')) = (Resp (Right r), mockFS')++runIO ::+ HasFS IO HandleIO ->+ Cmd FsPath (Handle HandleIO) ->+ IO (Resp FsPath (Handle HandleIO))+runIO hfs cmd = Resp <$> E.try (run hfs cmd)++{-------------------------------------------------------------------------------+ Bitraversable instances+-------------------------------------------------------------------------------}++TH.deriveBifunctor ''Cmd+TH.deriveBifoldable ''Cmd+TH.deriveBitraversable ''Cmd++TH.deriveBifunctor ''Success+TH.deriveBifoldable ''Success+TH.deriveBitraversable ''Success++TH.deriveBifunctor ''Resp+TH.deriveBifoldable ''Resp+TH.deriveBitraversable ''Resp++{-------------------------------------------------------------------------------+ Collect arguments+-------------------------------------------------------------------------------}++paths :: Bitraversable t => t fp h -> [fp]+paths = bifoldMap (: []) (const [])++handles :: Bitraversable t => t fp h -> [h]+handles = bifoldMap (const []) (: [])++{-------------------------------------------------------------------------------+ Model+-------------------------------------------------------------------------------}++-- | Concrete or symbolic reference to a path+type PathRef = QSM.Reference FsPath++-- | Concrete or symbolic reference to an IO file handle+type HandleRef = QSM.Reference (Handle HandleIO)++-- | Mapping between real IO file handles and mock file handles+type KnownHandles = RefEnv (Handle HandleIO) (Handle HandleMock)++-- | Mapping between path references and paths+type KnownPaths = RefEnv FsPath FsPath++resolvePathExpr :: Eq1 r => KnownPaths r -> PathExpr (PathRef r) -> FsPath+resolvePathExpr knownPaths = evalPathExpr . fmap (knownPaths RE.!)++-- | Execution model+data Model r = Model+ { mockFS :: MockFS+ , knownPaths :: KnownPaths r+ , knownHandles :: KnownHandles r+ }+ deriving (Show, Generic)++-- | Initial model+initModel :: Model r+initModel = Model Mock.empty RE.empty RE.empty++-- | Key property of the model is that we can go from real to mock responses+toMock ::+ (Bifunctor t, Eq1 r) =>+ Model r -> t :@ r -> t FsPath (Handle HandleMock)+toMock Model{..} (At r) = bimap (knownPaths RE.!) (knownHandles RE.!) r++-- | Step the mock semantics+--+-- We cannot step the whole Model here (see 'Event', below)+step ::+ Eq1 r =>+ Model r -> Cmd :@ r -> (Resp FsPath (Handle HandleMock), MockFS)+step model@Model{..} cmd = runPure (toMock model cmd) mockFS++-- | Open read handles+openHandles :: Model r -> [Handle HandleMock]+openHandles Model{..} =+ filter isOpen (RE.elems knownHandles)+ where+ isOpen :: Handle HandleMock -> Bool+ isOpen (Handle h _) = Mock.handleIsOpen mockFS h++{-------------------------------------------------------------------------------+ Wrapping in quickcheck-state-machine references+-------------------------------------------------------------------------------}++-- | Instantiate functor @f@ to @f (PathRef r) (HandleRef r)@+--+-- > Cmd :@ Concrete ~ Cmd (PathRef Concrete) (HandleRef Concrete)+newtype At t r = At {unAt :: (t (PathRef r) (HandleRef r))}+ deriving Generic++-- | Alias for 'At'+type (:@) t r = At t r++deriving instance Show1 r => Show (Cmd :@ r)+deriving instance Show1 r => Show (Resp :@ r)+deriving instance Eq1 r => Eq (Resp :@ r)++instance Bifoldable t => Rank2.Foldable (At t) where+ foldMap = \f (At x) -> bifoldMap (app f) (app f) x+ where+ app :: (r x -> m) -> QSM.Reference x r -> m+ app f (QSM.Reference x) = f x++instance Bifunctor t => Rank2.Functor (At t) where+ fmap = \f (At x) -> At (bimap (app f) (app f) x)+ where+ app :: (r x -> r' x) -> QSM.Reference x r -> QSM.Reference x r'+ app f (QSM.Reference x) = QSM.Reference (f x)++instance Bitraversable t => Rank2.Traversable (At t) where+ traverse = \f (At x) -> At <$> bitraverse (app f) (app f) x+ where+ app ::+ Functor f =>+ (r x -> f (r' x)) -> QSM.Reference x r -> f (QSM.Reference x r')+ app f (QSM.Reference x) = QSM.Reference <$> f x++{-------------------------------------------------------------------------------+ Events+-------------------------------------------------------------------------------}++-- | An event records the model before and after a command along with the+-- command itself and its response+data Event r = Event+ { eventBefore :: Model r+ , eventCmd :: Cmd :@ r+ , eventAfter :: Model r+ , eventMockResp :: Resp FsPath (Handle HandleMock)+ }+ deriving Show++eventMockCmd :: Eq1 r => Event r -> Cmd FsPath (Handle HandleMock)+eventMockCmd Event{..} = toMock eventBefore eventCmd++-- | Construct an event+--+-- When we execute both the model and the real implementation in lockstep,+-- we get two responses: this suffices to update the model.+lockstep ::+ forall r.+ (Show1 r, Ord1 r, HasCallStack) =>+ Model r ->+ Cmd :@ r ->+ Resp :@ r ->+ Event r+lockstep model@Model{..} cmd (At resp) =+ Event+ { eventBefore = model+ , eventCmd = cmd+ , eventAfter =+ Model+ { mockFS = mockFS'+ , knownPaths = knownPaths `RE.union` newPaths+ , knownHandles = knownHandles `RE.union` newHandles+ }+ , eventMockResp = resp'+ }+ where+ (resp', mockFS') = step model cmd+ newPaths = RE.fromList $ zip (paths resp) (paths resp')+ newHandles = RE.fromList $ zip (handles resp) (handles resp')++{-------------------------------------------------------------------------------+ Generator+-------------------------------------------------------------------------------}++generator :: Model Symbolic -> Gen (Cmd :@ Symbolic)+generator Model{..} =+ oneof $+ concat+ [ withoutHandle+ , if RE.null knownHandles then [] else withHandle+ ]+ where+ withoutHandle :: [Gen (Cmd :@ Symbolic)]+ withoutHandle =+ [ fmap At $ genOpen+ , fmap At $ CreateDir <$> genPathExpr+ , fmap At $ CreateDirIfMissing <$> arbitrary <*> genPathExpr+ , fmap At $ ListDirectory <$> genPathExpr+ , fmap At $ DoesDirectoryExist <$> genPathExpr+ , fmap At $ DoesFileExist <$> genPathExpr+ , fmap At $ RemoveDirRecursive <$> genPathExpr+ , fmap At $ RemoveFile <$> genPathExpr+ , fmap At $ RenameFile <$> genPathExpr <*> genPathExpr+ ]++ withHandle :: [Gen (Cmd :@ Symbolic)]+ withHandle =+ [ fmap At $ Close <$> genHandle+ , fmap At $ IsOpen <$> genHandle+ , 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+ ]++ genOpen :: Gen (Cmd (PathRef Symbolic) (HandleRef Symbolic))+ genOpen = do+ path <- genPath+ mode <- genMode $ elem path (RE.elems knownPaths)+ return $ Open (PExpPath path) mode++ -- Wrap path in a simple path expression+ -- (References are generated during shrinking only)+ genPathExpr :: Gen (PathExpr fp)+ genPathExpr = PExpPath <$> genPath++ -- We choose from a small list of names so that we reuse names often+ -- We use the same set of files and directories so that we can test+ -- things like trying to open a directory as if it were a file+ genPath :: Gen FsPath+ genPath = do+ n <- choose (0, 3)+ mkFsPath <$> replicateM n (elements ["x", "y", "z"])++ genHandle :: Gen (HandleRef Symbolic)+ genHandle = elements (RE.keys knownHandles)++ genMode :: Bool -> Gen OpenMode+ genMode fileExists =+ frequency+ [ (rf, return ReadMode)+ , (wf, WriteMode <$> genAllowExisting)+ , (wf, AppendMode <$> genAllowExisting)+ , (wf, ReadWriteMode <$> genAllowExisting)+ ]+ where+ -- we try to avoid 'ReadMode' when the file does not exist.+ (rf, wf) = if fileExists then (10, 3) else (1, 3)++ genAllowExisting :: Gen AllowExisting+ genAllowExisting = elements [AllowExisting, MustBeNew, MustExist]++ genSeekMode :: Gen SeekMode+ genSeekMode =+ elements+ [ AbsoluteSeek+ , RelativeSeek+ , SeekFromEnd+ ]++ genOffset :: Gen Int64+ genOffset =+ oneof+ [ return 0+ , choose (1, 10)+ , choose (-1, -10)+ ]++instance Arbitrary AbsOffset where+ arbitrary = AbsOffset . getSmall <$> arbitrary+ shrink ao = AbsOffset <$> shrink (unAbsOffset ao)++{-------------------------------------------------------------------------------+ Temporary files (used in shrinking)+-------------------------------------------------------------------------------}++-- | Temp files are numbered from 1+newtype TempFile = TempFile Int+ deriving Show++instance Condense TempFile where -- basically GNTD+ condense (TempFile n) = condense n++tempToExpr :: TempFile -> PathExpr fp+tempToExpr (TempFile n) = PExpPath (mkFsPath ['t' : show n])++tempFromPath :: FsPath -> Maybe TempFile+tempFromPath fp =+ case map Text.unpack (fsPathToList fp) of+ ['t' : suf] -> do+ n <- readMaybe suf+ guard (n >= 1)+ return $ TempFile n+ _otherwise -> Nothing++{-------------------------------------------------------------------------------+ Shrinking+-------------------------------------------------------------------------------}++-- | When we replace one reference with another, we are careful to impose an+-- order so that we don't end up flipping between references. Since shrinking is+-- greedy this does mean that the choice of reference may influence how much we+-- can shrink later. This is hard to avoid in greedy algorithms.+shrinker :: Model Symbolic -> Cmd :@ Symbolic -> [Cmd :@ Symbolic]+shrinker Model{..} (At cmd) =+ case cmd of+ Open pe mode ->+ concat+ [ case tempFromPath fp of+ Just n ->+ map (\n' -> At $ Open (tempToExpr n') mode) $+ shrinkTempFile n+ Nothing ->+ let mode' = case mode of+ ReadMode -> ReadWriteMode AllowExisting+ _otherwise -> mode+ in [At $ Open (tempToExpr (TempFile numTempFiles)) mode']+ , case mode of+ ReadWriteMode ex ->+ [ At $ Open pe ReadMode+ , At $ Open pe (WriteMode ex)+ ]+ _otherwise ->+ []+ , map (\pe' -> At $ Open pe' mode) $+ replaceWithRef pe (== fp) PExpRef+ ]+ where+ fp :: FsPath+ fp = resolvePathExpr knownPaths pe+ ListDirectory pe ->+ concat+ [ map (At . ListDirectory) $+ replaceWithRef pe ((== fp) . fsPathInit) PExpParentOf+ ]+ where+ fp :: FsPath+ fp = resolvePathExpr knownPaths pe+ Get h n -> At . Get h <$> shrink n+ 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 ->+ []+ where+ -- Replace path with reference+ --+ -- If we are replacing one reference with another, be careful to impose+ -- an ordering so that we don't end up toggling between references.+ replaceWithRef ::+ PathExpr (PathRef Symbolic) ->+ -- current+ (FsPath -> Bool) ->+ -- evaluate candidate+ (PathRef Symbolic -> PathExpr (PathRef Symbolic)) ->+ -- construct replacement+ [PathExpr (PathRef Symbolic)]+ replaceWithRef pe p f =+ filter (canReplace pe) $ map f $ RE.reverseLookup p knownPaths+ where+ canReplace ::+ PathExpr (PathRef Symbolic) -> -- current+ PathExpr (PathRef Symbolic) -> -- candidate+ Bool+ canReplace (PExpRef ref) (PExpRef ref') = ref' < ref+ canReplace (PExpParentOf ref) (PExpParentOf ref') = ref' < ref+ canReplace _ _ = True++ shrinkTempFile :: TempFile -> [TempFile]+ shrinkTempFile (TempFile n) = TempFile . getPositive <$> shrink (Positive n)++ shrinkBytes :: ByteString -> [ByteString]+ shrinkBytes = map BS.pack . shrink . BS.unpack++ numTempFiles :: Int+ numTempFiles = 100++{-------------------------------------------------------------------------------+ Limitations/known bugs+-------------------------------------------------------------------------------}++-- | Known limitations/bugs that we don't want to test for+--+-- NOTE: Can assume all used handles are in known in the model.+knownLimitation :: Model Symbolic -> Cmd :@ Symbolic -> QSM.Logic+knownLimitation model cmd =+ case getResp resp of+ Left FsError{..} -> QSM.Boolean fsLimitation+ _otherwise -> QSM.Bot+ where+ (resp, _mockFS') = step model cmd++{-------------------------------------------------------------------------------+ The final state machine+-------------------------------------------------------------------------------}++-- | Mock a response+--+-- We do this by running the pure semantics and then generating mock+-- references for any new handles.+mock ::+ Model Symbolic ->+ Cmd :@ Symbolic ->+ QSM.GenSym (Resp :@ Symbolic)+mock model cmd = At <$> bitraverse (const QSM.genSym) (const QSM.genSym) resp+ where+ (resp, _mockFS') = step model cmd++precondition :: Model Symbolic -> Cmd :@ Symbolic -> QSM.Logic+precondition m@Model{..} (At cmd) =+ QSM.forAll (handles cmd) (`QSM.member` RE.keys knownHandles)+ QSM.:&& QSM.Boolean (Mock.numOpenHandles mockFS < maxNumOpenHandles)+ QSM.:&& QSM.Not (knownLimitation m (At cmd))+ where+ -- Limit number of open handles to avoid exceeding OS limits+ maxNumOpenHandles = 100++-- | Step the model+--+-- NOTE: This function /must/ be polymorphic in @r@.+transition :: (Show1 r, Ord1 r) => Model r -> Cmd :@ r -> Resp :@ r -> Model r+transition model cmd = eventAfter . lockstep model cmd++postcondition ::+ Model Concrete ->+ Cmd :@ Concrete ->+ Resp :@ Concrete ->+ QSM.Logic+postcondition model cmd resp =+ toMock (eventAfter ev) resp+ QSM..== eventMockResp ev+ QSM..&& errorHasMountPoint (getResp $ unAt resp)+ where+ ev = lockstep model cmd resp++ errorHasMountPoint :: Either FsError a -> QSM.Logic+ errorHasMountPoint (Right _) = QSM.Top+ errorHasMountPoint (Left fsError) = QSM.Boolean $ hasMountPoint fsError++semantics :: HasFS IO HandleIO -> Cmd :@ Concrete -> IO (Resp :@ Concrete)+semantics hfs (At cmd) =+ At . bimap QSM.reference QSM.reference+ <$> runIO hfs (bimap QSM.concrete QSM.concrete cmd)++-- | The state machine proper+sm :: HasFS IO HandleIO -> QSM.StateMachine Model (At Cmd) IO (At Resp)+sm hfs =+ QSM.StateMachine+ { initModel = initModel+ , transition = transition+ , precondition = precondition+ , postcondition = postcondition+ , generator = Just . generator+ , shrinker = shrinker+ , semantics = semantics hfs+ , mock = mock+ , cleanup = QSM.noCleanup+ , invariant = Nothing+ }++{-------------------------------------------------------------------------------+ Labelling+-------------------------------------------------------------------------------}++data Tag+ = -- | Create directory then list its parent+ --+ -- > CreateDir [x, .., y, z]+ -- > ListDirectory [x, .., y]+ TagCreateDirThenListDir+ | -- | Create a directory with its parents, then list its parents+ --+ -- > CreateDirIfMissing True [x, .., y, z]+ -- > ListDirectory [x, .., y]+ --+ -- Note that this implies all directories must have been created.+ TagCreateDirWithParentsThenListDir+ | -- | Have a least N open files+ --+ -- > Open ..+ -- > .. --+ -- > Open ..+ --+ -- (with not too many Close calls in between).+ TagAtLeastNOpenFiles Int+ | -- | Write, then truncate, then write again+ --+ -- > Put ..+ -- > Truncate .. (deleting some but not all of the bytes already written)+ -- > Put (write some different bytes)+ --+ -- Verifies that we correctly modify the file pointer.+ TagPutTruncatePut+ | -- | Concurrent writer and reader+ --+ -- > h1 <- Open fp WriteMode ..+ -- > h2 <- Open fp ReadMode ..+ -- > Put h1 ..+ -- > Get h2 ..+ TagConcurrentWriterReader+ | -- > Get h2 ..++ -- | Writing many times should append the bytes.+ --+ -- > h1 <- Open fp WriteMode .. | > h2 <- Open fp ReadMode ..+ -- > Put h1 .. |+ -- > Put h1 .. |+ TagWriteWriteRead+ | -- | Try to open a directory+ --+ -- > CreateDirectoryIfMissing True fp+ -- > Open hp IO.WriteMode+ TagOpenDirectory+ | -- | Write to a file+ --+ -- > Put h1+ TagWrite+ | -- | Seek from end of a file+ --+ -- > Seek h IO.SeekFromEnd n (n<0)+ TagSeekFromEnd+ | -- | Create a directory+ --+ -- > CreateDirIfMissing True ..+ TagCreateDirectory+ | -- | DoesFileExistOK returns True+ TagDoesFileExistOK+ | -- | DoesFileExistOK returns False+ TagDoesFileExistKO+ | -- | DoesDirectoryExistOK returns True+ TagDoesDirectoryExistOK+ | -- | DoesDirectoryExistOK returns False+ TagDoesDirectoryExistKO+ | -- | Remove a directory recursively+ --+ -- > RemoveDirRecursively fe+ -- > DoesFileExist fe+ TagRemoveDirectoryRecursive+ | -- | Remove a file+ --+ -- > RemoveFile fe+ -- > DoesFileExist fe+ TagRemoveFile+ | -- | Rename a file+ --+ -- > _ <- Open fe1 WriteMode+ -- > RenameFile fe2 fe2+ TagRenameFile+ | -- | Put truncate and Get+ --+ -- > Put ..+ -- > Truncate ..+ -- > Get ..+ TagPutTruncateGet+ | -- | Close a handle 2 times+ --+ -- > h <- Open ..+ -- > close h+ -- > close h+ TagClosedTwice+ | -- | Open an existing file with ReadMode and then with WriteMode+ --+ -- > open fp ReadMode+ -- > open fp Write+ TagOpenReadThenWrite+ | -- | Open 2 Readers of a file.+ --+ -- > open fp ReadMode+ -- > open fp ReadMode+ TagOpenReadThenRead+ | -- | ListDir on a non empty dirextory.+ --+ -- > CreateDirIfMissing True a/b+ -- > ListDirectory a+ TagCreateDirWithParentsThenListDirNotNull+ | -- | Read from an AppendMode file+ --+ -- > h <- Open fp AppendMode+ -- > Read h ..+ TagReadInvalid+ | -- | Write to a read only file+ --+ -- > h <- Open fp ReadMode+ -- > Put h ..+ TagWriteInvalid+ | -- | Put Seek and Get+ --+ -- > Put ..+ -- > Seek ..+ -- > Get ..+ TagPutSeekGet+ | -- | Put Seek (negative) and Get+ --+ -- > Put ..+ -- > Seek .. (negative)+ -- > Get ..+ TagPutSeekNegGet+ | -- | Open with MustBeNew (O_EXCL flag), but the file already existed.+ --+ -- > h <- Open fp (AppendMode _)+ -- > Close h+ -- > Open fp (AppendMode MustBeNew)+ TagExclusiveFail+ | -- | Open a file in read mode successfully+ --+ -- > h <- Open fp (WriteMode _)+ -- > Close h+ -- > h <- Open fp ReadMode+ TagReadModeMustExist+ | -- | Open a file in read mode, but it fails because the file does not exist.+ --+ -- > h <- Open fp ReadMode+ TagReadModeMustExistFail+ | -- | Open a file in non-read mode with 'MustExist' successfully.+ --+ -- > h <- Open fp (_ MustBeNew)+ -- > Close h+ -- > h <- Open fp (_ MustExist)+ TagFileMustExist+ | -- | Open a file in non-read mode with 'MustExist', but it fails because the+ -- files does not exist.+ --+ -- > h <- Open fp (_ MustExist)+ TagFileMustExistFail+ | -- | Reading returns an empty bytestring when EOF+ --+ -- > h <- open fp ReadMode+ -- > Get h 1 == ""+ TagReadEOF+ | -- | GetAt+ --+ -- > 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+type EventPred = C.Predicate (Event Symbolic) Tag++-- | Convenience combinator for creating classifiers for successful commands+--+-- For convenience we pair handles with the paths they refer to+successful ::+ ( Event Symbolic ->+ Success FsPath (Handle HandleMock) ->+ Either Tag EventPred+ ) ->+ EventPred+successful f = C.predicate $ \ev ->+ case eventMockResp ev of+ Resp (Left _) -> Right $ successful f+ Resp (Right ok) -> f ev ok++-- | Tag commands+--+-- Tagging works on symbolic events, so that we can tag without doing real IO.+tag :: [Event Symbolic] -> [Tag]+tag =+ C.classify+ [ tagCreateDirThenListDir Set.empty+ , tagCreateDirWithParentsThenListDir Set.empty+ , tagAtLeastNOpenFiles 0+ , tagPutTruncatePut Map.empty Map.empty Map.empty+ , tagConcurrentWriterReader Map.empty+ , tagWriteWriteRead Map.empty+ , tagOpenDirectory Set.empty+ , tagWrite+ , tagSeekFromEnd+ , tagCreateDirectory+ , tagDoesFileExistOK+ , tagDoesFileExistKO+ , tagDoesDirectoryExistOK+ , tagDoesDirectoryExistKO+ , tagRemoveDirectoryRecursive Set.empty+ , tagRemoveFile Set.empty+ , tagRenameFile+ , tagPutTruncateGet Map.empty Set.empty+ , tagClosedTwice Set.empty+ , tagOpenReadThenWrite Set.empty+ , tagOpenReadThenRead Set.empty+ , tagCreateDirWithParentsThenListDirNotNull Set.empty+ , tagReadInvalid Set.empty+ , tagWriteInvalid Set.empty+ , tagPutSeekGet Set.empty Set.empty+ , tagPutSeekNegGet Set.empty Set.empty+ , tagExclusiveFail+ , tagReadModeMustExist+ , tagReadModeMustExistFail+ , tagFileMustExist+ , tagFileMustExistFail+ , tagReadEOF+ , tagPread+ , tagPutGetBuf Set.empty+ , tagPutGetBufAt Set.empty+ ]+ where+ tagCreateDirThenListDir :: Set FsPath -> EventPred+ tagCreateDirThenListDir created = successful $ \ev _ ->+ case eventMockCmd ev of+ CreateDir fe ->+ Right $ tagCreateDirThenListDir (Set.insert fp created)+ where+ fp = evalPathExpr fe+ ListDirectory fe+ | fp `Set.member` (Set.map fsPathInit created) ->+ Left TagCreateDirThenListDir+ where+ fp = evalPathExpr fe+ _otherwise ->+ Right $ tagCreateDirThenListDir created++ tagCreateDirWithParentsThenListDir :: Set FsPath -> EventPred+ tagCreateDirWithParentsThenListDir created = successful $ \ev _ ->+ case eventMockCmd ev of+ CreateDirIfMissing True fe+ | length (fsPathToList fp) > 1 ->+ Right $ tagCreateDirWithParentsThenListDir (Set.insert fp created)+ where+ fp = evalPathExpr fe+ ListDirectory fe+ | fp `Set.member` (Set.map fsPathInit created) ->+ Left TagCreateDirWithParentsThenListDir+ where+ fp = evalPathExpr fe+ _otherwise ->+ Right $ tagCreateDirWithParentsThenListDir created++ tagCreateDirWithParentsThenListDirNotNull :: Set FsPath -> EventPred+ tagCreateDirWithParentsThenListDirNotNull created = successful $ \ev suc ->+ case (eventMockCmd ev, suc) of+ (CreateDirIfMissing True fe, _)+ | length (fsPathToList fp) > 1 ->+ Right $ tagCreateDirWithParentsThenListDirNotNull (Set.insert fp created)+ where+ fp = evalPathExpr fe+ (ListDirectory fe, Strings set)+ | fp `Set.member` (Set.map fsPathInit created)+ && not (Set.null set) ->+ Left TagCreateDirWithParentsThenListDirNotNull+ where+ fp = evalPathExpr fe+ _otherwise ->+ Right $ tagCreateDirWithParentsThenListDirNotNull created++ -- TODO: It turns out we never hit the 10 (or higher) open handles case+ -- Not sure if this is a problem or not.+ tagAtLeastNOpenFiles :: Int -> EventPred+ tagAtLeastNOpenFiles maxNumOpen =+ C.Predicate+ { predApply = \ev ->+ let maxNumOpen' = max maxNumOpen (countOpen (eventAfter ev))+ in Right $ tagAtLeastNOpenFiles maxNumOpen'+ , predFinish = case maxNumOpen of+ 0 -> Nothing+ 1 -> Just $ TagAtLeastNOpenFiles 1+ 2 -> Just $ TagAtLeastNOpenFiles 2+ n | n < 10 -> Just $ TagAtLeastNOpenFiles 3+ n -> Just $ TagAtLeastNOpenFiles (n `div` 10 * 10)+ }+ where+ countOpen :: Model r -> Int+ countOpen = Mock.numOpenHandles . mockFS++ tagPutTruncateGet ::+ Map (HandleMock, FsPath) Int ->+ Set (HandleMock, FsPath) ->+ EventPred+ tagPutTruncateGet put truncated = successful $ \ev _ ->+ case eventMockCmd ev of+ Put (Handle h fp) bs+ | BS.length bs /= 0 ->+ let+ f Nothing = Just $ BS.length bs+ f (Just n) = Just $ (BS.length bs) + n+ put' = Map.alter f (h, fp) put+ in+ Right $ tagPutTruncateGet put' truncated+ Truncate (Handle h fp) sz | sz > 0 -> case Map.lookup (h, fp) put of+ Just p+ | fromIntegral sz < p ->+ let truncated' = Set.insert (h, fp) truncated+ in Right $ tagPutTruncateGet put truncated'+ _otherwise -> Right $ tagPutTruncateGet put truncated+ Get (Handle h fp) n+ | n > 0+ && ( not $+ Set.null $+ Set.filter (\(hRead, fp') -> fp' == fp && not (hRead == h)) truncated+ ) ->+ Left TagPutTruncateGet+ GetAt (Handle h fp) n _+ | n > 0+ && ( not $+ Set.null $+ Set.filter (\(hRead, fp') -> fp' == fp && not (hRead == h)) truncated+ ) ->+ Left TagPutTruncateGet+ _otherwise -> Right $ tagPutTruncateGet put truncated++ tagPutTruncatePut ::+ Map HandleMock ByteString ->+ Map HandleMock ByteString ->+ Map HandleMock ByteString ->+ EventPred+ tagPutTruncatePut before truncated after = successful $ \ev _ ->+ case eventMockCmd ev of+ Put (Handle h _) bs | BS.length bs /= 0 ->+ case Map.lookup h truncated of+ Nothing ->+ -- not yet truncated+ let before' = Map.alter (appTo bs) h before+ in Right $ tagPutTruncatePut before' truncated after+ Just deleted ->+ let putAfter = Map.findWithDefault mempty h after <> bs+ after' = Map.insert h putAfter after+ in if deleted /= BS.take (BS.length deleted) putAfter+ then Left $ TagPutTruncatePut+ else Right $ tagPutTruncatePut before truncated after'+ Truncate (Handle h _) sz+ | sz > 0 ->+ let putBefore = Map.findWithDefault mempty h before+ (putBefore', deleted) = BS.splitAt (fromIntegral sz) putBefore+ before' = Map.insert h putBefore' before+ truncated' = Map.insert h deleted truncated+ after' = Map.delete h after+ in Right $ tagPutTruncatePut before' truncated' after'+ _otherwise ->+ Right $ tagPutTruncatePut before truncated after+ where+ appTo :: Monoid a => a -> Maybe a -> Maybe a+ appTo b Nothing = Just b+ appTo b (Just a) = Just (a <> b)++ tagConcurrentWriterReader :: Map HandleMock (Set HandleMock) -> EventPred+ tagConcurrentWriterReader put = successful $ \ev@Event{..} _ ->+ case eventMockCmd ev of+ Put (Handle h fp) bs+ | BS.length bs > 0 ->+ -- Remember the other handles to the same file open at this time+ let readHs :: Set HandleMock+ readHs =+ Set.fromList $+ map handleRaw $+ filter (\(Handle h' fp') -> h /= h' && fp == fp') $+ openHandles eventBefore++ put' :: Map HandleMock (Set HandleMock)+ put' = Map.alter (Just . maybe readHs (Set.union readHs)) h put+ in Right $ tagConcurrentWriterReader put'+ Close (Handle h _) ->+ Right $ tagConcurrentWriterReader (Map.delete h put)+ Get (Handle h _) n+ | h `elem` Set.unions (Map.elems put)+ , n > 0 ->+ Left TagConcurrentWriterReader+ GetAt (Handle h _) n _+ | h `elem` Set.unions (Map.elems put)+ , n > 0 ->+ Left TagConcurrentWriterReader+ _otherwise ->+ Right $ tagConcurrentWriterReader put++ tagOpenReadThenWrite :: Set FsPath -> EventPred+ tagOpenReadThenWrite readOpen = successful $ \ev _ ->+ case eventMockCmd ev of+ Open (PExpPath fp) ReadMode ->+ Right $ tagOpenReadThenWrite $ Set.insert fp readOpen+ Open (PExpPath fp) (WriteMode _)+ | Set.member fp readOpen ->+ Left TagOpenReadThenWrite+ _otherwise -> Right $ tagOpenReadThenWrite readOpen++ tagOpenReadThenRead :: Set FsPath -> EventPred+ tagOpenReadThenRead readOpen = successful $ \ev _ ->+ case eventMockCmd ev of+ Open (PExpPath fp) ReadMode+ | Set.member fp readOpen ->+ Left TagOpenReadThenRead+ Open (PExpPath fp) ReadMode ->+ Right $ tagOpenReadThenRead $ Set.insert fp readOpen+ _otherwise -> Right $ tagOpenReadThenRead readOpen++ tagWriteWriteRead :: Map (HandleMock, FsPath) Int -> EventPred+ tagWriteWriteRead wr = successful $ \ev _ ->+ case eventMockCmd ev of+ Put (Handle h fp) bs+ | BS.length bs > 0 ->+ let f Nothing = Just 0+ f (Just x) = Just $ x + 1+ in Right $ tagWriteWriteRead $ Map.alter f (h, fp) wr+ Get (Handle hRead fp) n+ | n > 1 ->+ if not $+ Map.null $+ Map.filterWithKey (\(hWrite, fp') times -> fp' == fp && times > 1 && not (hWrite == hRead)) wr+ then Left TagWriteWriteRead+ else Right $ tagWriteWriteRead wr+ GetAt (Handle hRead fp) n _+ | n > 1 ->+ if not $+ Map.null $+ Map.filterWithKey (\(hWrite, fp') times -> fp' == fp && times > 1 && not (hWrite == hRead)) wr+ then Left TagWriteWriteRead+ else Right $ tagWriteWriteRead wr+ _otherwise ->+ Right $ tagWriteWriteRead wr++ -- this never succeeds because of an fsLimitation+ tagOpenDirectory :: Set FsPath -> EventPred+ tagOpenDirectory created = C.predicate $ \ev ->+ case (eventMockCmd ev, eventMockResp ev) of+ (CreateDir fe, Resp (Right _)) ->+ Right $ tagOpenDirectory (Set.insert fp created)+ where+ fp = evalPathExpr fe+ (CreateDirIfMissing True fe, Resp (Right _)) ->+ Right $ tagOpenDirectory (Set.insert fp created)+ where+ fp = evalPathExpr fe+ (Open fe _mode, _)+ | Set.member (evalPathExpr fe) created ->+ Left TagOpenDirectory+ _otherwise ->+ Right $ tagOpenDirectory created++ tagWrite :: EventPred+ tagWrite = successful $ \ev _ ->+ case eventMockCmd ev of+ Put _ bs+ | BS.length bs > 0 ->+ Left TagWrite+ _otherwise -> Right tagWrite++ tagSeekFromEnd :: EventPred+ tagSeekFromEnd = successful $ \ev _ ->+ case eventMockCmd ev of+ Seek _ SeekFromEnd n | n < 0 -> Left TagSeekFromEnd+ _otherwise -> Right tagSeekFromEnd++ tagCreateDirectory :: EventPred+ tagCreateDirectory = successful $ \ev _ ->+ case eventMockCmd ev of+ CreateDirIfMissing True (PExpPath fp)+ | length (fsPathToList fp) > 1 ->+ Left TagCreateDirectory+ _otherwise ->+ Right tagCreateDirectory++ tagDoesFileExistOK :: EventPred+ tagDoesFileExistOK = successful $ \ev suc ->+ case (eventMockCmd ev, suc) of+ (DoesFileExist _, Bool True) -> Left TagDoesFileExistOK+ _otherwise -> Right tagDoesFileExistOK++ tagDoesFileExistKO :: EventPred+ tagDoesFileExistKO = successful $ \ev suc ->+ case (eventMockCmd ev, suc) of+ (DoesFileExist _, Bool False) -> Left TagDoesFileExistKO+ _otherwise -> Right tagDoesFileExistKO++ tagDoesDirectoryExistOK :: EventPred+ tagDoesDirectoryExistOK = successful $ \ev suc ->+ case (eventMockCmd ev, suc) of+ (DoesDirectoryExist (PExpPath fp), Bool True)+ | not (fp == mkFsPath ["/"]) ->+ Left TagDoesDirectoryExistOK+ _otherwise -> Right tagDoesDirectoryExistOK++ tagDoesDirectoryExistKO :: EventPred+ tagDoesDirectoryExistKO = successful $ \ev suc ->+ case (eventMockCmd ev, suc) of+ (DoesDirectoryExist _, Bool False) -> Left TagDoesDirectoryExistKO+ _otherwise -> Right tagDoesDirectoryExistKO++ tagRemoveDirectoryRecursive :: Set FsPath -> EventPred+ tagRemoveDirectoryRecursive removed = successful $ \ev _suc ->+ case eventMockCmd ev of+ RemoveDirRecursive fe -> Right $ tagRemoveDirectoryRecursive $ Set.insert fp removed+ where+ fp = evalPathExpr fe+ DoesFileExist fe ->+ if Set.member fp removed+ then Left TagRemoveDirectoryRecursive+ else Right $ tagRemoveDirectoryRecursive removed+ where+ fp = evalPathExpr fe+ _otherwise -> Right $ tagRemoveDirectoryRecursive removed++ tagRemoveFile :: Set FsPath -> EventPred+ tagRemoveFile removed = successful $ \ev _suc ->+ case eventMockCmd ev of+ RemoveFile fe -> Right $ tagRemoveFile $ Set.insert fp removed+ where+ fp = evalPathExpr fe+ DoesFileExist fe ->+ if Set.member fp removed+ then Left TagRemoveFile+ else Right $ tagRemoveFile removed+ where+ fp = evalPathExpr fe+ _otherwise -> Right $ tagRemoveFile removed++ tagRenameFile :: EventPred+ tagRenameFile = successful $ \ev _suc ->+ case eventMockCmd ev of+ RenameFile{} -> Left TagRenameFile+ _otherwise -> Right tagRenameFile++ tagClosedTwice :: Set HandleMock -> EventPred+ tagClosedTwice closed = successful $ \ev _suc ->+ case eventMockCmd ev of+ Close (Handle h _) | Set.member h closed -> Left TagClosedTwice+ Close (Handle h _) -> Right $ tagClosedTwice $ Set.insert h closed+ _otherwise -> Right $ tagClosedTwice closed++ -- this never succeeds because of an fsLimitation+ tagReadInvalid :: Set HandleMock -> EventPred+ tagReadInvalid openAppend = C.predicate $ \ev ->+ case (eventMockCmd ev, eventMockResp ev) of+ (Open _ (AppendMode _), Resp (Right (WHandle _ (Handle h _)))) ->+ Right $ tagReadInvalid $ Set.insert h openAppend+ (Close (Handle h _), Resp (Right _)) ->+ Right $ tagReadInvalid $ Set.delete h openAppend+ (Get (Handle h _) _, Resp (Left _))+ | Set.member h openAppend ->+ Left TagReadInvalid+ (GetAt (Handle h _) _ _, Resp (Left _))+ | Set.member h openAppend ->+ Left TagReadInvalid+ _otherwise -> Right $ tagReadInvalid openAppend++ tagWriteInvalid :: Set HandleMock -> EventPred+ tagWriteInvalid openRead = C.predicate $ \ev ->+ case (eventMockCmd ev, eventMockResp ev) of+ (Open _ ReadMode, Resp (Right (RHandle (Handle h _)))) ->+ Right $ tagWriteInvalid $ Set.insert h openRead+ (Close (Handle h _), Resp (Right _)) ->+ Right $ tagWriteInvalid $ Set.delete h openRead+ (Put (Handle h _) _, _)+ | Set.member h openRead ->+ Left TagWriteInvalid+ _otherwise -> Right $ tagWriteInvalid openRead++ tagPutSeekGet :: Set HandleMock -> Set HandleMock -> EventPred+ tagPutSeekGet put seek = successful $ \ev _suc ->+ case eventMockCmd ev of+ Put (Handle h _) bs+ | BS.length bs > 0 ->+ Right $ tagPutSeekGet (Set.insert h put) seek+ Seek (Handle h _) RelativeSeek n+ | n > 0 && Set.member h put ->+ Right $ tagPutSeekGet put (Set.insert h seek)+ Get (Handle h _) n+ | n > 0 && Set.member h seek ->+ Left TagPutSeekGet+ GetAt (Handle h _) n _+ | n > 0 && Set.member h seek ->+ Left TagPutSeekGet+ _otherwise -> Right $ tagPutSeekGet put seek++ tagPutSeekNegGet :: Set HandleMock -> Set HandleMock -> EventPred+ tagPutSeekNegGet put seek = successful $ \ev _suc ->+ case eventMockCmd ev of+ Put (Handle h _) bs+ | BS.length bs > 0 ->+ Right $ tagPutSeekNegGet (Set.insert h put) seek+ Seek (Handle h _) RelativeSeek n+ | n < 0 && Set.member h put ->+ Right $ tagPutSeekNegGet put (Set.insert h seek)+ Get (Handle h _) n+ | n > 0 && Set.member h seek ->+ Left TagPutSeekNegGet+ GetAt (Handle h _) n _+ | n > 0 && Set.member h seek ->+ Left TagPutSeekNegGet+ _otherwise -> Right $ tagPutSeekNegGet put seek++ tagExclusiveFail :: EventPred+ tagExclusiveFail = C.predicate $ \ev ->+ case (eventMockCmd ev, eventMockResp ev) of+ (Open _ mode, Resp (Left fsError))+ | MustBeNew <- allowExisting mode+ , fsErrorType fsError == FsResourceAlreadyExist ->+ Left TagExclusiveFail+ _otherwise -> Right tagExclusiveFail++ tagReadModeMustExist :: EventPred+ tagReadModeMustExist = C.predicate $ \ev ->+ case (eventMockCmd ev, eventMockResp ev) of+ (Open _ ReadMode, Resp (Right (RHandle _))) -> Left TagReadModeMustExist+ _otherwise -> Right tagReadModeMustExist++ tagReadModeMustExistFail :: EventPred+ tagReadModeMustExistFail = C.predicate $ \ev ->+ case (eventMockCmd ev, eventMockResp ev) of+ (Open _ ReadMode, Resp (Left fsError))+ | fsErrorType fsError == FsResourceDoesNotExist ->+ Left TagReadModeMustExistFail+ _otherwise -> Right tagReadModeMustExistFail++ tagFileMustExist :: EventPred+ tagFileMustExist = C.predicate $ \ev ->+ case (eventMockCmd ev, eventMockResp ev) of+ (Open _ mode, Resp (Right (WHandle _ _)))+ | MustExist <- allowExisting mode+ , mode /= ReadMode ->+ Left TagFileMustExist+ _otherwise -> Right tagFileMustExist++ tagFileMustExistFail :: EventPred+ tagFileMustExistFail = C.predicate $ \ev ->+ case (eventMockCmd ev, eventMockResp ev) of+ (Open _ mode, Resp (Left fsError))+ | MustExist <- allowExisting mode+ , mode /= ReadMode+ , fsErrorType fsError == FsResourceDoesNotExist ->+ Left TagFileMustExistFail+ _otherwise -> Right tagFileMustExistFail++ tagReadEOF :: EventPred+ tagReadEOF = successful $ \ev suc ->+ case (eventMockCmd ev, suc) of+ (Get _ n, ByteString bl)+ | n > 0, BS.null bl -> Left TagReadEOF+ _otherwise -> Right tagReadEOF++ tagPread :: EventPred+ tagPread = successful $ \ev _ ->+ case eventMockCmd ev of+ 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+execCmd model (QSM.Command cmd resp _vars) = lockstep model cmd resp++-- | 'execCmds' is just the repeated form of 'execCmd'+execCmds :: QSM.Commands (At Cmd) (At Resp) -> [Event Symbolic]+execCmds = \(QSM.Commands cs) -> go initModel cs+ where+ go :: Model Symbolic -> [QSM.Command (At Cmd) (At Resp)] -> [Event Symbolic]+ go _ [] = []+ go m (c : cs) = let ev = execCmd m c in ev : go (eventAfter ev) cs++{-------------------------------------------------------------------------------+ Required instances++ The 'ToExpr' constraints come from "Data.TreeDiff".+-------------------------------------------------------------------------------}++constrInfo ::+ SOP.HasDatatypeInfo a =>+ proxy a ->+ SOP.NP SOP.ConstructorInfo (SOP.Code a)+constrInfo = SOP.constructorInfo . SOP.datatypeInfo++constrName :: forall a. SOP.HasDatatypeInfo a => a -> String+constrName a =+ SOP.hcollapse $ SOP.hliftA2 go (constrInfo p) (SOP.unSOP (SOP.from a))+ where+ go :: SOP.ConstructorInfo b -> SOP.NP SOP.I b -> SOP.K String b+ go nfo _ = SOP.K $ SOP.constructorName nfo++ p = Proxy @a++constrNames :: SOP.HasDatatypeInfo a => proxy a -> [String]+constrNames p =+ SOP.hcollapse $ SOP.hmap go (constrInfo p)+ where+ go :: SOP.ConstructorInfo a -> SOP.K String a+ go nfo = SOP.K $ SOP.constructorName nfo++instance QSM.CommandNames (At Cmd) where+ cmdName (At cmd) = constrName cmd+ cmdNames _ = constrNames (Proxy @(Cmd () ()))++deriving instance ToExpr a => ToExpr (FsTree a)+deriving instance ToExpr fp => ToExpr (PathExpr fp)++deriving instance ToExpr HandleMock+deriving instance ToExpr MockFS+deriving instance ToExpr Mock.HandleState+deriving instance ToExpr Mock.OpenHandleState+deriving instance ToExpr Mock.ClosedHandleState+deriving instance ToExpr Mock.FilePtr+deriving instance ToExpr FsPath++instance ToExpr (Handle h) where+ toExpr = defaultExprViaShow++deriving instance ToExpr (Model Concrete)++{-------------------------------------------------------------------------------+ Top-level tests+-------------------------------------------------------------------------------}++-- | Show minimal examples for each of the generated tags+--+-- TODO: The examples listed are not always minimal. I'm not entirely sure why.+showLabelledExamples' ::+ -- | Seed+ Maybe Int ->+ -- | Number of tests to run to find examples+ Int ->+ -- | Tag filter (can be @const True@)+ (Tag -> Bool) ->+ IO ()+showLabelledExamples' mReplay numTests focus = do+ replaySeed <- case mReplay of+ Nothing -> getStdRandom (randomR (1, 999999))+ Just seed -> return seed++ labelledExamplesWith+ ( stdArgs+ { replay = Just (mkQCGen replaySeed, 0)+ , maxSuccess = numTests+ }+ )+ $ forAllShrinkShow+ (QSM.generateCommands sm' Nothing)+ (QSM.shrinkCommands sm')+ pp+ $ \cmds ->+ collects (filter focus . tag . execCmds $ cmds) $+ property True++ putStrLn $ "Used replaySeed " ++ show replaySeed+ where+ sm' = sm unusedHasFS+ pp = \x -> ppShow x ++ "\n" ++ condense x++ collects :: Show a => [a] -> Property -> Property+ collects = repeatedly collect+ where+ repeatedly :: (a -> b -> b) -> ([a] -> b -> b)+ repeatedly = flip . foldl' . flip++showLabelledExamples :: IO ()+showLabelledExamples = showLabelledExamples' Nothing 1000 (const True)++prop_sequential :: Property+prop_sequential =+ withMaxSuccess 1000 $+ QSM.forAllCommands (sm unusedHasFS) Nothing $+ runCmds++runCmds :: QSM.Commands (At Cmd) (At Resp) -> Property+runCmds cmds = QC.monadicIO $ do+ (tstTmpDir, hist, res) <- QC.run $+ withSystemTempDirectory "StateMachine" $ \tstTmpDir -> do+ let mount = MountPoint tstTmpDir+ hfs = ioHasFS mount+ sm' = sm hfs++ (hist, model, res) <- QSM.runCommands' sm' cmds++ -- Close all open handles+ forM_ (RE.keys (knownHandles model)) $ hClose hfs . QSM.concrete++ return (tstTmpDir, hist, res)++ QSM.prettyCommands (sm unusedHasFS) hist $+ QSM.checkCommandNames cmds $+ tabulate "Tags" (map show $ tag (execCmds cmds)) $+ counterexample ("Mount point: " ++ tstTmpDir) $+ res === QSM.Ok++tests :: TestTree+tests =+ testGroup+ "Test.System.FS.StateMachine"+ [ testProperty "q-s-m" $ prop_sequential+ , localOption (QuickCheckTests 1) $+ testProperty "regression_removeFileOnDir" $+ runCmds regression_removeFileOnDir+ ]++-- | Unused HasFS+--+-- 'forAllCommands' wants the entire state machine as argument, but we need the+-- HasFS only when /executing/ the commands in IO. We can therefore generate the+-- commands with a dummy HasFS, and then inside the property construct a+-- temporary directory which we can use for execution.+unusedHasFS :: HasFS m h+unusedHasFS = error "HasFS not used during command generation"++-- | The error numbers returned by Linux vs. MacOS differ when using+-- 'removeFile' on a directory. The model mainly mimicks Linux-style errors,+-- which results in an 'FsResourceInappropriateType' error, whereas on MacOS it+-- results in an 'FsInsufficientPermissions' error. The implementation of+-- 'F.sameError' was made more lenient for MacOS in fs-sim#41 to allow this+-- model-SUT discrepancy to occur without making the tests fail. We might revist+-- this /temporary/ fix in the future, see fs-sim#45.+regression_removeFileOnDir :: QSM.Commands (At Cmd) (At Resp)+regression_removeFileOnDir =+ QSM.Commands+ { unCommands =+ [ QSM.Command+ ( At+ { unAt =+ CreateDirIfMissing+ True+ (PExpPath (mkFsPath ["x"]))+ }+ )+ ( At+ { unAt =+ Resp+ { getResp =+ Right (Path (QSM.Reference (QSM.Symbolic (QSM.Var 0))) ())+ }+ }+ )+ [QSM.Var 0]+ , QSM.Command+ ( At+ { unAt =+ RemoveFile+ (PExpPath (mkFsPath ["x"]))+ }+ )+ ( At+ { unAt =+ Resp+ { getResp =+ Left+ ( FsError+ { fsErrorType = FsResourceInappropriateType+ , fsErrorPath = FsErrorPath Nothing (mkFsPath ["x"])+ , fsErrorString = "expected file"+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = False+ }+ )+ }+ }+ )+ []+ ]+ }++{-------------------------------------------------------------------------------+ Debugging+-------------------------------------------------------------------------------}++-- | Debugging: show @n@ levels of shrink steps (with some required tags)+--+-- This can be useful when debugging the shrinker+_showTaggedShrinks ::+ -- | Required tags+ ([Tag] -> Bool) ->+ -- | Number of shrink steps+ Int ->+ QSM.Commands (At Cmd) (At Resp) ->+ IO ()+_showTaggedShrinks hasRequiredTags numLevels = go 0+ where+ go :: Int -> QSM.Commands (At Cmd) (At Resp) -> IO ()+ go n _ | n == numLevels = return ()+ go n cmds = do+ if hasRequiredTags tags+ then do+ putStrLn $ replicate n '\t' ++ condense (cmds, tags)+ forM_ shrinks $ go (n + 1)+ else+ return ()+ where+ tags = tag $ execCmds cmds+ shrinks = QSM.shrinkCommands (sm unusedHasFS) cmds++{-------------------------------------------------------------------------------+ Pretty-printing+-------------------------------------------------------------------------------}++instance Condense fp => Condense (PathExpr fp) where+ condense (PExpPath fp) = condense fp+ condense (PExpRef fp) = condense fp+ condense (PExpParentOf fp) = condense fp ++ "/.."++instance (Condense fp, Condense h) => Condense (Cmd fp h) where+ condense = L.intercalate " " . go+ where+ go (Open fp mode) = ["open", condense fp, condense mode]+ 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 (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]+ go (CreateDirIfMissing p fp) = ["createDirIfMissing", condense p, condense fp]+ go (ListDirectory fp) = ["listDirectory", condense fp]+ go (DoesDirectoryExist fp) = ["doesDirectoryExist", condense fp]+ go (DoesFileExist fp) = ["doesFileExist", condense fp]+ go (RemoveDirRecursive fp) = ["removeDirectoryRecursive", condense fp]+ go (RemoveFile fp) = ["removeFile", condense fp]+ go (RenameFile fp1 fp2) = ["renameFile", condense fp1, condense fp2]++instance Condense1 r => Condense (Cmd :@ r) where+ condense (At cmd) = condense cmd++instance Condense Tag where+ condense = show++instance Condense AbsOffset where+ condense = show++instance Condense ByteCount where+ condense = show++{-------------------------------------------------------------------------------+ (Orphan) condense instance for QSM types+-------------------------------------------------------------------------------}++instance Condense QSM.Var where+ condense (QSM.Var i) = "x" ++ condense i++instance Condense1 Symbolic where+ liftCondense _ (QSM.Symbolic a) = condense a++instance Condense (QSM.Opaque a) where+ condense _ = "<>"++instance (Condense1 r, Condense a) => Condense (QSM.Reference a r) where+ condense (QSM.Reference ra) = condense1 ra++instance Condense (cmd Symbolic) => Condense (QSM.Command cmd resp) where+ condense = \(QSM.Command cmd _resp vars) ->+ L.intercalate " " $ go cmd vars+ where+ go :: cmd Symbolic -> [QSM.Var] -> [String]+ go cmd [] = [condense cmd]+ go cmd xs = [condense xs, "<-", condense cmd]++instance Condense (cmd Symbolic) => Condense (QSM.Commands cmd resp) where+ condense (QSM.Commands cmds) = unlines $ "do" : map (indent . condense) cmds+ where+ indent :: String -> String+ indent = (" " ++)
test/Test/Util.hs view
@@ -1,11 +1,11 @@-module Test.Util (- showPowersOf10+module Test.Util+ ( showPowersOf10 , showPowersOf ) where -import Data.List (find)-import Data.Maybe (fromJust)-import Text.Printf+import Data.List (find)+import Data.Maybe (fromJust)+import Text.Printf showPowersOf10 :: Int -> String showPowersOf10 = showPowersOf 10@@ -13,9 +13,9 @@ showPowersOf :: Int -> Int -> String showPowersOf factor n | factor <= 1 = error "showPowersOf: factor must be larger than 1"- | n < 0 = "n < 0"- | n == 0 = "n == 0"- | otherwise = printf "%d <= n < %d" lb ub- where- ub = fromJust (find (n <) (iterate (* factor) factor))- lb = ub `div` factor+ | n < 0 = "n < 0"+ | n == 0 = "n == 0"+ | otherwise = printf "%d <= n < %d" lb ub+ where+ ub = fromJust (find (n <) (iterate (* factor) factor))+ lb = ub `div` factor
test/Test/Util/RefEnv.hs view
@@ -1,15 +1,15 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TupleSections #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TupleSections #-} -- | Environments of QSM references.-module Test.Util.RefEnv (- RefEnv- -- opaque+module Test.Util.RefEnv+ ( RefEnv+ -- opaque , elems , empty , filter@@ -24,63 +24,70 @@ , (!) ) where -import Prelude hiding (filter, lookup, null)-import qualified Prelude--import Data.Bifunctor-import Data.Functor.Classes-import Data.List (intercalate)-import GHC.Generics (Generic)-import GHC.Stack-import Test.StateMachine (Reference)-import Test.StateMachine.TreeDiff+import Data.Bifunctor+import Data.Functor.Classes+import Data.List (intercalate)+import GHC.Generics (Generic)+import GHC.Stack+import Test.StateMachine (Reference)+import Test.StateMachine.TreeDiff import qualified Test.StateMachine.Types.Rank2 as Rank2+import Prelude hiding (filter, lookup, null)+import qualified Prelude -data RefEnv k a r = RefEnv { toList :: [(Reference k r, a)] }+data RefEnv k a r = RefEnv {toList :: [(Reference k r, a)]} deriving (Generic, ToExpr, Show) -- | Extend mapping -- -- We don't insist that the keys are disjoint, but if the same key appears -- twice, the value must agree.-extendMapping :: forall k v. (Eq k, Eq v, Show k, Show v, HasCallStack)- => [(k, v)] -- Mapping known to have duplicate keys- -> [(k, v)] -- With potential duplicates- -> [(k, v)]-extendMapping acc [] = acc+extendMapping ::+ forall k v.+ (Eq k, Eq v, Show k, Show v, HasCallStack) =>+ [(k, v)] -> -- Mapping known to have duplicate keys+ [(k, v)] -> -- With potential duplicates+ [(k, v)]+extendMapping acc [] = acc extendMapping acc ((k, v) : kvs) =- case Prelude.lookup k acc of- Just v' | v /= v' -> error $ renderError v'- _otherwise -> extendMapping ((k, v) : acc) kvs- where- renderError :: v -> String- renderError v' = intercalate " " [- "Key"- , show k- , "with two different values"- , show v- , "and"- , show v'- ]+ case Prelude.lookup k acc of+ Just v' | v /= v' -> error $ renderError v'+ _otherwise -> extendMapping ((k, v) : acc) kvs+ where+ renderError :: v -> String+ renderError v' =+ intercalate+ " "+ [ "Key"+ , show k+ , "with two different values"+ , show v+ , "and"+ , show v'+ ] -fromList :: (Eq k, Show k, Eq a, Show a, Eq1 r, Show1 r, HasCallStack)- => [(Reference k r, a)] -> RefEnv k a r+fromList ::+ (Eq k, Show k, Eq a, Show a, Eq1 r, Show1 r, HasCallStack) =>+ [(Reference k r, a)] -> RefEnv k a r fromList = RefEnv . extendMapping [] instance Rank2.Functor (RefEnv k a) where- fmap f (RefEnv ras) = RefEnv $+ fmap f (RefEnv ras) =+ RefEnv $ fmap (first (Rank2.fmap f)) ras instance Rank2.Foldable (RefEnv k a) where foldMap f (RefEnv ras) =- foldMap (Rank2.foldMap f . fst) ras+ foldMap (Rank2.foldMap f . fst) ras instance Rank2.Traversable (RefEnv k a) where- traverse f (RefEnv ras) = RefEnv <$>- traverse (\(r, a) -> (,a) <$> Rank2.traverse f r) ras+ traverse f (RefEnv ras) =+ RefEnv+ <$> traverse (\(r, a) -> (,a) <$> Rank2.traverse f r) ras -union :: (Eq k, Show k, Eq a, Show a, Eq1 r, Show1 r, HasCallStack)- => RefEnv k a r -> RefEnv k a r -> RefEnv k a r+union ::+ (Eq k, Show k, Eq a, Show a, Eq1 r, Show1 r, HasCallStack) =>+ RefEnv k a r -> RefEnv k a r -> RefEnv k a r union (RefEnv ras1) (RefEnv ras2) = RefEnv (extendMapping ras1 ras2) -- | Empty environment@@ -95,8 +102,8 @@ (!) :: (Eq k, Eq1 r) => RefEnv k a r -> Reference k r -> a env ! r = case lookup r env of- Just a -> a- Nothing -> error "(RefEnv.!): key not found"+ Just a -> a+ Nothing -> error "(RefEnv.!): key not found" keys :: RefEnv k a r -> [Reference k r] keys (RefEnv ras) = map fst ras
test/Test/Util/WithEntryCounter.hs view
@@ -1,65 +1,83 @@ {-# LANGUAGE RecordWildCards #-} -module Test.Util.WithEntryCounter (- EntryCounters (..)+module Test.Util.WithEntryCounter+ ( EntryCounters (..) , zeroEntryCounters , incrTVar , withEntryCounters ) where -import Control.Concurrent.Class.MonadSTM.Strict-import Data.Word-import System.FS.API+import Control.Concurrent.Class.MonadSTM.Strict+import Data.Word+import System.FS.API -data EntryCounters f = EntryCounters {- dumpStateC :: f Word64- -- file operations- , hOpenC :: f Word64- , hCloseC :: f Word64- , hIsOpenC :: f Word64- , hSeekC :: f Word64- , hGetSomeC :: f Word64- , hGetSomeAtC :: f Word64- , hPutSomeC :: f Word64- , hTruncateC :: f Word64- , hGetSizeC :: f Word64- -- directory operations- , createDirectoryC :: f Word64+data EntryCounters f = EntryCounters+ { dumpStateC :: f Word64+ , -- file operations+ hOpenC :: f Word64+ , hCloseC :: f Word64+ , hIsOpenC :: f Word64+ , hSeekC :: f Word64+ , hGetSomeC :: f Word64+ , hGetSomeAtC :: f Word64+ , hPutSomeC :: f Word64+ , hTruncateC :: f Word64+ , hGetSizeC :: f Word64+ , -- directory operations+ createDirectoryC :: f Word64 , createDirectoryIfMissingC :: f Word64- , listDirectoryC :: f Word64- , doesDirectoryExistC :: f Word64- , doesFileExistC :: f Word64+ , listDirectoryC :: f Word64+ , doesDirectoryExistC :: f Word64+ , doesFileExistC :: f Word64 , removeDirectoryRecursiveC :: f Word64- , removeFileC :: f Word64- , renameFileC :: f Word64- -- file I\/O with user-supplied buffers- , hGetBufSomeC :: f Word64- , hGetBufSomeAtC :: f Word64- , hPutBufSomeC :: f Word64- , hPutBufSomeAtC :: f Word64+ , removeFileC :: f Word64+ , renameFileC :: f Word64+ , -- file I\/O with user-supplied buffers+ hGetBufSomeC :: f Word64+ , hGetBufSomeAtC :: f Word64+ , hPutBufSomeC :: f Word64+ , hPutBufSomeAtC :: f Word64 } zeroEntryCounters :: MonadSTM m => m (EntryCounters (StrictTVar m))-zeroEntryCounters = EntryCounters <$>- newTVarIO 0 <*> newTVarIO 0 <*> newTVarIO 0 <*> newTVarIO 0 <*>- newTVarIO 0 <*> newTVarIO 0 <*> newTVarIO 0 <*> newTVarIO 0 <*>- newTVarIO 0 <*> newTVarIO 0 <*> newTVarIO 0 <*> newTVarIO 0 <*>- newTVarIO 0 <*> newTVarIO 0 <*> newTVarIO 0 <*> newTVarIO 0 <*>- newTVarIO 0 <*> newTVarIO 0 <*> newTVarIO 0 <*> newTVarIO 0 <*>- newTVarIO 0 <*> newTVarIO 0+zeroEntryCounters =+ EntryCounters+ <$> newTVarIO 0+ <*> newTVarIO 0+ <*> newTVarIO 0+ <*> newTVarIO 0+ <*> newTVarIO 0+ <*> newTVarIO 0+ <*> newTVarIO 0+ <*> newTVarIO 0+ <*> newTVarIO 0+ <*> newTVarIO 0+ <*> newTVarIO 0+ <*> newTVarIO 0+ <*> newTVarIO 0+ <*> newTVarIO 0+ <*> newTVarIO 0+ <*> newTVarIO 0+ <*> newTVarIO 0+ <*> newTVarIO 0+ <*> newTVarIO 0+ <*> newTVarIO 0+ <*> newTVarIO 0+ <*> newTVarIO 0 incrTVar :: MonadSTM m => StrictTVar m Word64 -> m ()-incrTVar var = atomically $ modifyTVar var (+1)+incrTVar var = atomically $ modifyTVar var (+ 1) withEntryCounters ::- MonadSTM m- => EntryCounters (StrictTVar m)- -> HasFS m h- -> HasFS m h-withEntryCounters EntryCounters{..} HasFS{..} = HasFS {- dumpState = incrTVar dumpStateC >> dumpState- -- file operatoins- , hOpen = \a b -> incrTVar hOpenC >> hOpen a b+ MonadSTM m =>+ EntryCounters (StrictTVar m) ->+ HasFS m h ->+ HasFS m h+withEntryCounters EntryCounters{..} HasFS{..} =+ HasFS+ { dumpState = incrTVar dumpStateC >> dumpState+ , -- file operatoins+ hOpen = \a b -> incrTVar hOpenC >> hOpen a b , hClose = \a -> incrTVar hCloseC >> hClose a , hIsOpen = \a -> incrTVar hIsOpenC >> hIsOpen a , hSeek = \a b c -> incrTVar hSeekC >> hSeek a b c@@ -68,8 +86,8 @@ , hPutSome = \a b -> incrTVar hPutSomeC >> hPutSome a b , hTruncate = \a b -> incrTVar hTruncateC >> hTruncate a b , hGetSize = \a -> incrTVar hGetSizeC >> hGetSize a- -- directory operations- , createDirectory = \a -> incrTVar createDirectoryC >> createDirectory a+ , -- directory operations+ createDirectory = \a -> incrTVar createDirectoryC >> createDirectory a , createDirectoryIfMissing = \a b -> incrTVar createDirectoryIfMissingC >> createDirectoryIfMissing a b , listDirectory = \a -> incrTVar listDirectoryC >> listDirectory a , doesDirectoryExist = \a -> incrTVar doesDirectoryExistC >> doesDirectoryExist a@@ -79,8 +97,8 @@ , renameFile = \a b -> incrTVar renameFileC >> renameFile a b , mkFsErrorPath = mkFsErrorPath , unsafeToFilePath = unsafeToFilePath- -- file I\/O with user-supplied buffers- , hGetBufSome = \a b c d -> incrTVar hGetBufSomeC >> hGetBufSome a b c d+ , -- file I\/O with user-supplied buffers+ hGetBufSome = \a b c d -> incrTVar hGetBufSomeC >> hGetBufSome a b c d , hGetBufSomeAt = \a b c d e -> incrTVar hGetBufSomeAtC >> hGetBufSomeAt a b c d e , hPutBufSome = \a b c d -> incrTVar hPutBufSomeC >> hPutBufSome a b c d , hPutBufSomeAt = \a b c d e -> incrTVar hPutBufSomeAtC >> hPutBufSomeAt a b c d e