From b4d47ea641599de70f4cf350c7736499d86fe147 Mon Sep 17 00:00:00 2001 From: Joris Dral Date: Thu, 23 May 2024 17:12:44 +0200 Subject: [PATCH] Move `sameError` to `fs-sim-test` The `sameError` function is only used by the model-based tests in `fs-sim-test` to compare errors that the mocked file system throws against errors that the real file system throws. We do not expect users of the `fs-api`/`fs-sim` packages to use this comparison function themselves, so we have moved to `fs-sim-test` instead. Modules in the `System.FS.IO.Internal` hierarchy are now also public. --- fs-api/CHANGELOG.md | 9 +- fs-api/fs-api.cabal | 18 +-- .../src-linux/System/FS/IO/Internal/Error.hs | 7 -- .../src-macos/System/FS/IO/Internal/Error.hs | 17 --- .../System/FS/IO/{Internal.hs => Unix.hs} | 10 +- .../System/FS/IO/{Internal.hs => Windows.hs} | 38 +----- fs-api/src/System/FS/IO.hs | 44 +++---- .../src/System/FS/IO/{Internal => }/Handle.hs | 6 +- fs-sim/test/Test/System/FS/StateMachine.hs | 119 ++++++++++++------ hie.yaml | 2 - 10 files changed, 130 insertions(+), 140 deletions(-) delete mode 100644 fs-api/src-linux/System/FS/IO/Internal/Error.hs delete mode 100644 fs-api/src-macos/System/FS/IO/Internal/Error.hs rename fs-api/src-unix/System/FS/IO/{Internal.hs => Unix.hs} (96%) rename fs-api/src-win32/System/FS/IO/{Internal.hs => Windows.hs} (76%) rename fs-api/src/System/FS/IO/{Internal => }/Handle.hs (94%) delete mode 100644 hie.yaml diff --git a/fs-api/CHANGELOG.md b/fs-api/CHANGELOG.md index bfea60a..6652a9e 100644 --- a/fs-api/CHANGELOG.md +++ b/fs-api/CHANGELOG.md @@ -10,6 +10,11 @@ `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 public, inspired by + "Internal convention is a mistake". The following modules are moved/renamed: + * `System.FS.IO.Internal` is moved to `System.FS.IO.Unix` on Linux and MacOS + systems, and moved to `System.FS.IO.Windows` on Windows systems. + * `System.FS.IO.Internal.Handle` is moved to `System.FS.IO.Handle`. ### Non-breaking @@ -20,10 +25,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..8b38f97 100644 --- a/fs-api/fs-api.cabal +++ b/fs-api/fs-api.cabal @@ -35,8 +35,7 @@ library System.FS.Condense System.FS.CRC System.FS.IO - System.FS.IO.Internal - System.FS.IO.Internal.Handle + System.FS.IO.Handle default-language: Haskell2010 build-depends: @@ -52,23 +51,18 @@ library , text >=1.2 && <2.2 if os(windows) - hs-source-dirs: src-win32 - build-depends: Win32 >=2.6.1.0 + hs-source-dirs: src-win32 + exposed-modules: System.FS.IO.Windows + build-depends: Win32 >=2.6.1.0 + -- every other distribution is handled like it is Unix-based else hs-source-dirs: src-unix + exposed-modules: System.FS.IO.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/Unix.hs similarity index 96% rename from fs-api/src-unix/System/FS/IO/Internal.hs rename to fs-api/src-unix/System/FS/IO/Unix.hs index b3ba47d..bdd842e 100644 --- a/fs-api/src-unix/System/FS/IO/Internal.hs +++ b/fs-api/src-unix/System/FS/IO/Unix.hs @@ -1,9 +1,9 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE PackageImports #-} --- | This is meant to be used for the implementation of HasFS instances and not --- directly by client code. -module System.FS.IO.Internal ( +-- | This module is mainly meant to be used for the 'IO' implementation of +-- 'System.FS.API.HasFS'. +module System.FS.IO.Unix ( FHandle , close , getSize @@ -13,7 +13,6 @@ module System.FS.IO.Internal ( , pwriteBuf , read , readBuf - , sameError , seek , truncate , write @@ -30,8 +29,7 @@ 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 System.FS.IO.Handle import qualified System.Posix as Posix import System.Posix (ByteCount, Fd (..), FileOffset) import qualified System.Posix.IO.ByteString.Ext as Posix (fdPreadBuf, diff --git a/fs-api/src-win32/System/FS/IO/Internal.hs b/fs-api/src-win32/System/FS/IO/Windows.hs similarity index 76% rename from fs-api/src-win32/System/FS/IO/Internal.hs rename to fs-api/src-win32/System/FS/IO/Windows.hs index 452a00f..af6677c 100644 --- a/fs-api/src-win32/System/FS/IO/Internal.hs +++ b/fs-api/src-win32/System/FS/IO/Windows.hs @@ -1,8 +1,8 @@ {-# OPTIONS_GHC -Wno-dodgy-imports #-} --- | This is meant to be used for the implementation of HasFS instances and not --- directly by client code. -module System.FS.IO.Internal ( +-- | This module is mainly meant to be used for the 'IO' implementation of +-- 'System.FS.API.HasFS'. +module System.FS.IO.Windows ( FHandle , close , getSize @@ -12,7 +12,6 @@ module System.FS.IO.Internal ( , pwriteBuf , read , readBuf - , sameError , seek , truncate , write @@ -27,9 +26,9 @@ import Data.ByteString import Data.ByteString.Internal as Internal import Data.Word (Word32, Word64, Word8) import Foreign (Int64, Ptr) -import System.FS.API.Types (AllowExisting (..), FsError (..), - FsErrorType (..), OpenMode (..), SeekMode (..)) -import System.FS.IO.Internal.Handle +import System.FS.API.Types (AllowExisting (..), OpenMode (..), + SeekMode (..)) +import System.FS.IO.Handle import System.Posix.Types import System.Win32 @@ -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-api/src/System/FS/IO.hs b/fs-api/src/System/FS/IO.hs index 4a5b0a5..90d37ba 100644 --- a/fs-api/src/System/FS/IO.hs +++ b/fs-api/src/System/FS/IO.hs @@ -1,9 +1,9 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} --- | IO implementation of the 'HasFS' interface +-- | 'IO' implementation of the 'HasFS' interface. module System.FS.IO ( - -- * IO implementation & monad HandleIO , ioHasFS ) where @@ -19,8 +19,13 @@ import qualified Foreign import GHC.Stack import qualified System.Directory as Dir import System.FS.API -import qualified System.FS.IO.Internal as F -import qualified System.FS.IO.Internal.Handle as H +#if defined(mingw32_HOST_OS) +import qualified System.FS.IO.Windows as F +#else +-- treat every other distribution like it is (Ubuntu) Linux +import qualified System.FS.IO.Unix as F +#endif +import qualified System.FS.IO.Handle as H {------------------------------------------------------------------------------- I/O implementation of HasFS @@ -31,6 +36,10 @@ import qualified System.FS.IO.Internal.Handle as H -- We store the path the handle points to for better error messages type HandleIO = F.FHandle +-- | 'IO' implementation of the 'HasFS' interface using the /real/ file system. +-- +-- The concrete implementation depends on the OS distribution, but behaviour +-- should be similar across distributions. ioHasFS :: (MonadIO m, PrimState IO ~ PrimState m) => MountPoint -> HasFS m HandleIO ioHasFS mount = HasFS { -- TODO(adn) Might be useful to implement this properly by reading all @@ -94,21 +103,14 @@ ioHasFS mount = HasFS { root = fsToFilePath mount rethrowFsError :: HasCallStack => FsPath -> IO a -> IO a - rethrowFsError = _rethrowFsError mount - -{-# INLINE _rethrowFsError #-} --- | Catch IO exceptions and rethrow them as 'FsError' --- --- See comments for 'ioToFsError' -_rethrowFsError :: HasCallStack => MountPoint -> FsPath -> IO a -> IO a -_rethrowFsError mount fp action = do - res <- E.try action - case res of - Left err -> handleError err - Right a -> return a - where - handleError :: HasCallStack => IOError -> IO a - handleError ioErr = E.throwIO $ ioToFsError errorPath ioErr + rethrowFsError fp action = do + res <- E.try action + case res of + Left err -> handleError err + Right a -> return a + where + handleError :: HasCallStack => IOError -> IO a + handleError ioErr = E.throwIO $ ioToFsError errorPath ioErr - errorPath :: FsErrorPath - errorPath = fsToFsErrorPath mount fp + errorPath :: FsErrorPath + errorPath = fsToFsErrorPath mount fp diff --git a/fs-api/src/System/FS/IO/Internal/Handle.hs b/fs-api/src/System/FS/IO/Handle.hs similarity index 94% rename from fs-api/src/System/FS/IO/Internal/Handle.hs rename to fs-api/src/System/FS/IO/Handle.hs index 09a6414..ab21659 100644 --- a/fs-api/src/System/FS/IO/Internal/Handle.hs +++ b/fs-api/src/System/FS/IO/Handle.hs @@ -1,8 +1,8 @@ {-# LANGUAGE LambdaCase #-} --- | This is meant to be used for the implementation of HasFS instances and not --- directly by client code. -module System.FS.IO.Internal.Handle ( +-- | This module is mainly meant to be used for the 'IO' implementation of +-- 'System.FS.API.HasFS'. +module System.FS.IO.Handle ( HandleOS (..) , closeHandleOS , isHandleClosedException diff --git a/fs-sim/test/Test/System/FS/StateMachine.hs b/fs-sim/test/Test/System/FS/StateMachine.hs index dae47f5..e15b560 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,61 @@ 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 '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 +442,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 +869,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 +1602,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 +1616,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 +1646,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 +1709,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