IOHasBufFS` interface for I/O using user-supplied buffers

.stylish-haskell.yaml

@@ -21,7 +21,7 @@ steps:
   #
   #     # Should export lists be sorted?  Sorting is only performed within the
   #     # export section, as delineated by Haddock comments.
-      sort: true
+      sort: false
   #
   #     # See `separate_lists` for the `imports` step.
       separate_lists: true

fs-api/CHANGELOG.md

@@ -2,6 +2,22 @@
 
 ## next release -- ????-??-??
 
+### Breaking
+
+* New `primitive ^>=0.9` dependency
+* Tighten lower bound on `bytestring` from `>=0.10` to `>=0.10.3`
+
+### 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 `UBuffer` module with a new `UBuffer` module. Provide functions for
+  manipulating and allocation `UBuffer`s.
+* Add compound functions, built from primitives in `HasBufFS`: `hGetAllAt`,
+  `hGetBufExactly`, `hPutBufExactly`, `hGetBufExactlyAt` and `hPutBufExactlyAt`
+* Provide an instantiation of the `HasBufFS` interface for `IO`.
+
 ### Patch
 
 * Make internal error comparison function more lenient on MacOS systems.

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
@@ -45,6 +45,7 @@ library
     , directory   >=1.3  && <1.4
     , filepath    >=1.4  && <1.5
     , io-classes  >=0.3  && <1.5
+    , primitive   ^>=0.9
     , text        >=1.2  && <2.2
 
   if os(windows)
@@ -69,3 +70,24 @@ 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
+    , primitive
+    , 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,11 +9,15 @@ module System.FS.IO.Internal (
   , getSize
   , open
   , pread
+  , preadBuf
+  , pwriteBuf
   , read
+  , readBuf
   , sameError
   , seek
   , truncate
   , write
+  , writeBuf
   ) where
 
 import           Prelude hiding (read, truncate)
@@ -29,8 +33,9 @@ import           System.FS.API.Types (AllowExisting (..), OpenMode (..),
 import           System.FS.IO.Internal.Error (sameError)
 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
 
@@ -130,10 +135,28 @@ read h bytes = withOpenHandle "read" h $ \fd ->
     Internal.createUptoN (fromIntegral bytes) $ \ptr ->
       fromIntegral <$> Posix.fdReadBuf fd ptr (fromIntegral bytes)
 
+readBuf :: FHandle -> Ptr Word8 -> ByteCount -> IO ByteCount
+readBuf f buf c = withOpenHandle "readBuf" f $ \fd -> Posix.fdReadBuf fd buf c
+
+writeBuf :: FHandle -> Ptr Word8 -> ByteCount -> IO ByteCount
+writeBuf f buf c = withOpenHandle "writeBuf" f $ \fd -> Posix.fdWriteBuf fd buf c
+
 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 h buf c off = withOpenHandle "preadBuf" h $ \fd -> Posix.fdPreadBuf fd 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 h buf c off = withOpenHandle "pwriteBuf" h $ \fd -> Posix.fdPwriteBuf fd 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,11 +8,15 @@ module System.FS.IO.Internal (
   , getSize
   , open
   , pread
+  , preadBuf
+  , pwriteBuf
   , read
+  , readBuf
   , sameError
   , seek
   , truncate
   , write
+  , writeBuf
   ) where
 
 import           Prelude hiding (read, truncate)
@@ -26,6 +30,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
@@ -78,6 +83,14 @@ read fh bytes = withOpenHandle "read" fh $ \h ->
 getCurrentFileOffset :: HANDLE -> IO Int64
 getCurrentFileOffset h = setFilePointerEx h 0 fILE_CURRENT
 
+readBuf :: FHandle -> Ptr Word8 -> ByteCount -> IO ByteCount
+readBuf fh buf c = withOpenHandle "readBuf" fh $ \h ->
+    fromIntegral <$> win32_ReadFile h buf (fromIntegral c) Nothing
+
+writeBuf :: FHandle -> Ptr Word8 -> ByteCount -> IO ByteCount
+writeBuf fh buf c = withOpenHandle "writeBuf" fh $ \h ->
+    fromIntegral <$> win32_WriteFile h buf (fromIntegral c) Nothing
+
 pread :: FHandle -> Word64 -> Word64 -> IO ByteString
 pread fh bytes pos = withOpenHandle "pread" fh $ \h ->
   Internal.createUptoN (fromIntegral bytes) $ \ptr -> do
@@ -87,6 +100,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 buf c off = withOpenHandle "preadBuf" fh $ \h -> do
+    initialOffset <- getCurrentFileOffset h
+    _ <- setFilePointerEx h (fromIntegral off) fILE_BEGIN
+    n <- fromIntegral <$> win32_ReadFile h buf (fromIntegral c) Nothing
+    _ <- setFilePointerEx h initialOffset fILE_BEGIN
+    return n
+
+pwriteBuf :: FHandle -> Ptr Word8 -> ByteCount -> FileOffset -> IO ByteCount
+pwriteBuf fh buf c off = withOpenHandle "pwriteBuf" fh $ \h -> do
+    initialOffset <- getCurrentFileOffset h
+    _ <- setFilePointerEx h (fromIntegral off) fILE_BEGIN
+    n <- fromIntegral <$> win32_WriteFile h buf (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,11 +18,20 @@ module System.FS.API (
   , withFile
     -- * SomeHasFS
   , SomeHasFS (..)
+    -- * HasBufFS
+  , HasBufFS (..)
+  , hGetBufAllAt
+  , hGetBufExactly
+  , hGetBufExactlyAt
+  , hPutBufExactly
+  , hPutBufExactlyAt
   ) where
 
 import           Control.Monad.Class.MonadThrow
+import           Control.Monad.Primitive (PrimMonad (..))
 import qualified Data.ByteString as BS
 import           Data.Int (Int64)
+import           Data.Primitive (MutableByteArray)
 import           Data.Set (Set)
 import           Data.Word
 
@@ -175,3 +185,179 @@ 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.
+--
+-- [User-supplied buffers]: It is the user's responsiblity to provide buffers
+--   that are large enough. Behaviour is undefined if the I\/O operations access
+--   the buffer outside it's allocated range.
+--
+-- Note: this interface is likely going to become part of the 'HasFS' interface,
+-- but is separated for now so downstream code does not break.
+data HasBufFS m h = HasBufFS {
+    -- | Like 'hGetSome', but the bytes are read into a user-supplied buffer.
+    -- See __User-supplied buffers__.
+    hGetBufSome      :: HasCallStack
+                     => Handle h
+                     -> MutableByteArray (PrimState m) -- ^ Buffer to read bytes into
+                     -> Int -- ^ Offset into buffer
+                     -> Word64  -- ^ The number of bytes to read
+                     -> m Word64
+    -- | Like 'hGetSomeAt', but the bytes are read into a user-supplied buffer.
+    -- See __User-supplied buffers__.
+  , hGetBufSomeAt    :: HasCallStack
+                     => Handle h
+                     -> MutableByteArray (PrimState m)   -- ^ Buffer to read bytes into
+                     -> Int -- ^ Offset into buffer
+                     -> Word64  -- ^ The number of bytes to read
+                     -> AbsOffset -- ^ The file offset at which to read
+                     -> m Word64
+    -- | Like 'hPutSome', but the bytes are written from a user-supplied buffer.
+    -- See __User-supplied buffers__.
+  , hPutBufSome      :: HasCallStack
+                     => Handle h
+                     -> MutableByteArray (PrimState m) -- ^ Buffer to write bytes from
+                     -> Int -- ^ Offset into buffer
+                     -> Word64  -- ^ The number of bytes to write
+                     -> m Word64
+    -- | Like 'hPutSome', but the bytes are written from a user-supplied buffer
+    -- at a given file offset. This offset does not affect the offset stored in
+    -- the file handle (see also 'hGetSomeAt'). See __User-supplied buffers__.
+  , hPutBufSomeAt    :: HasCallStack
+                     => Handle h
+                     -> MutableByteArray (PrimState m)   -- ^ Buffer to write bytes from
+                     -> Int -- ^ Offset into buffer
+                     -> Word64  -- ^ The number of bytes to write
+                     -> AbsOffset -- ^ The file offset at which to write
+                     -> m Word64
+  }
+
+-- | Wrapper for 'hGetBufSomeAt' that ensures that we read all bytes from a
+-- file.
+--
+-- A sufficiently large buffer can be provided by comparing 'hGetSize' against
+-- the requested file offset.
+--
+-- Is implemented in terms of 'hGetBufExactlyAt'.
+hGetBufAllAt :: forall m h. (HasCallStack, MonadThrow m)
+          => HasFS m h
+          -> HasBufFS m h
+          -> Handle h
+          -> MutableByteArray (PrimState m)   -- ^ Buffer to read bytes into
+          -> Int -- ^ Offset into buffer
+          -> AbsOffset -- ^ The file offset at which to read
+          -> m Word64
+hGetBufAllAt hfs hbfs h buf bufOff off = do
+    sz <- hGetSize hfs h
+    let c = sz - unAbsOffset off
+    hGetBufExactlyAt hfs hbfs h buf bufOff c off
+
+-- | Wrapper for 'hGetBufSome' 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.
+hGetBufExactly :: forall m h. (HasCallStack, MonadThrow m)
+               => HasFS m h
+               -> HasBufFS m h
+               -> Handle h
+               -> MutableByteArray (PrimState m) -- ^ Buffer to read bytes into
+               -> Int -- ^ Offset into buffer
+               -> Word64  -- ^ The number of bytes to read
+               -> m Word64
+hGetBufExactly hfs hbfs h buf bufOff c = go c bufOff
+  where
+    go :: Word64 -> Int -> m Word64
+    go !remainingCount !currentBufOff
+      | remainingCount == 0 = pure c
+      | otherwise            = do
+          readBytes <- hGetBufSome hbfs h buf currentBufOff c
+          if readBytes == 0 then
+            throwIO FsError {
+                fsErrorType   = FsReachedEOF
+              , fsErrorPath   = mkFsErrorPath hfs $ handlePath h
+              , fsErrorString = "hGetBufExactly 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)
+                  (currentBufOff + fromIntegral readBytes)
+
+-- | 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)
+                 => HasFS m h
+                 -> HasBufFS m h
+                 -> Handle h
+                 -> MutableByteArray (PrimState m)   -- ^ Buffer to read bytes into
+                 -> Int -- ^ Offset into buffer
+                 -> Word64    -- ^ The number of bytes to read
+                 -> AbsOffset -- ^ The file offset at which to read
+                 -> m Word64
+hGetBufExactlyAt hfs hbfs h buf bufOff c off = go c off bufOff
+  where
+    go :: Word64 -> AbsOffset -> Int -> m Word64
+    go !remainingCount !currentOffset !currentBufOff
+      | remainingCount == 0 = pure c
+      | otherwise            = do
+          readBytes <- hGetBufSomeAt hbfs h buf currentBufOff c currentOffset
+          if readBytes == 0 then
+            throwIO FsError {
+                fsErrorType   = FsReachedEOF
+              , fsErrorPath   = mkFsErrorPath hfs $ 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)
+                  (currentBufOff + fromIntegral readBytes)
+
+-- | Wrapper for 'hPutBufSome' that ensures we write exactly as many bytes as
+-- requested.
+hPutBufExactly :: forall m h. (HasCallStack, MonadThrow m)
+                 => HasBufFS m h
+                 -> Handle h
+                 -> MutableByteArray (PrimState m) -- ^ Buffer to write bytes from
+                 -> Int -- ^ Offset into buffer
+                 -> Word64  -- ^ The number of bytes to write
+                 -> m Word64
+hPutBufExactly hbfs h buf bufOff c = go c bufOff
+  where
+    go :: Word64 -> Int -> m Word64
+    go !remainingCount !currentBufOff = do
+      writtenBytes <- hPutBufSome hbfs h buf currentBufOff remainingCount
+      let remainingCount' = remainingCount - writtenBytes
+      if remainingCount' == 0
+        then pure c
+        else go remainingCount'
+                (currentBufOff + fromIntegral writtenBytes)
+
+-- | Wrapper for 'hPutBufSomeAt' that ensures we write exactly as many bytes as
+-- requested.
+hPutBufExactlyAt :: forall m h. (HasCallStack, MonadThrow m)
+                 => HasBufFS m h
+                 -> Handle h
+                 -> MutableByteArray (PrimState m)   -- ^ Buffer to write bytes from
+                 -> Int -- ^ Offset into buffer
+                 -> Word64    -- ^ The number of bytes to write
+                 -> AbsOffset -- ^ The file offset at which to write
+                 -> m Word64
+hPutBufExactlyAt hbfs h buf bufOff c off = go c off bufOff
+  where
+    go :: Word64 -> AbsOffset -> Int -> m Word64
+    go !remainingCount !currentOffset !currentBufOff = do
+      writtenBytes <- hPutBufSomeAt hbfs h buf currentBufOff remainingCount currentOffset
+      let remainingCount' = remainingCount - writtenBytes
+      if remainingCount' == 0
+        then pure c
+        else go remainingCount'
+                (currentOffset + fromIntegral writtenBytes)
+                (currentBufOff + fromIntegral writtenBytes)