diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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 diff --git a/NOTICE b/NOTICE new file mode 100644 --- /dev/null +++ b/NOTICE @@ -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. + diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. diff --git a/fs-sim.cabal b/fs-sim.cabal new file mode 100644 --- /dev/null +++ b/fs-sim.cabal @@ -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 diff --git a/src/System/FS/Sim/Error.hs b/src/System/FS/Sim/Error.hs new file mode 100644 --- /dev/null +++ b/src/System/FS/Sim/Error.hs @@ -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" + 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 diff --git a/src/System/FS/Sim/FsTree.hs b/src/System/FS/Sim/FsTree.hs new file mode 100644 --- /dev/null +++ b/src/System/FS/Sim/FsTree.hs @@ -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) diff --git a/src/System/FS/Sim/MockFS.hs b/src/System/FS/Sim/MockFS.hs new file mode 100644 --- /dev/null +++ b/src/System/FS/Sim/MockFS.hs @@ -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 + } diff --git a/src/System/FS/Sim/Prim.hs b/src/System/FS/Sim/Prim.hs new file mode 100644 --- /dev/null +++ b/src/System/FS/Sim/Prim.hs @@ -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 + } diff --git a/src/System/FS/Sim/STM.hs b/src/System/FS/Sim/STM.hs new file mode 100644 --- /dev/null +++ b/src/System/FS/Sim/STM.hs @@ -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) diff --git a/src/System/FS/Sim/Stream.hs b/src/System/FS/Sim/Stream.hs new file mode 100644 --- /dev/null +++ b/src/System/FS/Sim/Stream.hs @@ -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 -> ("" ++) + 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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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 + ] diff --git a/test/Test/System/FS/Sim/Error.hs b/test/Test/System/FS/Sim/Error.hs new file mode 100644 --- /dev/null +++ b/test/Test/System/FS/Sim/Error.hs @@ -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 + } diff --git a/test/Test/System/FS/Sim/FsTree.hs b/test/Test/System/FS/Sim/FsTree.hs new file mode 100644 --- /dev/null +++ b/test/Test/System/FS/Sim/FsTree.hs @@ -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 diff --git a/test/Test/System/FS/StateMachine.hs b/test/Test/System/FS/StateMachine.hs new file mode 100644 --- /dev/null +++ b/test/Test/System/FS/StateMachine.hs @@ -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 = (" " ++) diff --git a/test/Test/Util.hs b/test/Test/Util.hs new file mode 100644 --- /dev/null +++ b/test/Test/Util.hs @@ -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 diff --git a/test/Test/Util/RefEnv.hs b/test/Test/Util/RefEnv.hs new file mode 100644 --- /dev/null +++ b/test/Test/Util/RefEnv.hs @@ -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 diff --git a/test/Test/Util/WithEntryCounter.hs b/test/Test/Util/WithEntryCounter.hs new file mode 100644 --- /dev/null +++ b/test/Test/Util/WithEntryCounter.hs @@ -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 + }