WIP

Author: jorisdral

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

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
+

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

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

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
 -------------------------------------------------------------------------------}