IOHasBufFS interface for I/O using user-supplied buffers

fs-api/CHANGELOG.md

@@ -1,5 +1,16 @@
 # Revision history for fs-api
 
+## next version -- ????-??-??
+
+### Non-breaking
+
+* Add new `HasBufFS` interface for performing I/O using pointer buffers. Note
+  that it is likely that this interfaced is unified with the `HasFS` interface
+  in the future.
+* Add `hGetBufExactlyAt` and `hPutBufExactlyAt` functions that ensure all
+  requested bytes are read or written respectively.
+* Provide an instantiation of the `HasBufFS` interface for `IO`.
+
 ## 0.2.0.1 -- 2023-10-30
 
 ### Patch

fs-api/fs-api.cabal

@@ -10,7 +10,7 @@ license-files:
 
 copyright:       2019-2023 Input Output Global Inc (IOG)
 author:          IOG Engineering Team
-maintainer:      [email protected], Joris Dral
+maintainer:      [email protected], Joris Dral ([email protected])
 category:        System
 build-type:      Simple
 extra-doc-files: CHANGELOG.md
@@ -66,3 +66,23 @@ library
     -Wall -Wcompat -Wincomplete-uni-patterns
     -Wincomplete-record-updates -Wpartial-fields -Widentities
     -Wredundant-constraints -Wmissing-export-lists -Wunused-packages
+
+test-suite fs-api-test
+  type:             exitcode-stdio-1.0
+  hs-source-dirs:   test
+  main-is:          Main.hs
+  other-modules:    Test.System.FS.IO
+  default-language: Haskell2010
+  build-depends:
+    , base
+    , bytestring
+    , fs-api
+    , tasty
+    , tasty-quickcheck
+    , temporary
+
+  ghc-options:
+    -Wall -Wcompat -Wincomplete-uni-patterns
+    -Wincomplete-record-updates -Wpartial-fields -Widentities
+    -Wredundant-constraints -Wmissing-export-lists -Wunused-packages
+    -fno-ignore-asserts

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

@@ -8,6 +8,8 @@ module System.FS.IO.Internal (
   , getSize
   , open
   , pread
+  , preadBuf
+  , pwriteBuf
   , read
   , sameError
   , seek
@@ -26,6 +28,7 @@ import           Foreign (Int64, Ptr)
 import           System.FS.API.Types (AllowExisting (..), FsError (..),
                      FsErrorType (..), OpenMode (..), SeekMode (..))
 import           System.FS.IO.Internal.Handle
+import           System.Posix.Types
 import           System.Win32
 
 type FHandle = HandleOS HANDLE
@@ -87,6 +90,22 @@ pread fh bytes pos = withOpenHandle "pread" fh $ \h ->
     _ <- setFilePointerEx h initialOffset fILE_BEGIN
     return n
 
+preadBuf :: FHandle -> Ptr Word8 -> ByteCount -> FileOffset -> IO ByteCount
+preadBuf fh bufptr c off = withOpenHandle "preadBuf" 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 :: FHandle -> Ptr Word8 -> ByteCount -> FileOffset -> IO ByteCount
+pwriteBuf fh bufptr c off = withOpenHandle "pwriteBuf" 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

@@ -1,3 +1,4 @@
+{-# LANGUAGE BangPatterns        #-}
 {-# LANGUAGE DataKinds           #-}
 {-# LANGUAGE DerivingVia         #-}
 {-# LANGUAGE GADTs               #-}
@@ -17,13 +18,18 @@ module System.FS.API (
   , withFile
     -- * SomeHasFS
   , SomeHasFS (..)
+    -- * Buffer filesystem access
+  , HasBufFS (..)
+  , hGetBufExactlyAt
+  , hPutBufExactlyAt
   ) where
 
 import           Control.Monad.Class.MonadThrow
 import qualified Data.ByteString as BS
 import           Data.Int (Int64)
 import           Data.Set (Set)
 import           Data.Word
+import qualified Foreign
 
 import           System.FS.API.Types as Types
 
@@ -175,3 +181,92 @@ 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
+-------------------------------------------------------------------------------}
+
+-- | Abstract interface for performing I\/O using user-supplied buffers.
+--
+-- Note: this interface is likely going to become part of the 'HasFS' interface,
+-- but is separated for now so downstream code does not break because of adding
+-- an additional type parameter.
+--
+-- TODO: add versions that use the file offset that is stored in the file
+-- handle, akin to 'hGetSome' and 'hPutSome'.
+data HasBufFS m h ptr = HasBufFS {
+    -- | Like 'hGetSomeAt', but the resulting bytes are read into a
+    -- user-supplied buffer.
+    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
+    -- | Like 'hPutSome', but the resulting bytes are written from a
+    -- user-supplied buffer at a given offset. This offset does not affect the
+    -- offset stored in the file handle (see 'hGetSomeAt').
+  , hPutBufSomeAt            :: HasCallStack
+                             => Handle h
+                             -> ptr Word8 -- ^ Buffer to write bytes from
+                             -> Word64    -- ^ The number of bytes to write
+                             -> AbsOffset -- ^ The file offset at which to write
+                             -> m Word64
+  -- | See 'mkFsErrorPath'.
+  --
+  -- Note: this function is included here so that we can use 'HasBufFS' without
+  -- providing a 'HasBufFS'. For an example, see 'hGetBufExactlyAt'.
+  , mkBufFsErrorPath            :: FsPath -> FsErrorPath
+  }
+
+-- | Wrapper for 'hGetBufSomeAt' that ensures that we read exactly as many bytes
+-- as requested. If EOF is found before the requested number of bytes is read,
+-- an 'FsError' exception is thrown.
+hGetBufExactlyAt :: forall m h. (HasCallStack, MonadThrow m)
+                 => HasBufFS m h Foreign.Ptr
+                 -> Handle h
+                 -> Foreign.Ptr Word8 -- ^ Buffer to read bytes into
+                 -> Word64            -- ^ The number of bytes to read
+                 -> AbsOffset         -- ^ The file offset at which to read
+                 -> m Word64
+hGetBufExactlyAt hbfs h buf c off = go 0 off buf
+  where
+    go :: Word64 -> AbsOffset -> Foreign.Ptr Word8 -> m Word64
+    go !remainingCount !currentOffset currentBuf
+      | remainingCount == 0 = pure c
+      | otherwise            = do
+          readBytes <- hGetBufSomeAt hbfs h currentBuf c currentOffset
+          if readBytes == 0 then
+            throwIO FsError {
+                fsErrorType   = FsReachedEOF
+              , fsErrorPath   = mkBufFsErrorPath hbfs $ handlePath h
+              , fsErrorString = "hGetBufExactlyAt found eof before reading " ++ show c ++ " bytes"
+              , fsErrorNo     = Nothing
+              , fsErrorStack  = prettyCallStack
+              , fsLimitation  = False
+              }
+          -- We know the length <= remainingBytes, so this can't underflow.
+          else go (remainingCount - readBytes)
+                  (currentOffset + fromIntegral readBytes)
+                  (currentBuf `Foreign.plusPtr` fromIntegral readBytes)
+
+-- | Wrapper for 'hPutBufSomeAt' that ensures we write exactly as many bytes as
+-- requested.
+hPutBufExactlyAt :: forall m h. (HasCallStack, MonadThrow m)
+                 => HasBufFS m h Foreign.Ptr
+                 -> Handle h
+                 -> Foreign.Ptr Word8 -- ^ Buffer to write bytes from
+                 -> Word64            -- ^ The number of bytes to write
+                 -> AbsOffset         -- ^ The file offset at which to write
+                 -> m Word64
+hPutBufExactlyAt hbfs h buf c off = go 0 off buf
+  where
+    go :: Word64 -> AbsOffset -> Foreign.Ptr Word8 -> m Word64
+    go !remainingCount !currentOffset currentBuf = do
+      writtenBytes <- hPutBufSomeAt hbfs h currentBuf remainingCount currentOffset
+      let remainingCount' = remainingCount - writtenBytes
+      if remainingCount' == 0
+        then pure c
+        else go remainingCount'
+                (currentOffset + fromIntegral writtenBytes)
+                (currentBuf `Foreign.plusPtr` fromIntegral writtenBytes)

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,37 @@ 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
+{-# 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
+
+    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)
+    , mkBufFsErrorPath = fsToFsErrorPath mount
+    }
+  where
+    rethrowFsError = _rethrowFsError mount

fs-api/test/Main.hs

@@ -0,0 +1,9 @@
+module Main (main) where
+
+import           Test.System.FS.IO
+import           Test.Tasty
+
+main :: IO ()
+main = defaultMain $ testGroup "fs-api-test" [
+      Test.System.FS.IO.tests
+    ]