TOSQUASH

fs-api/fs-api.cabal

@@ -10,7 +10,7 @@ license-files:
 
 copyright:       2019-2023 Input Output Global Inc (IOG)
 author:          IOG Engineering Team
-maintainer:      operations@iohk.io, Joris Dral
+maintainer:      operations@iohk.io, Joris Dral (joris@well-typed.com)
 category:        System
 build-type:      Simple
 extra-doc-files: CHANGELOG.md

fs-api/src-unix/System/FS/IO/Internal.hs

@@ -9,6 +9,8 @@ module System.FS.IO.Internal (
   , getSize
   , open
   , pread
+  , preadBuf
+  , pwriteBuf
   , read
   , sameError
   , seek
@@ -28,8 +30,9 @@ import           System.FS.API.Types (AllowExisting (..), FsError,
                      OpenMode (..), SeekMode (..), sameFsError)
 import           System.FS.IO.Internal.Handle
 import qualified System.Posix as Posix
-import           System.Posix (Fd)
-import           System.Posix.IO.ByteString.Ext (fdPreadBuf)
+import           System.Posix (ByteCount, Fd, FileOffset)
+import qualified System.Posix.IO.ByteString.Ext as Posix (fdPreadBuf,
+                     fdPwriteBuf)
 
 type FHandle = HandleOS Fd
 
@@ -132,7 +135,19 @@ read h bytes = withOpenHandle "read" h $ \fd ->
 pread :: FHandle -> Word64 -> Word64 -> IO ByteString
 pread h bytes offset = withOpenHandle "pread" h $ \fd ->
     Internal.createUptoN (fromIntegral bytes) $ \ptr ->
-      fromIntegral <$> fdPreadBuf fd ptr (fromIntegral bytes) (fromIntegral offset)
+      fromIntegral <$> Posix.fdPreadBuf fd ptr (fromIntegral bytes) (fromIntegral offset)
+
+-- | @'preadBuf' fh buf c off@ reads @c@ bytes into the buffer @buf@ from the file
+-- handle @fh@ at the file offset @off@. This does not move the position of the
+-- file handle.
+preadBuf :: FHandle -> Ptr Word8 -> ByteCount -> FileOffset -> IO ByteCount
+preadBuf fh buf c off = withOpenHandle "preadBuf" fh $ \h -> Posix.fdPreadBuf h buf c off
+
+-- | @'pwriteBuf' fh buf c off@ writes @c@ bytes from the data in the buffer
+-- @buf@ to the file handle @fh@ at the file offset @off@. This does not move
+-- the position of the file handle.
+pwriteBuf :: FHandle -> Ptr Word8 -> ByteCount -> FileOffset -> IO ByteCount
+pwriteBuf fh buf c off = withOpenHandle "pwriteBuf" fh $ \h -> Posix.fdPwriteBuf h buf c off
 
 -- | Truncates the file managed by the input 'FHandle' to the input size.
 truncate :: FHandle -> Word64 -> IO ()

fs-api/src-win32/System/FS/IO/Internal.hs

@@ -87,6 +87,22 @@ pread fh bytes pos = withOpenHandle "pread" fh $ \h ->
     _ <- setFilePointerEx h initialOffset fILE_BEGIN
     return n
 
+preadBuf :: Handle FHandle -> Ptr Word8 -> ByteCount -> FileOffset -> IO ByteCount
+preadBuf fh bufptr c off = withOpenHandle "preadBuf" (handleRaw fh) $ \h -> do
+    initialOffset <- getCurrentFileOffset h
+    _ <- setFilePointerEx h (fromIntegral off) fILE_BEGIN
+    n <- fromIntegral <$> win32_ReadFile h bufptr (fromIntegral c) Nothing
+    _ <- setFilePointerEx h initialOffset fILE_BEGIN
+    return n
+
+pwriteBuf :: Handle FHandle -> Ptr Word8 -> ByteCount -> FileOffset -> IO ByteCount
+pwriteBuf fh bufptr c off = withOpenHandle "pwriteBuf" (handleRaw fh) $ \h -> do
+    initialOffset <- getCurrentFileOffset h
+    _ <- setFilePointerEx h (fromIntegral off) fILE_BEGIN
+    n <- fromIntegral <$> win32_WriteFile h bufptr (fromIntegral c) Nothing
+    _ <- setFilePointerEx h initialOffset fILE_BEGIN
+    return n
+
 -- We only allow truncate in AppendMode, but Windows do not support it, so we manually seek to the end.
 -- It is important that the logical end of the handle stays alligned to the physical end of the file.
 truncate :: FHandle -> Word64 -> IO ()

fs-api/src/System/FS/API.hs

@@ -17,6 +17,8 @@ module System.FS.API (
   , withFile
     -- * SomeHasFS
   , SomeHasFS (..)
+    -- * Buffer filesystem access
+  , HasBufFS (..)
   ) where
 
 import           Control.Monad.Class.MonadThrow
@@ -175,3 +177,22 @@ hClose' HasFS { hClose, hIsOpen } h = do
 -- hides an existential @h@ parameter of a 'HasFS'.
 data SomeHasFS m where
   SomeHasFS :: Eq h => HasFS m h -> SomeHasFS m
+
+{-------------------------------------------------------------------------------
+  HasBufFS
+-------------------------------------------------------------------------------}
+
+data HasBufFS m h ptr = HasBufFS {
+    hGetBufSomeAt            :: HasCallStack
+                             => Handle h
+                             -> ptr Word8 -- ^ Buffer to read bytes into
+                             -> Word64    -- ^ The number of bytes to read
+                             -> AbsOffset -- ^ The file offset at which to read
+                             -> m Word64
+  , hPutBufSomeAt            :: HasCallStack
+                             => Handle h
+                             -> ptr Word8 -- ^ Buffer to write bytes into
+                             -> Word64    -- ^ The number of bytes to write
+                             -> AbsOffset -- ^ The file offset at which to write
+                             -> m Word64
+  }

fs-api/src/System/FS/IO.hs

@@ -3,14 +3,16 @@ module System.FS.IO (
     -- * IO implementation & monad
     HandleIO
   , ioHasFS
+    -- * HasBufFS
+  , ioHasBufFS
   ) where
 
 import           Control.Concurrent.MVar
 import qualified Control.Exception as E
 import           Control.Monad.IO.Class (MonadIO (..))
 import qualified Data.ByteString.Unsafe as BS
 import qualified Data.Set as Set
-import           Foreign (castPtr)
+import qualified Foreign
 import           GHC.Stack
 import qualified System.Directory as Dir
 import           System.FS.API
@@ -52,7 +54,7 @@ ioHasFS mount = HasFS {
         F.getSize h
     , hPutSome = \(Handle h fp) bs -> liftIO $ rethrowFsError fp $ do
         BS.unsafeUseAsCStringLen bs $ \(ptr, len) ->
-            fromIntegral <$> F.write h (castPtr ptr) (fromIntegral len)
+            fromIntegral <$> F.write h (Foreign.castPtr ptr) (fromIntegral len)
     , createDirectory = \fp -> liftIO $ rethrowFsError fp $
         Dir.createDirectory (root fp)
     , listDirectory = \fp -> liftIO $ rethrowFsError fp $
@@ -76,18 +78,35 @@ ioHasFS mount = HasFS {
     root :: FsPath -> FilePath
     root = fsToFilePath mount
 
-    -- | Catch IO exceptions and rethrow them as 'FsError'
-    --
-    -- See comments for 'ioToFsError'
     rethrowFsError :: HasCallStack => FsPath -> IO a -> IO a
-    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
+    rethrowFsError = _rethrowFsError mount
 
-        errorPath :: FsErrorPath
-        errorPath = fsToFsErrorPath mount fp
+-- | 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
+
+    errorPath :: FsErrorPath
+    errorPath = fsToFsErrorPath mount fp
+
+{-------------------------------------------------------------------------------
+  HasBufFS
+-------------------------------------------------------------------------------}
+
+ioHasBufFS :: MonadIO m => MountPoint -> HasBufFS m HandleIO Foreign.Ptr
+ioHasBufFS mount = HasBufFS {
+      hGetBufSomeAt = \(Handle h fp) buf c off -> liftIO $ rethrowFsError fp $
+        fromIntegral <$> F.preadBuf h buf (fromIntegral c) (fromIntegral $ unAbsOffset off)
+    , hPutBufSomeAt = \(Handle h fp) buf c off -> liftIO $ rethrowFsError fp $
+        fromIntegral <$> F.pwriteBuf h buf (fromIntegral c) (fromIntegral $ unAbsOffset off)
+    }
+  where
+    rethrowFsError = _rethrowFsError mount

fs-sim/fs-sim.cabal

@@ -10,7 +10,7 @@ license-files:
 
 copyright:       2019-2023 Input Output Global Inc (IOG)
 author:          IOG Engineering Team
-maintainer:      operations@iohk.io, Joris Dral
+maintainer:      operations@iohk.io, Joris Dral (joris@well-typed.com)
 category:        Testing
 build-type:      Simple
 extra-doc-files: CHANGELOG.md