fs-sim (empty) → 0.3.0.0
raw patch · 18 files changed
+5460/−0 lines, 18 filesdep +QuickCheckdep +basedep +base16-bytestring
Dependencies added: QuickCheck, base, base16-bytestring, bifunctors, bytestring, containers, fs-api, fs-sim, generics-sop, io-classes, mtl, pretty-show, primitive, quickcheck-state-machine, random, safe-wild-cards, strict-stm, tasty, tasty-hunit, tasty-quickcheck, temporary, text
Files
- CHANGELOG.md +95/−0
- LICENSE +177/−0
- NOTICE +14/−0
- README.md +14/−0
- fs-sim.cabal +94/−0
- src/System/FS/Sim/Error.hs +840/−0
- src/System/FS/Sim/FsTree.hs +364/−0
- src/System/FS/Sim/MockFS.hs +1120/−0
- src/System/FS/Sim/Prim.hs +78/−0
- src/System/FS/Sim/STM.hs +98/−0
- src/System/FS/Sim/Stream.hs +168/−0
- test/Main.hs +13/−0
- test/Test/System/FS/Sim/Error.hs +244/−0
- test/Test/System/FS/Sim/FsTree.hs +125/−0
- test/Test/System/FS/StateMachine.hs +1791/−0
- test/Test/Util.hs +21/−0
- test/Test/Util/RefEnv.hs +117/−0
- test/Test/Util/WithEntryCounter.hs +87/−0
+ CHANGELOG.md view
@@ -0,0 +1,95 @@+# Revision history for fs-sim++## 0.3.0.0 -- 2024-08-26++### Breaking++* Orphan `Show` instance for `Foreign.C.Error.Errno` removed by `fs-api`.+* Rename some functions related to partial reads/writes and corruption in `System.FS.Sim.Error`:+ * Replace `hGetSomePartial` by `partialiseByteCount`/`partialiseWord64`.+ * Replace `hPutSomePartial` by `partialiseByteString`+ * Replace `corrupt` by `corruptByteString`+* Remove `System.FS.Sim.Pure` module.+* Adapt `simHasFS` to the new `HasFS` primitives. This leads to two breaking+ changes:+ * Add a `PrimMonad m` constraint to `runSimFS`, `simHasFS'` and `simHasFS`.+ * Change the `StrictTVar` argument to `simHasFS` to a `StrictTMVar`.+* Adapt `mkSimErrorHasFS` to the new `HasFS` primitives. This leads to two+ breaking changes:+ * Add a `PrimMonad m` constraint to `runSimErrorFS`, `mkSimErrorHasFS'` and `mkSimErrorHasFS`.+ * Change the `StrictTVar` argument to `mkSimErrorHasFS` to a `StrictTMVar`.+* Rename `mkSimErrorHasFS` to `simErrorHasFS`.+* Rename `mkSimErrorHasFS'` to `simErrorHasFS'`.++### Non-breaking++* New constructors for the `Errors` type: `hGetBufSomeE`, `hGetBufSomeAtE`,+ `hGetBufSomeE`, and `hPutBufSomeAtE`.+* Expose the new `System.FS.Sim.Prim` module.++### Patch++* `allNull` was not actually checking whether all streams in the argument+ `Errors` are empty.+* The `Show Errors` instance was not printing every stream.+* The shrinker for `Errors` was not shrinking every stream.+* Adapt to moving of `Util` modules in `fs-api`.+* Make it build with `ghc-9.10`.+* New `primitive ^>=0.9` dependency+* New `safe-wild-cards^>=1.0`dependency+* Tight dependency bounds.++## 0.2.1.1 -- 2023-10-30++### Patch++* Make it build with `ghc-9.8`.++## 0.2.1.0 -- 2023-08-01++### Non-breaking++* Build with `fs-api ^>=0.2`.++### Patch++* Bump upper version bounds for `io-classes` and `strict-stm` to `1.3`++## 0.2.0.0 -- 2023-06-02++### Breaking++* Move `Stream`-related functions to new `System.FS.Sim.Stream` module.+* Remove `Semigroup` and `Monoid` instances for `Stream` and `Errors` types.+* Overhaul `Stream` type and related functions. The `Stream` type now behaves+ similarly to `Test.QuickCheck`'s `InfiniteList`, which improves showing,+ generation and shrinking.++### Non-breaking++* Add `simHasFS'` and `mkSimErrorHasFS'`, which are alternatives to `simHasFS`+ and `mkSimErrorHasFS` that create `TVar`s internally.+* Add new `emptyErrors` function.+* Adapt the `Errors` type to use the overhauled `Stream` type. As a bonus:+ * Arbitrary `Errors` now contain infinite error `Stream`s by default, instead+ of finite ones.+ * Shrinking of `Errors` that contain infinite error `Stream`s now terminates.++### Patch++* Enable building with `ghc-9.4`.+* Remove `asserts` package flag.++## 0.1.0.2 -- 2023-05-25++* Enable building with ghc-9.6++## 0.1.0.1 -- 2023-04-24++### Non-breaking++Update the code to compile with `io-sim-1.0.0.1`.++## 0.1.0.0 -- 2023-03-27++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,177 @@++ Apache License+ Version 2.0, January 2004+ http://www.apache.org/licenses/++ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++ 1. Definitions.++ "License" shall mean the terms and conditions for use, reproduction,+ and distribution as defined by Sections 1 through 9 of this document.++ "Licensor" shall mean the copyright owner or entity authorized by+ the copyright owner that is granting the License.++ "Legal Entity" shall mean the union of the acting entity and all+ other entities that control, are controlled by, or are under common+ control with that entity. For the purposes of this definition,+ "control" means (i) the power, direct or indirect, to cause the+ direction or management of such entity, whether by contract or+ otherwise, or (ii) ownership of fifty percent (50%) or more of the+ outstanding shares, or (iii) beneficial ownership of such entity.++ "You" (or "Your") shall mean an individual or Legal Entity+ exercising permissions granted by this License.++ "Source" form shall mean the preferred form for making modifications,+ including but not limited to software source code, documentation+ source, and configuration files.++ "Object" form shall mean any form resulting from mechanical+ transformation or translation of a Source form, including but+ not limited to compiled object code, generated documentation,+ and conversions to other media types.++ "Work" shall mean the work of authorship, whether in Source or+ Object form, made available under the License, as indicated by a+ copyright notice that is included in or attached to the work+ (an example is provided in the Appendix below).++ "Derivative Works" shall mean any work, whether in Source or Object+ form, that is based on (or derived from) the Work and for which the+ editorial revisions, annotations, elaborations, or other modifications+ represent, as a whole, an original work of authorship. For the purposes+ of this License, Derivative Works shall not include works that remain+ separable from, or merely link (or bind by name) to the interfaces of,+ the Work and Derivative Works thereof.++ "Contribution" shall mean any work of authorship, including+ the original version of the Work and any modifications or additions+ to that Work or Derivative Works thereof, that is intentionally+ submitted to Licensor for inclusion in the Work by the copyright owner+ or by an individual or Legal Entity authorized to submit on behalf of+ the copyright owner. For the purposes of this definition, "submitted"+ means any form of electronic, verbal, or written communication sent+ to the Licensor or its representatives, including but not limited to+ communication on electronic mailing lists, source code control systems,+ and issue tracking systems that are managed by, or on behalf of, the+ Licensor for the purpose of discussing and improving the Work, but+ excluding communication that is conspicuously marked or otherwise+ designated in writing by the copyright owner as "Not a Contribution."++ "Contributor" shall mean Licensor and any individual or Legal Entity+ on behalf of whom a Contribution has been received by Licensor and+ subsequently incorporated within the Work.++ 2. Grant of Copyright License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ copyright license to reproduce, prepare Derivative Works of,+ publicly display, publicly perform, sublicense, and distribute the+ Work and such Derivative Works in Source or Object form.++ 3. Grant of Patent License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ (except as stated in this section) patent license to make, have made,+ use, offer to sell, sell, import, and otherwise transfer the Work,+ where such license applies only to those patent claims licensable+ by such Contributor that are necessarily infringed by their+ Contribution(s) alone or by combination of their Contribution(s)+ with the Work to which such Contribution(s) was submitted. If You+ institute patent litigation against any entity (including a+ cross-claim or counterclaim in a lawsuit) alleging that the Work+ or a Contribution incorporated within the Work constitutes direct+ or contributory patent infringement, then any patent licenses+ granted to You under this License for that Work shall terminate+ as of the date such litigation is filed.++ 4. Redistribution. You may reproduce and distribute copies of the+ Work or Derivative Works thereof in any medium, with or without+ modifications, and in Source or Object form, provided that You+ meet the following conditions:++ (a) You must give any other recipients of the Work or+ Derivative Works a copy of this License; and++ (b) You must cause any modified files to carry prominent notices+ stating that You changed the files; and++ (c) You must retain, in the Source form of any Derivative Works+ that You distribute, all copyright, patent, trademark, and+ attribution notices from the Source form of the Work,+ excluding those notices that do not pertain to any part of+ the Derivative Works; and++ (d) If the Work includes a "NOTICE" text file as part of its+ distribution, then any Derivative Works that You distribute must+ include a readable copy of the attribution notices contained+ within such NOTICE file, excluding those notices that do not+ pertain to any part of the Derivative Works, in at least one+ of the following places: within a NOTICE text file distributed+ as part of the Derivative Works; within the Source form or+ documentation, if provided along with the Derivative Works; or,+ within a display generated by the Derivative Works, if and+ wherever such third-party notices normally appear. The contents+ of the NOTICE file are for informational purposes only and+ do not modify the License. You may add Your own attribution+ notices within Derivative Works that You distribute, alongside+ or as an addendum to the NOTICE text from the Work, provided+ that such additional attribution notices cannot be construed+ as modifying the License.++ You may add Your own copyright statement to Your modifications and+ may provide additional or different license terms and conditions+ for use, reproduction, or distribution of Your modifications, or+ for any such Derivative Works as a whole, provided Your use,+ reproduction, and distribution of the Work otherwise complies with+ the conditions stated in this License.++ 5. Submission of Contributions. Unless You explicitly state otherwise,+ any Contribution intentionally submitted for inclusion in the Work+ by You to the Licensor shall be under the terms and conditions of+ this License, without any additional terms or conditions.+ Notwithstanding the above, nothing herein shall supersede or modify+ the terms of any separate license agreement you may have executed+ with Licensor regarding such Contributions.++ 6. Trademarks. This License does not grant permission to use the trade+ names, trademarks, service marks, or product names of the Licensor,+ except as required for reasonable and customary use in describing the+ origin of the Work and reproducing the content of the NOTICE file.++ 7. Disclaimer of Warranty. Unless required by applicable law or+ agreed to in writing, Licensor provides the Work (and each+ Contributor provides its Contributions) on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+ implied, including, without limitation, any warranties or conditions+ of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+ PARTICULAR PURPOSE. You are solely responsible for determining the+ appropriateness of using or redistributing the Work and assume any+ risks associated with Your exercise of permissions under this License.++ 8. Limitation of Liability. In no event and under no legal theory,+ whether in tort (including negligence), contract, or otherwise,+ unless required by applicable law (such as deliberate and grossly+ negligent acts) or agreed to in writing, shall any Contributor be+ liable to You for damages, including any direct, indirect, special,+ incidental, or consequential damages of any character arising as a+ result of this License or out of the use or inability to use the+ Work (including but not limited to damages for loss of goodwill,+ work stoppage, computer failure or malfunction, or any and all+ other commercial damages or losses), even if such Contributor+ has been advised of the possibility of such damages.++ 9. Accepting Warranty or Additional Liability. While redistributing+ the Work or Derivative Works thereof, You may choose to offer,+ and charge a fee for, acceptance of support, warranty, indemnity,+ or other liability obligations and/or rights consistent with this+ License. However, in accepting such obligations, You may act only+ on Your own behalf and on Your sole responsibility, not on behalf+ of any other Contributor, and only if You agree to indemnify,+ defend, and hold each Contributor harmless for any liability+ incurred by, or claims asserted against, such Contributor by reason+ of your accepting any such warranty or additional liability.++ END OF TERMS AND CONDITIONS
+ NOTICE view
@@ -0,0 +1,14 @@+Copyright 2019-2024 Input Output Global Inc (IOG)++ Licensed under the Apache License, Version 2.0 (the "License");+ you may not use this file except in compliance with the License.+ You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++ Unless required by applicable law or agreed to in writing, software+ distributed under the License is distributed on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+ See the License for the specific language governing permissions and+ limitations under the License.+
+ README.md view
@@ -0,0 +1,14 @@+# fs-sim++The `fs-sim` package provides a filesystem simulator that facilitates+simulation of errors and file corruption. This simulator is specially useful for+testing purposes, and works well in conjunction with+[`io-sim`](ps://github.com/input-output-hk/io-sim).++Code that is written using the abstract filesystem interface (`HasFS`) that is+provided by the parent package `fs-api` can be run against any of the simulator+implementations provided by `fs-sim`. `fs-sim` currently provides two+simulators:+* `System.FS.Sim.STM` provides an implementation that uses STM.+* `System.FS.Sim.Error` provides an implementation that uses STM, but can also+ simulate errors and file corruption.
+ fs-sim.cabal view
@@ -0,0 +1,94 @@+cabal-version: 3.0+name: fs-sim+version: 0.3.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)+category: Testing+build-type: Simple+extra-doc-files:+ CHANGELOG.md+ README.md++tested-with: GHC ==8.10 || ==9.2 || ==9.4 || ==9.6 || ==9.8 || ==9.10++source-repository head+ type: git+ location: https://github.com/input-output-hk/fs-sim+ subdir: fs-sim++library+ hs-source-dirs: src+ exposed-modules:+ System.FS.Sim.Error+ System.FS.Sim.FsTree+ System.FS.Sim.MockFS+ System.FS.Sim.Prim+ System.FS.Sim.STM+ System.FS.Sim.Stream++ default-language: Haskell2010+ build-depends:+ , base >=4.14 && <4.21+ , base16-bytestring ^>=0.1 || ^>=1.0+ , bytestring ^>=0.10 || ^>=0.11 || ^>=0.12+ , containers ^>=0.5 || ^>=0.6 || ^>=0.7+ , fs-api ^>=0.3+ , io-classes ^>=1.0 || ^>=1.1 || ^>=1.2 || ^>=1.3 || ^>=1.4 || ^>=1.5+ , mtl ^>=2.2 || ^>=2.3+ , primitive ^>=0.9+ , QuickCheck ^>=2.13 || ^>=2.14 || ^>=2.15+ , safe-wild-cards ^>=1.0+ , strict-stm ^>=1.0 || ^>=1.1 || ^>=1.2 || ^>=1.3 || ^>=1.4 || ^>=1.5+ , 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++test-suite fs-sim-test+ 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+ Test.System.FS.StateMachine+ Test.Util+ Test.Util.RefEnv+ Test.Util.WithEntryCounter++ default-language: Haskell2010+ build-depends:+ , base+ , bifunctors+ , bytestring+ , containers+ , fs-api+ , fs-sim+ , generics-sop+ , pretty-show+ , primitive+ , QuickCheck+ , quickcheck-state-machine >=0.10+ , random+ , strict-stm+ , 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+ -fno-ignore-asserts
+ src/System/FS/Sim/Error.hs view
@@ -0,0 +1,840 @@+{-# 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.Coerce (coerce)+import Data.Foldable (for_)+import Data.List (intercalate)+import qualified Data.List as List+import Data.Maybe (catMaybes)+import Data.Primitive.ByteArray+import Data.String (IsString (..))+import Data.Word (Word64)+import Foreign.C.Types+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 = coerce partialiseByteCount++-- | 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+ streamGen l = Stream.genInfinite . Stream.genMaybe' l . QC.elements+ streamGen' l = Stream.genInfinite . Stream.genMaybe' l . QC.frequency++ commonGetErrors = streamGen' 20+ [ (1, return $ Left FsReachedEOF)+ , (3, Right <$> arbitrary) ]++ commonPutErrors = streamGen' 5+ [ (1, Left . (FsDeviceFull, ) <$> QC.frequency+ [ (2, return Nothing)+ , (1, Just . PartialWrite <$> arbitrary)+ , (if genSubstituteWithJunk then 1 else 0,+ Just . SubstituteWithJunk <$> arbitrary)+ ])+ , (if genPartialWrites then 3 else 0, Right <$> arbitrary) ]++instance Arbitrary Errors where+ arbitrary = genErrors True True++ shrink err@($(fields 'Errors)) = concatMap (filter (not . allNull))+ [ (\s' -> err { dumpStateE = s' }) <$> Stream.shrinkStream dumpStateE+ , (\s' -> err { hOpenE = s' }) <$> Stream.shrinkStream hOpenE+ , (\s' -> err { hCloseE = s' }) <$> Stream.shrinkStream hCloseE+ , (\s' -> err { hSeekE = s' }) <$> Stream.shrinkStream hSeekE+ , (\s' -> err { hGetSomeE = s' }) <$> Stream.shrinkStream hGetSomeE+ , (\s' -> err { hGetSomeAtE = s' }) <$> Stream.shrinkStream hGetSomeAtE+ , (\s' -> err { hPutSomeE = s' }) <$> Stream.shrinkStream hPutSomeE+ , (\s' -> err { hTruncateE = s' }) <$> Stream.shrinkStream hTruncateE+ , (\s' -> err { hGetSizeE = s' }) <$> Stream.shrinkStream hGetSizeE+ , (\s' -> err { createDirectoryE = s' }) <$> Stream.shrinkStream createDirectoryE+ , (\s' -> err { createDirectoryIfMissingE = s' }) <$> Stream.shrinkStream createDirectoryIfMissingE+ , (\s' -> err { listDirectoryE = s' }) <$> Stream.shrinkStream listDirectoryE+ , (\s' -> err { doesDirectoryExistE = s' }) <$> Stream.shrinkStream doesDirectoryExistE+ , (\s' -> err { doesFileExistE = s' }) <$> Stream.shrinkStream doesFileExistE+ , (\s' -> err { removeDirectoryRecursiveE = s' }) <$> Stream.shrinkStream removeDirectoryRecursiveE+ , (\s' -> err { removeFileE = s' }) <$> Stream.shrinkStream removeFileE+ , (\s' -> err { renameFileE = s' }) <$> Stream.shrinkStream renameFileE+ -- File I\/O with user-supplied buffers+ , (\s' -> err { hGetBufSomeE = s' }) <$> Stream.shrinkStream hGetBufSomeE+ , (\s' -> err { hGetBufSomeAtE = s' }) <$> Stream.shrinkStream hGetBufSomeAtE+ , (\s' -> err { hPutBufSomeE = s' }) <$> Stream.shrinkStream hPutBufSomeE+ , (\s' -> err { hPutBufSomeAtE = s' }) <$> Stream.shrinkStream hPutBufSomeAtE+ ]++{-------------------------------------------------------------------------------+ Simulate Errors monad+-------------------------------------------------------------------------------}++-- | Alternative to 'simErrorHasFS' that creates 'TVar's internally.+simErrorHasFS' :: (MonadSTM m, MonadThrow m, PrimMonad m)+ => MockFS+ -> Errors+ -> m (HasFS m HandleMock)+simErrorHasFS' mockFS errs =+ simErrorHasFS <$> newTMVarIO mockFS <*> newTVarIO errs++-- | Introduce possibility of errors+simErrorHasFS :: forall m. (MonadSTM m, MonadThrow m, PrimMonad m)+ => StrictTMVar m MockFS+ -> StrictTVar m Errors+ -> HasFS m HandleMock+simErrorHasFS fsVar errorsVar =+ -- TODO: Lenses would be nice for the setters+ case Sim.simHasFS fsVar of+ hfs@HasFS{..} -> HasFS{+ dumpState =+ withErr errorsVar (mkFsPath ["<dumpState>"]) dumpState "dumpState"+ dumpStateE (\e es -> es { dumpStateE = e })+ , hOpen = \p m ->+ withErr errorsVar p (hOpen p m) "hOpen"+ hOpenE (\e es -> es { hOpenE = e })+ , hClose = \h ->+ withErr' errorsVar h (hClose h) "hClose"+ hCloseE (\e es -> es { hCloseE = e })+ , hIsOpen = hIsOpen+ , hSeek = \h m n ->+ withErr' errorsVar h (hSeek h m n) "hSeek"+ hSeekE (\e es -> es { hSeekE = e })+ , hGetSome = hGetSome' errorsVar hGetSome+ , hGetSomeAt = hGetSomeAt' errorsVar hGetSomeAt+ , hPutSome = hPutSome' errorsVar hPutSome+ , hTruncate = \h w ->+ withErr' errorsVar h (hTruncate h w) "hTruncate"+ hTruncateE (\e es -> es { hTruncateE = e })+ , hGetSize = \h ->+ withErr' errorsVar h (hGetSize h) "hGetSize"+ hGetSizeE (\e es -> es { hGetSizeE = e })++ , createDirectory = \p ->+ withErr errorsVar p (createDirectory p) "createDirectory"+ createDirectoryE (\e es -> es { createDirectoryE = e })+ , createDirectoryIfMissing = \b p ->+ withErr errorsVar p (createDirectoryIfMissing b p) "createDirectoryIfMissing"+ createDirectoryIfMissingE (\e es -> es { createDirectoryIfMissingE = e })+ , listDirectory = \p ->+ withErr errorsVar p (listDirectory p) "listDirectory"+ listDirectoryE (\e es -> es { listDirectoryE = e })+ , doesDirectoryExist = \p ->+ withErr errorsVar p (doesDirectoryExist p) "doesDirectoryExist"+ doesDirectoryExistE (\e es -> es { doesDirectoryExistE = e })+ , doesFileExist = \p ->+ withErr errorsVar p (doesFileExist p) "doesFileExist"+ doesFileExistE (\e es -> es { doesFileExistE = e })+ , removeDirectoryRecursive = \p ->+ withErr errorsVar p (removeDirectoryRecursive p) "removeFile"+ removeDirectoryRecursiveE (\e es -> es { removeDirectoryRecursiveE = e })+ , removeFile = \p ->+ withErr errorsVar p (removeFile p) "removeFile"+ removeFileE (\e es -> es { removeFileE = e })+ , renameFile = \p1 p2 ->+ withErr errorsVar p1 (renameFile p1 p2) "renameFile"+ renameFileE (\e es -> es { renameFileE = e })+ , mkFsErrorPath = fsToFsErrorPathUnmounted+ , unsafeToFilePath = error "simErrorHasFS:unsafeToFilePath"+ -- File I\/O with user-supplied buffers+ , hGetBufSome = hGetBufSomeWithErr errorsVar hfs+ , hGetBufSomeAt = hGetBufSomeAtWithErr errorsVar hfs+ , hPutBufSome = hPutBufSomeWithErr errorsVar hfs+ , hPutBufSomeAt = hPutBufSomeAtWithErr errorsVar hfs+ }++-- | Runs a computation provided an 'Errors' and an initial+-- 'MockFS', producing a result and the final state of the filesystem.+runSimErrorFS :: (MonadSTM m, MonadThrow m, PrimMonad m)+ => MockFS+ -> Errors+ -> (StrictTVar m Errors -> HasFS m HandleMock -> m a)+ -> m (a, MockFS)+runSimErrorFS mockFS errors action = do+ fsVar <- newTMVarIO mockFS+ errorsVar <- newTVarIO errors+ a <- action errorsVar $ simErrorHasFS fsVar errorsVar+ fs' <- atomically $ takeTMVar fsVar+ return (a, fs')++-- | Execute the next action using the given 'Errors'. After the action is+-- finished, the previous 'Errors' are restored.+withErrors :: MonadSTM m => StrictTVar m Errors -> Errors -> m a -> m a+withErrors errorsVar tempErrors action = do+ originalErrors <- atomically $ do+ originalErrors <- readTVar errorsVar+ writeTVar errorsVar tempErrors+ return originalErrors+ res <- action+ atomically $ writeTVar errorsVar originalErrors+ return res++{-------------------------------------------------------------------------------+ 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
+ src/System/FS/Sim/FsTree.hs view
@@ -0,0 +1,364 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Internal part of the mock file system+--+-- Intended for qualified import+--+-- > import System.FS.Sim.FsTree (FsTree)+-- > import qualified System.FS.Sim.FsTree as FS+module System.FS.Sim.FsTree (+ -- * FsTree type and indexing functions+ FsTree (..)+ , FsTreeError (..)+ , example+ -- * Construction+ , empty+ -- * Indexing+ , getDir+ , getFile+ , index+ -- * File system operations+ , createDirIfMissing+ , createDirWithParents+ , openFile+ , removeDirRecursive+ , 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 qualified Data.Map.Strict as M+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++{-------------------------------------------------------------------------------+ FsTree type and general indexing functions+-------------------------------------------------------------------------------}++-- | Simple in-memory representation of a file system+data FsTree a = File !a | Folder !(Folder a)+ deriving (Show, Eq, Generic, Functor)++type Folder a = Map Text (FsTree a)++-- | 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)+ ])+ ])+ ]++-- | File access error+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+ --+ -- 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+ --+ -- 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)++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++{-------------------------------------------------------------------------------+ 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 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++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 p onErr onNotExists 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 p onErr onNotExists onExists = alterF p onErr' f+ 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 :| [])++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 p onErr onNotExists onExists = alterF p onErr' f+ 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++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 p onErr onNotExists onExists =+ alterFileMaybe p (fmap Just . onErr) (fmap Just onNotExists)+ (fmap Just . onExists)+++{-------------------------------------------------------------------------------+ Construction+-------------------------------------------------------------------------------}++empty :: FsTree a+empty = Folder M.empty++{-------------------------------------------------------------------------------+ Auxiliary: paths+-------------------------------------------------------------------------------}++pathLast :: HasCallStack => FsPath -> Text+pathLast fp = case fsPathSplit fp of+ 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'++{-------------------------------------------------------------------------------+ Indexing+-------------------------------------------------------------------------------}++-- | Index the FsTree by the given FsPath.+index :: FsPath -> FsTree a -> Either FsTreeError (FsTree a)+index fp = getConst . alterF fp (Const . Left) (Const . Right)++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 :| [])++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 :| [])++{-------------------------------------------------------------------------------+ Specific file system functions+-------------------------------------------------------------------------------}++-- | Open a file: create it if necessary or throw an error if it existed+-- already wile we were supposed to create it from scratch (when passed+-- 'MustBeNew').+openFile :: Monoid a+ => FsPath -> AllowExisting -> FsTree a -> Either FsTreeError (FsTree a)+openFile fp ex = alterFile fp Left (Right mempty) $ \a -> case ex of+ AllowExisting -> Right a+ MustBeNew -> Left (FsExists 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 :| []))++-- | Create a directory if it does not already exist+createDirIfMissing :: FsPath -> FsTree a -> Either FsTreeError (FsTree a)+createDirIfMissing fp = alterDir fp Left (Right M.empty) Right++-- | 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+ . repeatedlyM createDirIfMissing (pathInits fp)+ 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++-- | 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 :| []))++-- | 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 :| []))++-- | 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'++{-------------------------------------------------------------------------------+ Path-listing+-------------------------------------------------------------------------------}++-- Find all the file paths reachable from fp. Similar to Unix's @find@.+--+-- The initial path will be prepended to the each item in the resulting list of+-- paths.+--+-- For instance, given the following file system, say @fs@:+--+-- > usr+-- > |-- local+-- > |-- bin+--+-- find ["usr"] fs will return:+--+-- > [usr, usr/local, usr/local/bin]+--+-- find ["usr", "local"] fs will return:+--+-- > [usr/local, usr/local/bin]+--+-- See the unit tests in @Test.Ouroboros.Storage.FsTree@ for additional+-- examples.+--+-- If the given file system path does not exist, a (Left FsMissing{}) is+-- returned.+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++ 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'++{-------------------------------------------------------------------------------+ Pretty-printing+-------------------------------------------------------------------------------}++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++-- | 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)
+ src/System/FS/Sim/MockFS.hs view
@@ -0,0 +1,1120 @@+{-# 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+ , 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, void, 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+ }+ when (openMode == ReadMode) $ void $+ checkFsTree $ FS.getFile fp (mockFiles fs)+ files' <- checkFsTree $ FS.openFile fp ex (mockFiles fs)+ return $ newHandle (fs { mockFiles = files' })+ (OpenHandle fp (filePtr openMode))+ where+ ex :: AllowExisting+ ex = allowExisting openMode++ filePtr :: OpenMode -> FilePtr+ filePtr ReadMode = RW True False 0+ filePtr (WriteMode _) = RW False True 0+ filePtr (ReadWriteMode _) = RW True True 0+ filePtr (AppendMode _) = Append++-- | Mock implementation of 'hClose'+hClose :: CanSimFS m => Handle' -> m ()+hClose h = withHandleRead h $ \_fs -> \case+ HandleOpen hs ->+ return ((), HandleClosed (ClosedHandle (openFilePath hs)))+ HandleClosed hs ->+ return ((), HandleClosed hs)++-- | Mock implementation of 'hIsOpen'+hIsOpen :: CanSimFS m => Handle' -> m Bool+hIsOpen h = gets (`handleIsOpen` handleRaw h)++-- | Mock implementation of 'hSeek'+--+-- NOTE: This is more restricted than the IO version, because seek has some+-- odd properties:+--+-- * We do not allow seeking at all on files in append mode+-- * We do not allow seeking past the end of the file+-- (this means that when using 'IO.SeekFromEnd', the only valid offset is 0)+-- * We do /not/ return the new file offset+hSeek :: CanSimFS m+ => Handle' -> SeekMode -> Int64 -> m ()+hSeek h seekMode o = withOpenHandleRead h $ \fs hs -> do+ openPtr' <- seekFilePtr fs h seekMode o+ return ((), hs { openPtr = openPtr' })++-- | Get bytes from handle+--+-- NOTE: Unlike real I/O, we disallow 'hGetSome' on a handle in append mode.+hGetSome :: CanSimFS m => Handle' -> Word64 -> m ByteString+hGetSome h n =+ withOpenHandleRead h $ \fs hs@OpenHandle{..} -> do+ file <- checkFsTree $ FS.getFile openFilePath (mockFiles fs)+ case openPtr of+ RW r w o -> do+ unless r $ throwError (errNoReadAccess openFilePath "write")+ let bs = BS.take (fromIntegral n) . BS.drop (fromIntegral o) $ file+ return (bs, hs { openPtr = RW True w (o + fromIntegral (BS.length bs)) })+ Append -> throwError (errNoReadAccess openFilePath "append")+ where+ errNoReadAccess fp mode = FsError {+ fsErrorType = FsInvalidArgument+ , fsErrorPath = fsToFsErrorPathUnmounted fp+ , fsErrorString = "cannot hGetSome in " <> mode <> " mode"+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = True+ }++-- | Thread safe version of 'hGetSome', which doesn't modify or read the file+-- offset.+hGetSomeAt :: CanSimFS m+ => Handle'+ -> Word64+ -> AbsOffset+ -> m ByteString+hGetSomeAt h n o =+ withOpenHandleRead h $ \fs hs@OpenHandle{..} -> do+ file <- checkFsTree $ FS.getFile openFilePath (mockFiles fs)+ let o' = unAbsOffset o+ let fsize = fromIntegral (BS.length file) :: Word64+ case openPtr of+ RW r _ _ -> do+ unless r $ throwError (errNoReadAccess openFilePath "write")+ let bs = BS.take (fromIntegral n) . BS.drop (fromIntegral o') $ file+ -- This is the same fsLimitation we get when we seek past the end of+ -- EOF, in AbsoluteSeek mode.+ when (o' > fsize) $ throwError (errPastEnd openFilePath)+ return (bs, hs)+ Append -> throwError (errNoReadAccess openFilePath "append")+ where+ errNoReadAccess fp mode = FsError {+ fsErrorType = FsInvalidArgument+ , fsErrorPath = fsToFsErrorPathUnmounted fp+ , fsErrorString = "cannot hGetSomeAt in " <> mode <> " mode"+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = True+ }++ errPastEnd fp = FsError {+ fsErrorType = FsInvalidArgument+ , fsErrorPath = fsToFsErrorPathUnmounted fp+ , fsErrorString = "hGetSomeAt offset past EOF not supported"+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = True+ }++hPutSome :: CanSimFS m => Handle' -> ByteString -> m Word64+hPutSome h toWrite =+ withOpenHandleModify h $ \fs hs@OpenHandle{..} -> do+ case openPtr of+ RW r w o -> do+ unless w $ throwError (errReadOnly openFilePath)+ file <- checkFsTree $ FS.getFile openFilePath (mockFiles fs)+ let file' = replace o toWrite file+ files' <- checkFsTree $ FS.replace openFilePath file' (mockFiles fs)+ return (written, (files', hs { openPtr = RW r w (o + written) }))+ Append -> do+ file <- checkFsTree $ FS.getFile openFilePath (mockFiles fs)+ let file' = file <> toWrite+ files' <- checkFsTree $ FS.replace openFilePath file' (mockFiles fs)+ return (written, (files', hs))+ where+ written = toEnum $ BS.length toWrite++ errReadOnly fp = FsError {+ fsErrorType = FsInvalidArgument+ , fsErrorPath = fsToFsErrorPathUnmounted fp+ , fsErrorString = "handle is read-only"+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = False+ }++-- | Truncate a file+--+-- NOTE: Differences from Posix:+--+-- * Although this corresponds to Posix @ftruncate@, this can only be used+-- to make files /smaller/, not larger.+-- * We only support this in append mode. The reason is that Posix+-- @ftruncate@ does not modify the file offset, and adds padding with zeroes+-- on subsequent writes. This is however not behaviour we want to emulate.+-- In append mode however the Posix file offset is not used (and we don't+-- even record it at all), appends always happen at the end of the file.+hTruncate :: CanSimFS m => Handle' -> Word64 -> m ()+hTruncate h sz =+ withOpenHandleModify h $ \fs hs@OpenHandle{..} -> do+ file <- checkFsTree $ FS.getFile openFilePath (mockFiles fs)+ ptr' <- case (sz > fromIntegral (BS.length file), openPtr) of+ (True, _) ->+ throwError FsError {+ fsErrorType = FsInvalidArgument+ , fsErrorPath = fsToFsErrorPathUnmounted openFilePath+ , fsErrorString = "truncate cannot make the file larger"+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = True+ }+ (False, RW{}) ->+ throwError FsError {+ fsErrorType = FsInvalidArgument+ , fsErrorPath = fsToFsErrorPathUnmounted openFilePath+ , fsErrorString = "truncate only supported in append mode"+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = True+ }+ (False, Append) ->+ return Append+ let file' = BS.take (fromIntegral sz) file+ files' <- checkFsTree $ FS.replace openFilePath file' (mockFiles fs)+ -- TODO: Don't replace the file pointer (not changed)+ return ((), (files', hs { openPtr = ptr' }))++-- | Get file size+--+-- NOTE: In the mock implementation this is thread safe, because there can be+-- only one writer, so concurrent threads cannot change the size of the file.+hGetSize :: CanSimFS m => Handle' -> m Word64+hGetSize h =+ withOpenHandleRead h $ \fs hs@OpenHandle{..} -> do+ file <- checkFsTree $ FS.getFile openFilePath (mockFiles fs)+ return (fromIntegral (BS.length file), hs)++{-------------------------------------------------------------------------------+ Operations on directories+-------------------------------------------------------------------------------}++createDirectory :: CanSimFS m => FsPath -> m ()+createDirectory dir = modifyMockFS $ \fs -> do+ checkDoesNotExist fs dir+ files' <- checkFsTree $ FS.createDirIfMissing dir (mockFiles fs)+ return ((), fs { mockFiles = files' })++createDirectoryIfMissing :: CanSimFS m+ => Bool -> FsPath -> m ()+createDirectoryIfMissing createParents dir = do+ -- Although @createDirectoryIfMissing /a/b/c@ will fail ("inappropriate+ -- type") if @b@ is a file (not a directory), for some strange reason it+ -- throws "already exists" if @c@ is is a file+ fileExists <- doesFileExist dir+ if fileExists then+ throwError FsError {+ fsErrorType = FsResourceAlreadyExist+ , fsErrorPath = fsToFsErrorPathUnmounted dir+ , fsErrorString = "a file with that name already exists"+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = False+ }+ else modifyMockFS $ \fs -> do+ files' <- checkFsTree $ go createParents (mockFiles fs)+ return ((), fs { mockFiles = files' })+ where+ go :: Bool -> Files -> Either FsTreeError Files+ go True = FS.createDirWithParents dir+ go False = FS.createDirIfMissing dir++listDirectory :: CanSimFS m+ => FsPath -> m (Set String)+listDirectory fp = readMockFS $+ fmap (S.fromList . map Text.unpack . M.keys)+ . checkFsTree+ . FS.getDir fp++-- | Check if directory exists+--+-- It seems real I/O maps what would be "inapproriate device" errors to False.+doesDirectoryExist :: CanSimFS m => FsPath -> m Bool+doesDirectoryExist fp = readMockFS $ \fs ->+ return $ case FS.getDir fp fs of+ Left _ -> False+ Right _ -> True++-- | Check if file exists+--+-- See comments for 'doesDirectoryExist'.+doesFileExist :: CanSimFS m => FsPath -> m Bool+doesFileExist fp = readMockFS $ \fs ->+ return $ case FS.getFile fp fs of+ Left _ -> False+ Right _ -> True++-- | Remove a directory and its contents+--+-- Same limitations as 'removeFile'.+removeDirectoryRecursive :: CanSimFS m => FsPath -> m ()+removeDirectoryRecursive fp = do+ modifyMockFS $ \fs -> do+ reachablePaths <- fmap S.fromList $ checkFsTree $ FS.find fp (mockFiles fs)+ let openReachablePaths = reachablePaths `S.intersection` openFilePaths fs+ case fsPathToList fp of+ []+ -> throwError FsError {+ fsErrorType = FsIllegalOperation+ , fsErrorPath = fsToFsErrorPathUnmounted fp+ , fsErrorString = "cannot remove the root directory"+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = True+ }+ _ | openReachablePaths /= mempty+ -> throwError FsError {+ fsErrorType = FsIllegalOperation+ , fsErrorPath = fsToFsErrorPathUnmounted fp+ , fsErrorString = "cannot remove an open file. "+ ++ "The following files are reachable from "+ ++ show fp+ ++ "and are still open: "+ ++ show openReachablePaths+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = True+ }+ _ -> do+ files' <- checkFsTree $ FS.removeDirRecursive fp (mockFiles fs)+ return ((), fs { mockFiles = files' })++-- | Remove a file+--+-- The behaviour of @unlink@ is to remove the file after all open file handles+-- that refer to it are closed. The open file handles referring to the file+-- can still be used to write\/read to\/from, while at the same time, the file+-- is invisible for all other operations.+--+-- We do not implement this behaviour and consider this a limitation of the+-- mock file system, and throw an error when removing a file that still has+-- open file handles to it.+--+-- In the state machine tests, removing the root directory may cause the IO+-- implementation to throw an 'FsInsufficientPermissions' error, depending on+-- the permissions of the temporary directory used to run the tests in. In+-- theory it should throw a 'FsResourceInappropriateType' error. To avoid this+-- mismatch during testing, we also consider removing the root folder a+-- limitation of the mock file system.+removeFile :: CanSimFS m => FsPath -> m ()+removeFile fp =+ modifyMockFS $ \fs -> case fsPathToList fp of+ []+ -> throwError FsError {+ fsErrorType = FsIllegalOperation+ , fsErrorPath = fsToFsErrorPathUnmounted fp+ , fsErrorString = "cannot remove the root directory"+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = True+ }+ _ | fp `S.member` openFilePaths fs+ -> throwError FsError {+ fsErrorType = FsIllegalOperation+ , fsErrorPath = fsToFsErrorPathUnmounted fp+ , fsErrorString = "cannot remove an open file"+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = True+ }+ _ -> do+ files' <- checkFsTree $ FS.removeFile fp (mockFiles fs)+ return ((), fs { mockFiles = files' })++renameFile :: CanSimFS m => FsPath -> FsPath -> m ()+renameFile fpOld fpNew =+ modifyMockFS $ \fs -> if+ | not (sameDir fpOld fpNew) ->+ throwError $ errDifferentDir fpOld+ | fpOld `S.member` openFilePaths fs ->+ throwError $ errRenameOpenFile fpOld+ | fpNew `S.member` openFilePaths fs ->+ throwError $ errRenameOpenFile fpNew+ | Right _ <- FS.getDir fpNew (mockFiles fs) ->+ throwError $ errRenameDir fpNew+ | otherwise -> do+ files' <- checkFsTree $ FS.renameFile fpOld fpNew (mockFiles fs)+ return ((), fs { mockFiles = files' })+ where+ sameDir fp1 fp2 =+ (fst <$> fsPathSplit fp1) == (fst <$> fsPathSplit fp2)++ errRenameOpenFile fp = FsError {+ fsErrorType = FsIllegalOperation+ , fsErrorPath = fsToFsErrorPathUnmounted fp+ , fsErrorString = "cannot rename opened file"+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = True+ }++ errRenameDir fp = FsError {+ fsErrorType = FsResourceInappropriateType+ , fsErrorPath = fsToFsErrorPathUnmounted fp+ , fsErrorString = "is a directory"+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = True+ }++ errDifferentDir fp = FsError {+ fsErrorType = FsIllegalOperation+ , fsErrorPath = fsToFsErrorPathUnmounted fp+ , fsErrorString = "files must be in the same directory"+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = True+ }++{-------------------------------------------------------------------------------+ Pretty-printing+-------------------------------------------------------------------------------}++-- | Renders the 'MockFS' in a human-readable fashion.+pretty :: MockFS -> String+-- TODO: Right now does this not show the state of the handles.+pretty = FS.pretty renderFile . mockFiles+ where+ renderFile :: ByteString -> String+ renderFile = show . hexDump . B16.encode++ hexDump :: ByteString -> ByteString+ hexDump = fst+ . BS.foldl' (\(acc, n) w8 ->+ if n == 2 then (acc <> " " <> BS.singleton w8, 1)+ else (acc <> BS.singleton w8, n + 1)+ ) (mempty, 0 :: Int)++{-------------------------------------------------------------------------------+ Auxiliary+-------------------------------------------------------------------------------}++data Sign a = Negative a | Positive a+ deriving (Functor)++sign :: (Num a, Ord a) => a -> Sign a+sign a | a < 0 = Negative (negate a)+ | otherwise = Positive a++sign64 :: Int64 -> Sign Word64+sign64 = fmap fromIntegral . sign++{-------------------------------------------------------------------------------+ ByteString+-------------------------------------------------------------------------------}++-- Given+--+-- > A B C+-- > |-----------|-------.-----------|+-- > n .+-- > .+-- > D .+-- > |-------|+--+-- return A <> D <> C+replace :: Word64 -> ByteString -> ByteString -> ByteString+replace n d abc = a <> d <> c+ where+ (a, c) = snip (fromIntegral n) (BS.length d) abc++-- Given+--+-- > A B C+-- > |-----------|-------|-----------|+-- > n+-- > <------->+-- > m+--+-- return (A, C)+snip :: Int -> Int -> ByteString -> (ByteString, ByteString)+snip n m bs = (a, c)+ where+ (a, bc) = BS.splitAt n bs+ c = BS.drop m bc++{-------------------------------------------------------------------------------+ HasBufFS+-------------------------------------------------------------------------------}++packMutableByteArray :: PrimMonad m => P.MutableByteArray (PrimState m) -> BufferOffset -> [Word8] -> m ()+packMutableByteArray mba i bytes = forM_ (zip [unBufferOffset i..] bytes) $ uncurry (P.writeByteArray mba)++intoBuffer :: PrimMonad m => P.MutableByteArray (PrimState m) -> BufferOffset -> ByteString -> m Bool+intoBuffer buf bufOff bs = do+ bufSize <- P.getSizeofMutableByteArray buf+ let remaining = bufSize - unBufferOffset bufOff+ if BS.length bs > remaining+ then pure False+ else packMutableByteArray buf bufOff (BS.unpack bs)+ >> pure True++unpackMutableByteArray :: PrimMonad m => P.MutableByteArray (PrimState m) -> BufferOffset -> ByteCount -> m [Word8]+unpackMutableByteArray mba i c = forM [unBufferOffset i .. unBufferOffset i + fromIntegral c - 1] $ P.readByteArray mba++fromBuffer :: PrimMonad m => P.MutableByteArray (PrimState m) -> BufferOffset -> ByteCount -> m (Maybe ByteString)+fromBuffer buf bufOff c = do+ bufSize <- P.getSizeofMutableByteArray buf+ let remaining = bufSize - unBufferOffset bufOff+ if fromIntegral c > remaining+ then pure Nothing+ else Just . BS.pack <$> unpackMutableByteArray buf bufOff c++hGetBufSome :: (CanSimFS m, PrimMonad m) => Handle' -> MutableByteArray (PrimState m) -> BufferOffset -> ByteCount -> m ByteCount+hGetBufSome h buf bufOff n =+ withOpenHandleRead h $ \fs hs@OpenHandle{..} -> do+ file <- checkFsTree $ FS.getFile openFilePath (mockFiles fs)+ case openPtr of+ RW r w o -> do+ unless r $ throwError (errNoReadAccess openFilePath "write")+ let bs = BS.take (fromIntegral n) . BS.drop (fromIntegral o) $ file+ success <- intoBuffer buf bufOff bs+ -- we can't read more bytes than the buffer size+ unless success $ throwError (errWritePastBufEnd openFilePath)+ let readBytes = fromIntegral (BS.length bs)+ return (readBytes, hs { openPtr = RW True w (o + fromIntegral readBytes)})+ Append -> throwError (errNoReadAccess openFilePath "append")+ where+ errNoReadAccess fp mode = FsError {+ fsErrorType = FsInvalidArgument+ , fsErrorPath = fsToFsErrorPathUnmounted fp+ , fsErrorString = "cannot hGetBufSomeAt in " <> mode <> " mode"+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = True+ }++ errWritePastBufEnd fp = FsError {+ fsErrorType = FsInvalidArgument+ , fsErrorPath = fsToFsErrorPathUnmounted fp+ , fsErrorString = "hPutBufSomeAt: writing into buffer past end not supported"+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = True+ }++hGetBufSomeAt :: (CanSimFS m, PrimMonad m) => Handle' -> MutableByteArray (PrimState m) -> BufferOffset -> ByteCount -> AbsOffset -> m ByteCount+hGetBufSomeAt h buf bufOff n o =+ withOpenHandleRead h $ \fs hs@OpenHandle{..} -> do+ file <- checkFsTree $ FS.getFile openFilePath (mockFiles fs)+ let o' = unAbsOffset o+ let fsize = fromIntegral (BS.length file) :: Word64+ case openPtr of+ RW r _ _ -> do+ unless r $ throwError (errNoReadAccess openFilePath "write")+ -- This is the same fsLimitation we get when we seek past the end of+ -- EOF, in AbsoluteSeek mode.+ when (o' > fsize) $ throwError (errPastEnd openFilePath)+ let bs = BS.take (fromIntegral n) . BS.drop (fromIntegral o') $ file+ success <- intoBuffer buf bufOff bs+ -- we can't read more bytes than the buffer size+ unless success $ throwError (errWritePastBufEnd openFilePath)+ return (fromIntegral (BS.length bs), hs)+ Append -> throwError (errNoReadAccess openFilePath "append")+ where+ errNoReadAccess fp mode = FsError {+ fsErrorType = FsInvalidArgument+ , fsErrorPath = fsToFsErrorPathUnmounted fp+ , fsErrorString = "cannot hGetBufSomeAt in " <> mode <> " mode"+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = True+ }++ errPastEnd fp = FsError {+ fsErrorType = FsInvalidArgument+ , fsErrorPath = fsToFsErrorPathUnmounted fp+ , fsErrorString = "hGetBufSomeAt offset past EOF not supported"+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = True+ }++ errWritePastBufEnd fp = FsError {+ fsErrorType = FsInvalidArgument+ , fsErrorPath = fsToFsErrorPathUnmounted fp+ , fsErrorString = "hPutBufSomeAt: writing into buffer past end not supported"+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = True+ }++hPutBufSome :: (CanSimFS m, PrimMonad m) => Handle' -> MutableByteArray (PrimState m) -> BufferOffset -> ByteCount -> m ByteCount+hPutBufSome h buf bufOff n = do+ withOpenHandleModify h $ \fs hs@OpenHandle{..} -> do+ file <- checkFsTree $ FS.getFile openFilePath (mockFiles fs)+ case openPtr of+ RW r w o -> do+ unless w $ throwError (errNoWriteAccess openFilePath "read")+ -- We can't write more bytes than the buffer size+ toWrite <- fromBuffer buf bufOff n >>= \case+ Nothing -> throwError (errReadPastBufEnd openFilePath)+ Just bs -> pure bs+ let file' = replace o toWrite file+ files' <- checkFsTree $ FS.replace openFilePath file' (mockFiles fs)+ let written = fromIntegral $ BS.length toWrite+ return (written, (files', hs { openPtr = RW r w (o + fromIntegral written)}))+ Append -> do+ -- We can't write more bytes than the buffer size+ toWrite <- fromBuffer buf bufOff n >>= \case+ Nothing -> throwError (errReadPastBufEnd openFilePath)+ Just bs -> pure bs+ let file' = file <> toWrite+ files' <- checkFsTree $ FS.replace openFilePath file' (mockFiles fs)+ let written = fromIntegral $ BS.length toWrite+ return (written, (files', hs))+ where+ errNoWriteAccess fp mode = FsError {+ fsErrorType = FsInvalidArgument+ , fsErrorPath = fsToFsErrorPathUnmounted fp+ , fsErrorString = "cannot hPutBufSomeAt in " <> mode <> " mode"+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = True+ }++ errReadPastBufEnd fp = FsError {+ fsErrorType = FsInvalidArgument+ , fsErrorPath = fsToFsErrorPathUnmounted fp+ , fsErrorString = "hPutBufSomeAt: reading from buffer past end not supported"+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = True+ }++hPutBufSomeAt :: (CanSimFS m, PrimMonad m) => Handle' -> MutableByteArray (PrimState m) -> BufferOffset -> ByteCount -> AbsOffset -> m ByteCount+hPutBufSomeAt h buf bufOff n o = do+ withOpenHandleModify h $ \fs hs@OpenHandle{..} -> do+ file <- checkFsTree $ FS.getFile openFilePath (mockFiles fs)+ let o' = unAbsOffset o+ let fsize = fromIntegral (BS.length file)+ case openPtr of+ RW _ w _ -> do+ unless w $ throwError (errNoWriteAccess openFilePath "read")+ -- This is the same fsLimitation we get when we seek past the end of+ -- EOF, in AbsoluteSeek mode.+ when (o' > fsize) $ throwError (errPastEnd openFilePath)+ -- We can't write more bytes than the buffer size+ toWrite <- fromBuffer buf bufOff n >>= \case+ Nothing -> throwError (errReadPastBufEnd openFilePath)+ Just bs -> pure bs+ let file' = replace o' toWrite file+ files' <- checkFsTree $ FS.replace openFilePath file' (mockFiles fs)+ let written = fromIntegral $ BS.length toWrite+ return (written, (files', hs))+ Append -> throwError (errNoWriteAccess openFilePath "append")+ where+ errNoWriteAccess fp mode = FsError {+ fsErrorType = FsInvalidArgument+ , fsErrorPath = fsToFsErrorPathUnmounted fp+ , fsErrorString = "cannot hPutBufSomeAt in " <> mode <> " mode"+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = True+ }++ errPastEnd fp = FsError {+ fsErrorType = FsInvalidArgument+ , fsErrorPath = fsToFsErrorPathUnmounted fp+ , fsErrorString = "hPutBufSomeAt offset past EOF not supported"+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = True+ }++ errReadPastBufEnd fp = FsError {+ fsErrorType = FsInvalidArgument+ , fsErrorPath = fsToFsErrorPathUnmounted fp+ , fsErrorString = "hPutBufSomeAt: reading from buffer past end not supported"+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = True+ }
+ src/System/FS/Sim/Prim.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralisedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE UndecidableInstances #-}++-- | Mocked, monad transformer-based implementation of the 'HasFS' interface.+module System.FS.Sim.Prim (+ FSSimT+ , runFSSimT+ , primHasMockFS+ ) where++import Control.Monad.Except+import Control.Monad.Primitive+import Control.Monad.State++import System.FS.API++import qualified System.FS.Sim.MockFS as Mock+import System.FS.Sim.MockFS (MockFS)++-- | 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+ }+ 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++-- | Mocked, monad transformer-based implementation of the 'HasFS' interface.+--+-- This implementation is pure when running in a monad @m@ that is+-- 'Control.Monad.ST.ST'.+--+-- This implementation runs in a primitive monad @m@ extended with an 'FSSimT'+-- monad transformer. It is recommended to use 'System.FS.Sim.STM.simHasFS' or+-- 'System.FS.Sim.Error.simErrorHasFS' instead because they hide the monad+-- transformer. The caveat is that @m@ should be IO-like.+primHasMockFS :: PrimMonad m => HasFS (FSSimT m) Mock.HandleMock+-- An alternative design could have fixed this implementation to+-- 'Control.Monad.ST.ST', and used 'Control.Monad.Class.MonadST.stToIO' to+-- convert between a pure and 'IO' version. However, it's simpler to just+-- overload this function.+primHasMockFS = HasFS {+ dumpState = Mock.dumpState+ , hOpen = Mock.hOpen+ , hClose = Mock.hClose+ , hIsOpen = Mock.hIsOpen+ , hSeek = Mock.hSeek+ , hGetSome = Mock.hGetSome+ , hGetSomeAt = Mock.hGetSomeAt+ , hPutSome = Mock.hPutSome+ , hTruncate = Mock.hTruncate+ , hGetSize = Mock.hGetSize+ , createDirectory = Mock.createDirectory+ , createDirectoryIfMissing = Mock.createDirectoryIfMissing+ , listDirectory = Mock.listDirectory+ , doesDirectoryExist = Mock.doesDirectoryExist+ , doesFileExist = Mock.doesFileExist+ , removeDirectoryRecursive = Mock.removeDirectoryRecursive+ , removeFile = Mock.removeFile+ , renameFile = Mock.renameFile+ , mkFsErrorPath = fsToFsErrorPathUnmounted+ , unsafeToFilePath = \_ -> error "pureHasFS:unsafeToFilePath"+ -- File I\/O with user-supplied buffers+ , hGetBufSome = Mock.hGetBufSome+ , hGetBufSomeAt = Mock.hGetBufSomeAt+ , hPutBufSome = Mock.hPutBufSome+ , hPutBufSomeAt = Mock.hPutBufSomeAt+ }
+ src/System/FS/Sim/STM.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | 'HasFS' instance using 'MockFS' stored in an STM variable+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 qualified System.FS.Sim.MockFS as Mock+import System.FS.Sim.MockFS (HandleMock, MockFS)+import System.FS.Sim.Prim++{------------------------------------------------------------------------------+ The simulation-related types+------------------------------------------------------------------------------}++--- | 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 fs act = do+ 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' mockFS = simHasFS <$> newTMVarIO mockFS++-- | 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+ }+ 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++ (.:) :: (y -> z) -> (x0 -> x1 -> y) -> (x0 -> x1 -> z)+ (f .: g) x0 x1 = f (g x0 x1)++ (..:) :: (y -> z) -> (x0 -> x1 -> x2 -> y) -> (x0 -> x1 -> x2 -> z)+ (f ..: g) x0 x1 x2 = f (g x0 x1 x2)++ (...:) :: (y -> z) -> (x0 -> x1 -> x2 -> x3 -> y) -> (x0 -> x1 -> x2 -> x3 -> z)+ (f ...: g) x0 x1 x2 x3 = f (g x0 x1 x2 x3)++ (....:) :: (y -> z) -> (x0 -> x1 -> x2 -> x3 -> x4 -> y) -> (x0 -> x1 -> x2 -> x3 -> x4 -> z)+ (f ....: g) x0 x1 x2 x3 x4 = f (g x0 x1 x2 x3 x4)
+ src/System/FS/Sim/Stream.hs view
@@ -0,0 +1,168 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Possibly infinite streams of @'Maybe' a@s.+module System.FS.Sim.Stream (+ -- * Streams+ Stream+ -- * Running+ , runStream+ -- * Construction+ , always+ , empty+ , mkInfinite+ , repeating+ , unsafeMkFinite+ -- * Query+ , null+ -- * Generation and shrinking+ , genFinite+ , genInfinite+ , genMaybe+ , genMaybe'+ , shrinkStream+ ) where++import Control.Monad (replicateM)+import Prelude hiding (null)+import qualified Test.QuickCheck as QC+import Test.QuickCheck (Gen)++{-------------------------------------------------------------------------------+ Streams+-------------------------------------------------------------------------------}++-- | A 'Stream' is a stream of @'Maybe' a@s, which is /possibly/ infinite or+-- /definitely/ finite.+--+-- Finiteness is tracked internally and used for 'QC.shrink'ing and the 'Show'+-- instance.+data Stream a = Stream {+ -- | Info about the size of the stream.+ _streamInternalInfo :: InternalInfo+ , _getStream :: [Maybe a]+ }+ deriving Functor++-- | Tag for 'Stream's that describes whether it is either /definitely/ a finite+-- stream, or /possibly/ an infinite stream.+--+-- Useful for the 'Show' instance of 'Stream': when a 'Stream' is /definitely/+-- finite, we can safely print the full stream.+data InternalInfo = Infinite | Finite++-- | Fully shows a 'Stream' if it is /definitely/ finite, or prints a+-- placeholder string if it is /possibly/ infinite.+instance Show a => Show (Stream a) where+ showsPrec n (Stream info xs) = case info of+ Infinite -> ("<infinite stream>" ++)+ Finite -> (if n > 10 then ('(':) else id)+ . shows xs+ . (" ++ ..." ++)+ . (if n > 10 then (')':) else id)++{-------------------------------------------------------------------------------+ Running+-------------------------------------------------------------------------------}++-- | Advance the 'Stream'. Return the @'Maybe' a@ and the remaining 'Stream'.+--+-- Returns 'Nothing' by default if the 'Stream' is empty.+runStream :: Stream a -> (Maybe a, Stream a)+runStream s@(Stream _ [] ) = (Nothing, s)+runStream (Stream info (a:as)) = (a, Stream info as)++{-------------------------------------------------------------------------------+ Construction+-------------------------------------------------------------------------------}++-- | Make an empty 'Stream'.+empty :: Stream a+empty = Stream Finite []++-- | Make a 'Stream' that always generates the given @a@.+always :: a -> Stream a+always x = Stream Infinite (repeat (Just x))++-- | Make a 'Stream' that infinitely repeats the given list.+repeating :: [Maybe a] -> Stream a+repeating xs = Stream Infinite $ concat (repeat xs)++-- | UNSAFE: Make a 'Stream' that is marked as definitely finite.+--+-- This is unsafe since a user can pass in any list, and evaluating+-- 'Test.QuickCheck.shrink' or 'show' on the resulting 'Stream' will diverge. It+-- is the user's responsibility to only pass in a finite list.+unsafeMkFinite :: [Maybe a] -> Stream a+unsafeMkFinite = Stream Finite++-- | Make a 'Stream' that is marked as possibly infinite.+mkInfinite :: [Maybe a] -> Stream a+mkInfinite = Stream Infinite++{-------------------------------------------------------------------------------+ Query+-------------------------------------------------------------------------------}++-- | Return 'True' if the stream is empty.+--+-- A stream consisting of only 'Nothing's (even if it is only one) is not+-- considered to be empty.+null :: Stream a -> Bool+null (Stream _ []) = True+null _ = False++{-------------------------------------------------------------------------------+ Generation and shrinking+-------------------------------------------------------------------------------}++-- | Shrink a stream like it is an 'Test.QuickCheck.InfiniteList'.+--+-- Possibly infinite streams are shrunk differently than lists that are+-- definitely finite, which is to ensure that shrinking terminates.+-- * Possibly infinite streams are shrunk by taking finite prefixes of the+-- argument stream. As such, shrinking a possibly infinite stream creates+-- definitely finite streams.+-- * Definitely finite streams are shrunk like lists are shrunk normally,+-- preserving that the created streams are still definitely finite.+shrinkStream :: Stream a -> [Stream a]+shrinkStream (Stream info xs0) = case info of+ Infinite -> Stream Finite <$> [take n xs0 | n <- map (2^) [0 :: Int ..]]+ Finite -> Stream Finite <$> QC.shrinkList (const []) xs0++-- | Make a @'Maybe' a@ generator based on an @a@ generator.+--+-- Each element has a chance of being either 'Nothing' or an element generated+-- with the given @a@ generator (wrapped in a 'Just').+--+-- The first argument is the likelihood (as used by 'QC.frequency') of a+-- 'Just' where 'Nothing' has likelihood 2.+genMaybe ::+ Int -- ^ Likelihood of 'Nothing'+ -> Int -- ^ Likelihood of @'Just' a@+ -> Gen a+ -> Gen (Maybe a)+genMaybe nLi jLi genA = QC.frequency+ [ (nLi, return Nothing)+ , (jLi, Just <$> genA)+ ]++-- | Like 'genMaybe', but with the likelihood of 'Nothing' fixed to @2@. 'QC.frequency'+genMaybe' ::+ Int -- ^ Likelihood of @'Just' a@+ -> Gen a+ -> Gen (Maybe a)+genMaybe' = genMaybe 2++-- | Generate a finite 'Stream' of length @n@.+genFinite ::+ Int -- ^ Requested size of finite stream. Tip: use 'genMaybe'.+ -> Gen (Maybe a)+ -> Gen (Stream a)+genFinite n gen = Stream Finite <$> replicateM n gen++-- | Generate an infinite 'Stream'.+genInfinite ::+ Gen (Maybe a) -- ^ Tip: use 'genMaybe'.+ -> Gen (Stream a)+genInfinite gen = Stream Infinite <$> QC.listOf gen
+ test/Main.hs view
@@ -0,0 +1,13 @@+module Main (main) where++import qualified Test.System.FS.Sim.Error+import qualified Test.System.FS.Sim.FsTree+import qualified Test.System.FS.StateMachine+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.StateMachine.tests+ ]
+ test/Test/System/FS/Sim/Error.hs view
@@ -0,0 +1,244 @@+{-# OPTIONS_GHC -Wno-orphans #-}++module Test.System.FS.Sim.Error (tests) where++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 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 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++-- 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+ , testProperty "propPutterPutsAll Strict.hPutAllStrict" $+ let toInput = pure+ in propPutterPutsAll hPutSomeC Strict.hPutAllStrict toInput+ , testProperty "propPutterPutsAll Lazy.hPutAll" $+ let toInput = pure . LBS.fromStrict+ in propPutterPutsAll hPutSomeC Lazy.hPutAll toInput+ , testProperty "propPutterPutsAll Lazy.hPut" $+ let toInput = pure . BB.byteString+ 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)+ 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+ , testProperty "propPutterPutsAll hPutBufSomeAt (expects failure)" $ expectFailure $ \p bs ->+ 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+ , testProperty "propPutterPutsAll hPutBufAll" $ \p 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+ , testProperty "propPutterPutsAll hPutBufAllAt" $ \p bs ->+ 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)+ fromOutput = pure+ 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+ fromOutput = pure+ 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)+ fromOutput = pure . LBS.toStrict+ 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+ fromOutput = pure . LBS.toStrict+ in propGetterGetsAll hGetSomeAtC get fromOutput p bs+ , testProperty "propGetterGetsAll Lazy.hGetAll" $ \p bs ->+ let get = Lazy.hGetAll+ fromOutput = pure . LBS.toStrict+ in propGetterGetsAll hGetSomeC get fromOutput p bs+ , testProperty "propGetterGetsAll Lazy.hGetAllAt" $ \p bs ->+ let get hfs h = Lazy.hGetAllAt hfs h 0+ fromOutput = pure . LBS.toStrict+ 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+ 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+ , 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+ 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+ , 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+ 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+ , 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+ 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+ ]++instance Arbitrary BS.ByteString where+ arbitrary = BS.pack <$> arbitrary+ shrink = fmap BS.pack . shrink . BS.unpack++{-------------------------------------------------------------------------------+ Read functions get all requested bytes+-------------------------------------------------------------------------------}++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++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+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+ , hPutBufSomeE = errStream+ , hPutBufSomeAtE = errStream+ }++{-------------------------------------------------------------------------------+ Write functions put all requested bytes+-------------------------------------------------------------------------------}++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++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+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+ , hGetSomeAtE = errStream+ , hGetBufSomeE = errStream+ , hGetBufSomeAtE = errStream+ }
+ test/Test/System/FS/Sim/FsTree.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.System.FS.Sim.FsTree (tests) where++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)++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+ ]+ ]++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++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++{-------------------------------------------------------------------------------+ Examples and expected results+-------------------------------------------------------------------------------}++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)+ ])+ ])+ ]++findUsr :: [FsPath]+findUsr =+ 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"]+ ]++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"]+ ]++findRoot :: [FsPath]+findRoot = [fsPathFromList []] <> findUsr <> findVar
+ test/Test/System/FS/StateMachine.hs view
@@ -0,0 +1,1791 @@+{-# 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]++ 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+++ -- 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+ , 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++ 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 = (" " ++)
+ test/Test/Util.hs view
@@ -0,0 +1,21 @@+module Test.Util (+ showPowersOf10+ , showPowersOf+ ) where++import Data.List (find)+import Data.Maybe (fromJust)+import Text.Printf++showPowersOf10 :: Int -> String+showPowersOf10 = showPowersOf 10++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
+ test/Test/Util/RefEnv.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TupleSections #-}++-- | Environments of QSM references.+module Test.Util.RefEnv (+ RefEnv+ -- opaque+ , elems+ , empty+ , filter+ , fromList+ , keys+ , lookup+ , null+ , reverseLookup+ , singleton+ , toList+ , union+ , (!)+ ) 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 qualified Test.StateMachine.Types.Rank2 as Rank2++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 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'+ ]++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 (first (Rank2.fmap f)) ras++instance Rank2.Foldable (RefEnv k a) where+ foldMap f (RefEnv 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++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+--+-- In most context 'mempty' can be used, but the 'Monoid' instance requires+-- equality, which 'empty' does not.+empty :: RefEnv k a r+empty = RefEnv []++lookup :: (Eq k, Eq1 r) => Reference k r -> RefEnv k a r -> Maybe a+lookup r (RefEnv ras) = Prelude.lookup r ras++(!) :: (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"++keys :: RefEnv k a r -> [Reference k r]+keys (RefEnv ras) = map fst ras++elems :: RefEnv k a r -> [a]+elems (RefEnv ras) = map snd ras++null :: RefEnv k a r -> Bool+null (RefEnv ras) = Prelude.null ras++singleton :: Reference k r -> a -> RefEnv k a r+singleton r a = RefEnv [(r, a)]++filter :: (a -> Bool) -> RefEnv k a r -> RefEnv k a r+filter p (RefEnv ras) = RefEnv (Prelude.filter (p . snd) ras)++reverseLookup :: (a -> Bool) -> RefEnv k a r -> [Reference k r]+reverseLookup p = keys . filter p
+ test/Test/Util/WithEntryCounter.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE RecordWildCards #-}++module Test.Util.WithEntryCounter (+ EntryCounters (..)+ , zeroEntryCounters+ , incrTVar+ , withEntryCounters+ ) where++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+ , createDirectoryIfMissingC :: 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+ }++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++incrTVar :: MonadSTM m => StrictTVar m Word64 -> m ()+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+ , hClose = \a -> incrTVar hCloseC >> hClose a+ , hIsOpen = \a -> incrTVar hIsOpenC >> hIsOpen a+ , hSeek = \a b c -> incrTVar hSeekC >> hSeek a b c+ , hGetSome = \a b -> incrTVar hGetSomeC >> hGetSome a b+ , hGetSomeAt = \a b c -> incrTVar hGetSomeAtC >> hGetSomeAt a b c+ , 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+ , createDirectoryIfMissing = \a b -> incrTVar createDirectoryIfMissingC >> createDirectoryIfMissing a b+ , listDirectory = \a -> incrTVar listDirectoryC >> listDirectory a+ , doesDirectoryExist = \a -> incrTVar doesDirectoryExistC >> doesDirectoryExist a+ , doesFileExist = \a -> incrTVar doesFileExistC >> doesFileExist a+ , removeDirectoryRecursive = \a -> incrTVar removeDirectoryRecursiveC >> removeDirectoryRecursive a+ , removeFile = \a -> incrTVar removeFileC >> removeFile a+ , 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+ , 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+ }