diff --git a/.github/workflows/documentation.yml b/.github/workflows/documentation.yml index 255b5ae..7dcd910 100644 --- a/.github/workflows/documentation.yml +++ b/.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 }} 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..392858e --- /dev/null +++ b/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 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/Main.hs b/fs-sim/test/Main.hs index 9760fa1..3aced4a 100644 --- a/fs-sim/test/Main.hs +++ b/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 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 -------------------------------------------------------------------------------}