diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/fs-sim.cabal b/fs-sim.cabal --- a/fs-sim.cabal +++ b/fs-sim.cabal @@ -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 diff --git a/src/System/FS/Sim/Error.hs b/src/System/FS/Sim/Error.hs --- a/src/System/FS/Sim/Error.hs +++ b/src/System/FS/Sim/Error.hs @@ -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" - 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" + 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 diff --git a/src/System/FS/Sim/FsTree.hs b/src/System/FS/Sim/FsTree.hs --- a/src/System/FS/Sim/FsTree.hs +++ b/src/System/FS/Sim/FsTree.hs @@ -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) diff --git a/src/System/FS/Sim/MockFS.hs b/src/System/FS/Sim/MockFS.hs --- a/src/System/FS/Sim/MockFS.hs +++ b/src/System/FS/Sim/MockFS.hs @@ -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 } diff --git a/src/System/FS/Sim/Prim.hs b/src/System/FS/Sim/Prim.hs --- a/src/System/FS/Sim/Prim.hs +++ b/src/System/FS/Sim/Prim.hs @@ -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 } diff --git a/src/System/FS/Sim/STM.hs b/src/System/FS/Sim/STM.hs --- a/src/System/FS/Sim/STM.hs +++ b/src/System/FS/Sim/STM.hs @@ -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) diff --git a/src/System/FS/Sim/Stream.hs b/src/System/FS/Sim/Stream.hs --- a/src/System/FS/Sim/Stream.hs +++ b/src/System/FS/Sim/Stream.hs @@ -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 -> ("" ++) - Finite -> (if n > 10 then ('(':) else id) - . shows xs - . (" ++ ..." ++) - . (if n > 10 then (')':) else id) + Infinite -> ("" ++) + 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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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 + ] diff --git a/test/Test/System/FS/Sim/Error.hs b/test/Test/System/FS/Sim/Error.hs --- a/test/Test/System/FS/Sim/Error.hs +++ b/test/Test/System/FS/Sim/Error.hs @@ -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 diff --git a/test/Test/System/FS/Sim/FsTree.hs b/test/Test/System/FS/Sim/FsTree.hs --- a/test/Test/System/FS/Sim/FsTree.hs +++ b/test/Test/System/FS/Sim/FsTree.hs @@ -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 diff --git a/test/Test/System/FS/Sim/Stream.hs b/test/Test/System/FS/Sim/Stream.hs --- a/test/Test/System/FS/Sim/Stream.hs +++ b/test/Test/System/FS/Sim/Stream.hs @@ -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] diff --git a/test/Test/System/FS/StateMachine.hs b/test/Test/System/FS/StateMachine.hs --- a/test/Test/System/FS/StateMachine.hs +++ b/test/Test/System/FS/StateMachine.hs @@ -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 = (" " ++) diff --git a/test/Test/Util.hs b/test/Test/Util.hs --- a/test/Test/Util.hs +++ b/test/Test/Util.hs @@ -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 diff --git a/test/Test/Util/RefEnv.hs b/test/Test/Util/RefEnv.hs --- a/test/Test/Util/RefEnv.hs +++ b/test/Test/Util/RefEnv.hs @@ -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 diff --git a/test/Test/Util/WithEntryCounter.hs b/test/Test/Util/WithEntryCounter.hs --- a/test/Test/Util/WithEntryCounter.hs +++ b/test/Test/Util/WithEntryCounter.hs @@ -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