From 06af3ac2216024206de0b7b55ca81ee8051a1c2f Mon Sep 17 00:00:00 2001 From: Joris Dral Date: Mon, 26 Feb 2024 16:03:34 +0100 Subject: [PATCH 1/2] Small (documentation/code) touchups for q-s-m tests --- fs-sim/test/Test/System/FS/StateMachine.hs | 91 ++++++++++++---------- 1 file changed, 49 insertions(+), 42 deletions(-) diff --git a/fs-sim/test/Test/System/FS/StateMachine.hs b/fs-sim/test/Test/System/FS/StateMachine.hs index a204f87..40ef25e 100644 --- a/fs-sim/test/Test/System/FS/StateMachine.hs +++ b/fs-sim/test/Test/System/FS/StateMachine.hs @@ -227,36 +227,43 @@ run hasFS@HasFS{..} = go Detecting partial reads/writes of the tested IO implementation -------------------------------------------------------------------------------} --- The functions 'hGetSome', 'hGetSomeAt' and 'hPutSome' might perform partial --- reads/writes, depending on the underlying implementation, see #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 #502 were we track 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. --- --- While using the wrappers 'hGetExactly' and 'hPutAll' instead of 'hGetSome', --- 'hGetSomeAt' and 'hPut' in the implementation of 'run' will opaquely handle --- any potential partial reads/writes, it is not a good solution. The problem --- 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. +{- 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 @@ -267,7 +274,7 @@ hGetSomeChecked HasFS{..} h n = do -- 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" + error "Unsupported partial read detected, see Note [Checking for partial reads/writes]" return bytes hGetSomeAtChecked :: (Monad m, HasCallStack) @@ -279,7 +286,7 @@ hGetSomeAtChecked HasFS{..} h n o = do -- 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" + error "Unsupported partial read detected, see Note [Checking for partial reads/writes]" return bytes hPutSomeChecked :: (Monad m, HasCallStack) @@ -287,7 +294,7 @@ hPutSomeChecked :: (Monad m, HasCallStack) hPutSomeChecked HasFS{..} h bytes = do n <- hPutSome h bytes if fromIntegral (BS.length bytes) /= n - then error "Unsupported partial write detected, see #502" + then error "Unsupported partial write detected, see Note [Checking for partial reads/writes]" else return n {------------------------------------------------------------------------------- @@ -382,7 +389,7 @@ toMock Model{..} (At r) = bimap (knownPaths RE.!) (knownHandles RE.!) r -- | Step the mock semantics -- --- We cannot step the whole Model here (see 'event', below) +-- 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 @@ -399,7 +406,7 @@ openHandles Model{..} = Wrapping in quickcheck-state-machine references -------------------------------------------------------------------------------} --- | Instantiate functor @f@ to @f (PathRef r) (HRef r)@ +-- | 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))} @@ -585,13 +592,12 @@ tempFromPath fp = {------------------------------------------------------------------------------- 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. -------------------------------------------------------------------------------} +-- | 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 @@ -649,7 +655,7 @@ shrinker Model{..} (At cmd) = -- construct replacement -> [PathExpr (PathRef Symbolic)] replaceWithRef pe p f = - filter (canReplace pe) $ map f $ (RE.reverseLookup p knownPaths) + filter (canReplace pe) $ map f $ RE.reverseLookup p knownPaths where canReplace :: PathExpr (PathRef Symbolic) -- current -> PathExpr (PathRef Symbolic) -- candidate @@ -1438,7 +1444,7 @@ showLabelledExamples :: IO () showLabelledExamples = showLabelledExamples' Nothing 1000 (const True) prop_sequential :: FilePath -> Property -prop_sequential tmpDir = withMaxSuccess 10000 $ +prop_sequential tmpDir = withMaxSuccess 1000 $ QSM.forAllCommands (sm mountUnused) Nothing $ \cmds -> QC.monadicIO $ do (tstTmpDir, hist, res) <- QC.run $ withTempDirectory tmpDir "HasFS" $ \tstTmpDir -> do @@ -1453,6 +1459,7 @@ prop_sequential tmpDir = withMaxSuccess 10000 $ return (tstTmpDir, hist, res) QSM.prettyCommands (sm mountUnused) hist + $ QSM.checkCommandNames cmds $ tabulate "Tags" (map show $ tag (execCmds cmds)) $ counterexample ("Mount point: " ++ tstTmpDir) $ res === QSM.Ok From b1ff8af15ba615ee5a0ba4bc164ca1e5a6f5478c Mon Sep 17 00:00:00 2001 From: Joris Dral Date: Thu, 30 Nov 2023 11:22:46 +0100 Subject: [PATCH 2/2] Re-enable QSM tests for all distributions As a "temporary" fix for fs-sim#45, we make the implementation of `sameError` more lenient on MacOS systems. This will possibly be revisited in the future, but for now it should enable running the `q-s-m` tests on all distributions again. --- .github/workflows/documentation.yml | 2 +- fs-api/CHANGELOG.md | 6 +++ fs-api/fs-api.cabal | 19 ++++---- .../src-linux/System/FS/IO/Internal/Error.hs | 7 +++ .../src-macos/System/FS/IO/Internal/Error.hs | 17 +++++++ fs-api/src-unix/System/FS/IO/Internal.hs | 8 ++-- fs-sim/test/Main.hs | 17 ++----- fs-sim/test/Test/System/FS/StateMachine.hs | 44 +++++++++++++++++-- 8 files changed, 89 insertions(+), 31 deletions(-) create mode 100644 fs-api/src-linux/System/FS/IO/Internal/Error.hs create mode 100644 fs-api/src-macos/System/FS/IO/Internal/Error.hs diff --git a/.github/workflows/documentation.yml b/.github/workflows/documentation.yml index 255b5ae..7dcd910 100644 --- a/.github/workflows/documentation.yml +++ b/.github/workflows/documentation.yml @@ -42,7 +42,7 @@ jobs: - name: Setup Haskell id: setup-haskell - uses: haskell/actions/setup@v2 + uses: haskell-actions/setup@v2 with: ghc-version: ${{ env.ghc }} cabal-version: ${{ env.cabal }} diff --git a/fs-api/CHANGELOG.md b/fs-api/CHANGELOG.md index 61bea93..b739bb4 100644 --- a/fs-api/CHANGELOG.md +++ b/fs-api/CHANGELOG.md @@ -1,5 +1,11 @@ # Revision history for fs-api +## next release -- ????-??-?? + +### Patch + +* Make internal error comparison function more lenient on MacOS systems. + ## 0.2.0.1 -- 2023-10-30 ### Patch diff --git a/fs-api/fs-api.cabal b/fs-api/fs-api.cabal index 5b07daf..2621e84 100644 --- a/fs-api/fs-api.cabal +++ b/fs-api/fs-api.cabal @@ -23,13 +23,6 @@ source-repository head library hs-source-dirs: src - - if os(windows) - hs-source-dirs: src-win32 - - else - hs-source-dirs: src-unix - exposed-modules: System.FS.API System.FS.API.Lazy @@ -55,13 +48,23 @@ library , text >=1.2 && <2.2 if os(windows) - build-depends: Win32 >=2.6.1.0 + hs-source-dirs: src-win32 + build-depends: Win32 >=2.6.1.0 else + hs-source-dirs: src-unix build-depends: , unix , unix-bytestring >=0.4.0 + exposed-modules: System.FS.IO.Internal.Error + + if os(linux) + hs-source-dirs: src-linux + + else + hs-source-dirs: src-macos + ghc-options: -Wall -Wcompat -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -Widentities diff --git a/fs-api/src-linux/System/FS/IO/Internal/Error.hs b/fs-api/src-linux/System/FS/IO/Internal/Error.hs new file mode 100644 index 0000000..11b7b19 --- /dev/null +++ b/fs-api/src-linux/System/FS/IO/Internal/Error.hs @@ -0,0 +1,7 @@ +module System.FS.IO.Internal.Error (sameError) where + +import System.FS.API.Types (FsError, sameFsError) + +sameError :: FsError -> FsError -> Bool +sameError = sameFsError + diff --git a/fs-api/src-macos/System/FS/IO/Internal/Error.hs b/fs-api/src-macos/System/FS/IO/Internal/Error.hs new file mode 100644 index 0000000..392858e --- /dev/null +++ b/fs-api/src-macos/System/FS/IO/Internal/Error.hs @@ -0,0 +1,17 @@ +module System.FS.IO.Internal.Error (sameError) where + +import System.FS.API.Types (FsError (..), FsErrorType (..), + sameFsError) + +-- Check default implementation first using 'sameFsError', and otherwise permit +-- some combinations of error types that are not structurally equal. +sameError :: FsError -> FsError -> Bool +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 diff --git a/fs-api/src-unix/System/FS/IO/Internal.hs b/fs-api/src-unix/System/FS/IO/Internal.hs index 5a00ba1..82835ef 100644 --- a/fs-api/src-unix/System/FS/IO/Internal.hs +++ b/fs-api/src-unix/System/FS/IO/Internal.hs @@ -24,8 +24,9 @@ import qualified Data.ByteString.Internal as Internal import Data.Int (Int64) import Data.Word (Word32, Word64, Word8) import Foreign (Ptr) -import System.FS.API.Types (AllowExisting (..), FsError, - OpenMode (..), SeekMode (..), sameFsError) +import System.FS.API.Types (AllowExisting (..), OpenMode (..), + SeekMode (..)) +import System.FS.IO.Internal.Error (sameError) import System.FS.IO.Internal.Handle import qualified System.Posix as Posix import System.Posix (Fd) @@ -152,6 +153,3 @@ close h = closeHandleOS h Posix.closeFd getSize :: FHandle -> IO Word64 getSize h = withOpenHandle "getSize" h $ \fd -> fromIntegral . Posix.fileSize <$> Posix.getFdStatus fd - -sameError :: FsError -> FsError -> Bool -sameError = sameFsError diff --git a/fs-sim/test/Main.hs b/fs-sim/test/Main.hs index 9760fa1..3aced4a 100644 --- a/fs-sim/test/Main.hs +++ b/fs-sim/test/Main.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE CPP #-} - module Main (main) where import System.IO.Temp (withSystemTempDirectory) @@ -14,18 +12,9 @@ main = withSystemTempDirectory "fs-sim-test" $ \tmpDir -> defaultMain $ testGroup "Test" [ testGroup "System" [ - -- TODO: The FS tests fail for darwin on CI, see #532. So, they are - -- disabled for now, but should be enabled once #532 is resolved. - testGroup "FS" $ - [ Test.System.FS.StateMachine.tests tmpDir | not darwin] <> - [ Test.System.FS.Sim.FsTree.tests + testGroup "FS" [ + Test.System.FS.StateMachine.tests tmpDir + , Test.System.FS.Sim.FsTree.tests ] ] ] - -darwin :: Bool -#ifdef darwin_HOST_OS -darwin = True -#else -darwin = False -#endif diff --git a/fs-sim/test/Test/System/FS/StateMachine.hs b/fs-sim/test/Test/System/FS/StateMachine.hs index 40ef25e..3559a2d 100644 --- a/fs-sim/test/Test/System/FS/StateMachine.hs +++ b/fs-sim/test/Test/System/FS/StateMachine.hs @@ -17,6 +17,7 @@ {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} +{- HLINT ignore "Use camelCase" -} -- | Tests for our filesystem abstractions. -- @@ -74,7 +75,7 @@ import Data.TreeDiff (ToExpr (..), defaultExprViaShow) import Data.Word (Word64) import qualified Generics.SOP as SOP import GHC.Generics -import GHC.Stack +import GHC.Stack hiding (prettyCallStack) import System.IO.Temp (withTempDirectory) import System.Random (getStdRandom, randomR) import Text.Read (readMaybe) @@ -89,13 +90,14 @@ 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, testGroup) +import Test.Tasty (TestTree, localOption, testGroup) import Test.Tasty.QuickCheck import System.FS.API import System.FS.IO import qualified System.FS.IO.Internal as F +import Util.CallStack import Util.Condense import System.FS.Sim.FsTree (FsTree (..)) @@ -1445,7 +1447,10 @@ showLabelledExamples = showLabelledExamples' Nothing 1000 (const True) prop_sequential :: FilePath -> Property prop_sequential tmpDir = withMaxSuccess 1000 $ - QSM.forAllCommands (sm mountUnused) Nothing $ \cmds -> QC.monadicIO $ do + QSM.forAllCommands (sm mountUnused) Nothing $ runCmds tmpDir + +runCmds :: FilePath -> QSM.Commands (At Cmd) (At Resp) -> Property +runCmds tmpDir cmds = QC.monadicIO $ do (tstTmpDir, hist, res) <- QC.run $ withTempDirectory tmpDir "HasFS" $ \tstTmpDir -> do let mount = MountPoint tstTmpDir @@ -1467,6 +1472,8 @@ prop_sequential tmpDir = withMaxSuccess 1000 $ tests :: FilePath -> TestTree tests tmpDir = testGroup "HasFS" [ testProperty "q-s-m" $ prop_sequential tmpDir + , localOption (QuickCheckTests 1) + $ testProperty "regression_removeFileOnDir" $ runCmds tmpDir regression_removeFileOnDir ] -- | Unused mount mount @@ -1479,6 +1486,37 @@ tests tmpDir = testGroup "HasFS" [ mountUnused :: MountPoint mountUnused = error "mount point 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 -------------------------------------------------------------------------------}