Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Re-enable QSM tests for all distributions #41

Merged
merged 2 commits into from
Mar 11, 2024
Merged
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension


Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
2 changes: 1 addition & 1 deletion .github/workflows/documentation.yml
Original file line number Diff line number Diff line change
@@ -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 }}
6 changes: 6 additions & 0 deletions fs-api/CHANGELOG.md
Original file line number Diff line number Diff line change
@@ -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
19 changes: 11 additions & 8 deletions fs-api/fs-api.cabal
Original file line number Diff line number Diff line change
@@ -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
7 changes: 7 additions & 0 deletions fs-api/src-linux/System/FS/IO/Internal/Error.hs
Original file line number Diff line number Diff line change
@@ -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

17 changes: 17 additions & 0 deletions fs-api/src-macos/System/FS/IO/Internal/Error.hs
Original file line number Diff line number Diff line change
@@ -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
8 changes: 3 additions & 5 deletions fs-api/src-unix/System/FS/IO/Internal.hs
Original file line number Diff line number Diff line change
@@ -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
17 changes: 3 additions & 14 deletions fs-sim/test/Main.hs
Original file line number Diff line number Diff line change
@@ -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
135 changes: 90 additions & 45 deletions fs-sim/test/Test/System/FS/StateMachine.hs
Original file line number Diff line number Diff line change
@@ -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
-------------------------------------------------------------------------------}