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..bfbaacf --- /dev/null +++ b/fs-api/src-macos/System/FS/IO/Internal/Error.hs @@ -0,0 +1,12 @@ +module System.FS.IO.Internal.Error ( + sameError + ) where + +import System.FS.API.Types (FsError (..), sameFsError) + +sameError :: FsError -> FsError -> Bool +sameError e1 e2 = sameFsError e1 e2 + || (fsErrorPath e1 == fsErrorPath e2 + && sameFsErrorType (fsErrorType e1) (fsErrorType e2)) + where + sameFsErrorType ty1 ty2 = ty1 == ty2 \ No newline at end of file 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/Test/System/FS/StateMachine.hs b/fs-sim/test/Test/System/FS/StateMachine.hs index 40ef25e..c253c4e 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,32 @@ 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. +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 -------------------------------------------------------------------------------}