diff --git a/fs-api/CHANGELOG.md b/fs-api/CHANGELOG.md index bfea60a..0fc3440 100644 --- a/fs-api/CHANGELOG.md +++ b/fs-api/CHANGELOG.md @@ -10,6 +10,7 @@ `HasFS`. As a result, `ioHasFS` now requires that `PrimState IO ~ PrimState m`. * Rename `Util.CallStack` and `Util.Condense` to `System.FS.CallStack` and `System.FS.Condense` respectively. +* Make modules in the `System.FS.IO.Internal` hierarchy truly internal. ### Non-breaking @@ -20,10 +21,6 @@ `hGetBufExactly`, `hGetBufExactlyAt`, `hPutBufExactly`, and `hPutBufExactlyAt`. -### 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 c87613a..d85f1c2 100644 --- a/fs-api/fs-api.cabal +++ b/fs-api/fs-api.cabal @@ -35,6 +35,8 @@ library System.FS.Condense System.FS.CRC System.FS.IO + + other-modules: System.FS.IO.Internal System.FS.IO.Internal.Handle @@ -56,19 +58,11 @@ library build-depends: Win32 >=2.6.1.0 else - hs-source-dirs: src-unix + 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 deleted file mode 100644 index 11b7b19..0000000 --- a/fs-api/src-linux/System/FS/IO/Internal/Error.hs +++ /dev/null @@ -1,7 +0,0 @@ -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 deleted file mode 100644 index 392858e..0000000 --- a/fs-api/src-macos/System/FS/IO/Internal/Error.hs +++ /dev/null @@ -1,17 +0,0 @@ -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 b3ba47d..de27d0c 100644 --- a/fs-api/src-unix/System/FS/IO/Internal.hs +++ b/fs-api/src-unix/System/FS/IO/Internal.hs @@ -13,7 +13,6 @@ module System.FS.IO.Internal ( , pwriteBuf , read , readBuf - , sameError , seek , truncate , write @@ -30,7 +29,6 @@ import Data.Word (Word32, Word64, Word8) import Foreign (Ptr) 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 (ByteCount, Fd (..), FileOffset) diff --git a/fs-api/src-win32/System/FS/IO/Internal.hs b/fs-api/src-win32/System/FS/IO/Internal.hs index 452a00f..5e8bd46 100644 --- a/fs-api/src-win32/System/FS/IO/Internal.hs +++ b/fs-api/src-win32/System/FS/IO/Internal.hs @@ -12,7 +12,6 @@ module System.FS.IO.Internal ( , pwriteBuf , read , readBuf - , sameError , seek , truncate , write @@ -129,28 +128,3 @@ close fh = closeHandleOS fh closeHandle getSize :: FHandle -> IO Word64 getSize fh = withOpenHandle "getSize" fh $ \h -> bhfiSize <$> getFileInformationByHandle h - --- | 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 :: FsError -> FsError -> Bool -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 diff --git a/fs-sim/test/Test/System/FS/StateMachine.hs b/fs-sim/test/Test/System/FS/StateMachine.hs index dae47f5..1a8a05c 100644 --- a/fs-sim/test/Test/System/FS/StateMachine.hs +++ b/fs-sim/test/Test/System/FS/StateMachine.hs @@ -1,5 +1,5 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleInstances #-} @@ -106,7 +106,6 @@ import System.FS.API import System.FS.CallStack import System.FS.Condense import System.FS.IO -import qualified System.FS.IO.Internal as F import System.FS.Sim.FsTree (FsTree (..)) import qualified System.FS.Sim.MockFS as Mock @@ -375,13 +374,62 @@ 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(linux_HOST_OS) +sameError = sameFsError +#elif 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 +sameError = error "OS not supported" +#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 'F.sameError' +-- | The 'Eq' instance for 'Resp' uses 'sameError' instance (Eq fp, Eq h) => Eq (Resp fp h) where - Resp (Left e) == Resp (Left e') = F.sameError e e' + Resp (Left e) == Resp (Left e') = sameError e e' Resp (Right a) == Resp (Right a') = a == a' _ == _ = False @@ -395,9 +443,9 @@ runPure cmd mockFS = aux (Left e) = (Resp (Left e), mockFS) aux (Right (r, mockFS')) = (Resp (Right r), mockFS') -runIO :: MountPoint +runIO :: HasFS IO HandleIO -> Cmd FsPath (Handle HandleIO) -> IO (Resp FsPath (Handle HandleIO)) -runIO mount cmd = Resp <$> E.try (run (ioHasFS mount) cmd) +runIO hfs cmd = Resp <$> E.try (run hfs cmd) {------------------------------------------------------------------------------- Bitraversable instances @@ -822,25 +870,25 @@ postcondition model cmd resp = errorHasMountPoint (Right _) = QSM.Top errorHasMountPoint (Left fsError) = QSM.Boolean $ hasMountPoint fsError -semantics :: MountPoint -> Cmd :@ Concrete -> IO (Resp :@ Concrete) -semantics mount (At cmd) = +semantics :: HasFS IO HandleIO -> Cmd :@ Concrete -> IO (Resp :@ Concrete) +semantics hfs (At cmd) = At . bimap QSM.reference QSM.reference <$> - runIO mount (bimap QSM.concrete QSM.concrete cmd) + runIO hfs (bimap QSM.concrete QSM.concrete cmd) -- | The state machine proper -sm :: MountPoint -> QSM.StateMachine Model (At Cmd) IO (At Resp) -sm mount = QSM.StateMachine { - initModel = initModel - , transition = transition - , precondition = precondition - , postcondition = postcondition - , generator = Just . generator - , shrinker = shrinker - , semantics = semantics mount - , mock = mock - , cleanup = QSM.noCleanup - , invariant = Nothing - } +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 @@ -1555,7 +1603,7 @@ showLabelledExamples' mReplay numTests focus = do putStrLn $ "Used replaySeed " ++ show replaySeed where - sm' = sm mountUnused + sm' = sm unusedHasFS pp = \x -> ppShow x ++ "\n" ++ condense x collects :: Show a => [a] -> Property -> Property @@ -1569,23 +1617,24 @@ showLabelledExamples = showLabelledExamples' Nothing 1000 (const True) prop_sequential :: Property prop_sequential = withMaxSuccess 1000 $ - QSM.forAllCommands (sm mountUnused) Nothing runCmds + 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 - sm' = sm mount + hfs = ioHasFS mount + sm' = sm hfs (hist, model, res) <- QSM.runCommands' (pure sm') cmds -- Close all open handles - forM_ (RE.keys (knownHandles model)) $ F.close . handleRaw . QSM.concrete + forM_ (RE.keys (knownHandles model)) $ hClose hfs . QSM.concrete return (tstTmpDir, hist, res) - QSM.prettyCommands (sm mountUnused) hist + QSM.prettyCommands (sm unusedHasFS) hist $ QSM.checkCommandNames cmds $ tabulate "Tags" (map show $ tag (execCmds cmds)) $ counterexample ("Mount point: " ++ tstTmpDir) @@ -1598,15 +1647,14 @@ tests = testGroup "Test.System.FS.StateMachine" [ $ testProperty "regression_removeFileOnDir" $ runCmds regression_removeFileOnDir ] --- | Unused mount mount +-- | Unused HasFS -- --- 'forAllCommands' wants the entire state machine as argument, but we --- need the mount point only when /executing/ the commands in IO. We can --- therefore generate the commands with a dummy mount point, and then --- inside the property construct a temporary directory which we can use --- for execution. -mountUnused :: MountPoint -mountUnused = error "mount point not used during command generation" +-- '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, @@ -1662,7 +1710,7 @@ _showTaggedShrinks hasRequiredTags numLevels = go 0 return () where tags = tag $ execCmds cmds - shrinks = QSM.shrinkCommands (sm mountUnused) cmds + shrinks = QSM.shrinkCommands (sm unusedHasFS) cmds {------------------------------------------------------------------------------- Pretty-printing diff --git a/hie.yaml b/hie.yaml deleted file mode 100644 index f0c7014..0000000 --- a/hie.yaml +++ /dev/null @@ -1,2 +0,0 @@ -cradle: - cabal: \ No newline at end of file