Merge pull request #41 from input-output-hk/jdral/enable-qsm-tests

Re-enable QSM tests for all distributions

.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 }}

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

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

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
+

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

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

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

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 (..))
@@ -227,36 +229,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 +276,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,15 +288,15 @@ 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)
                 => 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 #502"
+      then error "Unsupported partial write detected, see Note [Checking for partial reads/writes]"
       else return n
 
 {-------------------------------------------------------------------------------
@@ -382,7 +391,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 +408,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 +594,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 +657,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,8 +1446,11 @@ showLabelledExamples :: IO ()
 showLabelledExamples = showLabelledExamples' Nothing 1000 (const True)
 
 prop_sequential :: FilePath -> Property
-prop_sequential tmpDir = withMaxSuccess 10000 $
-    QSM.forAllCommands (sm mountUnused) Nothing $ \cmds -> QC.monadicIO $ do
+prop_sequential tmpDir = withMaxSuccess 1000 $
+    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
@@ -1453,13 +1464,16 @@ 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
 
 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
@@ -1472,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
 -------------------------------------------------------------------------------}