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.
input-output-hk · May 31, 2024 · b4d47ea · b4d47ea
1 parent 3a21edd
commit b4d47ea
Show file tree

Hide file tree

Showing 10 changed files with 130 additions and 140 deletions.
diff --git 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
@@ -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
diff --git a/fs-api/src-macos/System/FS/IO/Internal/Error.hs b/fs-api/src-macos/System/FS/IO/Internal/Error.hs
diff --git a/fs-api/src-unix/System/FS/IO/Internal.hs → fs-api/src-unix/System/FS/IO/Unix.hs b/fs-api/src-unix/System/FS/IO/Internal.hs → 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 → fs-api/src-win32/System/FS/IO/Windows.hs b/fs-api/src-win32/System/FS/IO/Internal.hs → 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
@@ -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 → fs-api/src/System/FS/IO/Handle.hs b/fs-api/src/System/FS/IO/Internal/Handle.hs → 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