TOSQUASH

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

@@ -12,25 +12,31 @@ module System.FS.IO.Internal (
   , preadBuf
   , pwriteBuf
   , read
+  , readBuf
   , sameError
   , seek
+  , tell
   , truncate
   , write
+  , writeBuf
   ) where
 
 import           Prelude hiding (read, truncate)
 
 import           Control.Monad (void)
 import           Data.ByteString (ByteString)
 import qualified Data.ByteString.Internal as Internal
+import           Data.Coerce (coerce)
 import           Data.Int (Int64)
 import           Data.Word (Word32, Word64, Word8)
 import           Foreign (Ptr)
+import qualified GHC.IO.Device as Device
+import           GHC.IO.FD (FD (..))
 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 (ByteCount, Fd, FileOffset)
+import           System.Posix (ByteCount, Fd (..), FileOffset)
 import qualified System.Posix.IO.ByteString.Ext as Posix (fdPreadBuf,
                      fdPwriteBuf)
 
@@ -126,12 +132,22 @@ seek :: FHandle -> SeekMode -> Int64 -> IO ()
 seek h seekMode offset = withOpenHandle "seek" h $ \fd ->
     void $ Posix.fdSeek fd seekMode (fromIntegral offset)
 
+tell :: FHandle -> IO Word64
+tell h = withOpenHandle "tell" h $ \fd ->
+    fromIntegral <$> Device.tell (FD (coerce fd) 0)
+
 -- | Reads a given number of bytes from the input 'FHandle'.
 read :: FHandle -> Word64 -> IO ByteString
 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 ->
@@ -141,13 +157,13 @@ pread h bytes offset = withOpenHandle "pread" h $ \fd ->
 -- 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
+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 fh buf c off = withOpenHandle "pwriteBuf" fh $ \h -> Posix.fdPwriteBuf h buf c off
+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

@@ -11,10 +11,12 @@ module System.FS.IO.Internal (
   , preadBuf
   , pwriteBuf
   , read
+  , readBuf
   , sameError
   , seek
   , truncate
   , write
+  , writeBuf
   ) where
 
 import           Prelude hiding (read, truncate)
@@ -81,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
@@ -91,18 +101,18 @@ pread fh bytes pos = withOpenHandle "pread" fh $ \h ->
     return n
 
 preadBuf :: FHandle -> Ptr Word8 -> ByteCount -> FileOffset -> IO ByteCount
-preadBuf fh bufptr c off = withOpenHandle "preadBuf" fh $ \h -> do
+preadBuf fh buf 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
+    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 bufptr c off = withOpenHandle "pwriteBuf" fh $ \h -> do
+pwriteBuf fh buf 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
+    n <- fromIntegral <$> win32_WriteFile h buf (fromIntegral c) Nothing
     _ <- setFilePointerEx h initialOffset fILE_BEGIN
     return n
 

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

@@ -20,7 +20,11 @@ module System.FS.API (
   , SomeHasFS (..)
     -- * Buffer filesystem access
   , HasBufFS (..)
+  , hGetBufAll
+  , hGetBufAllAt
+  , hGetBufExactly
   , hGetBufExactlyAt
+  , hPutBufExactly
   , hPutBufExactlyAt
   ) where
 
@@ -111,6 +115,8 @@ data HasFS m h = HasFS {
     -- may affect this thread).
   , hGetSize                 :: HasCallStack => Handle h -> m Word64
 
+  , hTell                    :: HasCallStack => Handle h -> m AbsOffset
+
     -- Operations of directories
 
     -- | Create new directory
@@ -188,48 +194,125 @@ data SomeHasFS m where
 
 -- | 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.
+-- [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.
 --
--- TODO: add versions that use the file offset that is stored in the file
--- handle, akin to 'hGetSome' and 'hPutSome'.
+-- 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.
 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
+    -- | Like 'hGetSome', but the bytes are read into a user-supplied buffer.
+    -- See __User-supplied buffers__.
+    hGetBufSome      :: HasCallStack
+                     => Handle h
+                     -> ptr Word8 -- ^ Buffer to read bytes into
+                     -> 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
+                     -> 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 bytes are written from a user-supplied buffer.
+    -- See __User-supplied buffers__.
+  , hPutBufSome      :: HasCallStack
+                     => Handle h
+                     -> ptr Word8 -- ^ Buffer to write bytes from
+                     -> 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
+                     -> ptr Word8 -- ^ Buffer to write bytes from
+                     -> Word64    -- ^ The number of bytes to write
+                     -> AbsOffset -- ^ The file offset at which to write
+                     -> m Word64
   }
 
+-- | Wrapper for 'hGetBufSome' that ensures that we read all bytes from a file.
+--
+-- A sufficiently large buffer can be provided by comparing 'hGetSize' against
+-- 'hTell'.
+--
+-- Is implemented in terms of 'hGetBufExactly'.
+hGetBufAll :: forall m h. (HasCallStack, MonadThrow m)
+          => HasFS m h
+          -> HasBufFS m h Foreign.Ptr
+          -> Handle h
+          -> Foreign.Ptr Word8 -- ^ Buffer to read bytes into
+          -> m Word64
+hGetBufAll hfs hbfs h buf = do
+    sz <- hGetSize hfs h
+    off <- hTell hfs h
+    let c = sz - fromIntegral off
+    hGetBufExactly hfs hbfs h buf c
+
+-- | 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 Foreign.Ptr
+          -> Handle h
+          -> Foreign.Ptr Word8 -- ^ Buffer to read bytes into
+          -> AbsOffset         -- ^ The file offset at which to read
+          -> m Word64
+hGetBufAllAt hfs hbfs h buf off = do
+    sz <- hGetSize hfs h
+    let c = sz - fromIntegral off
+    hGetBufExactlyAt hfs hbfs h buf 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 Foreign.Ptr
+               -> Handle h
+               -> Foreign.Ptr Word8 -- ^ Buffer to read bytes into
+               -> Word64            -- ^ The number of bytes to read
+               -> m Word64
+hGetBufExactly hfs hbfs h buf c = go 0 buf
+  where
+    go :: Word64 -> Foreign.Ptr Word8 -> m Word64
+    go !remainingCount !currentBuf
+      | remainingCount == 0 = pure c
+      | otherwise            = do
+          readBytes <- hGetBufSome hbfs h currentBuf 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)
+                  (currentBuf `Foreign.plusPtr` 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)
-                 => HasBufFS m h Foreign.Ptr
+                 => HasFS m h
+                 -> 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
+hGetBufExactlyAt hfs hbfs h buf c off = go 0 off buf
   where
     go :: Word64 -> AbsOffset -> Foreign.Ptr Word8 -> m Word64
     go !remainingCount !currentOffset currentBuf
@@ -239,7 +322,7 @@ hGetBufExactlyAt hbfs h buf c off = go 0 off buf
           if readBytes == 0 then
             throwIO FsError {
                 fsErrorType   = FsReachedEOF
-              , fsErrorPath   = mkBufFsErrorPath hbfs $ handlePath h
+              , fsErrorPath   = mkFsErrorPath hfs $ handlePath h
               , fsErrorString = "hGetBufExactlyAt found eof before reading " ++ show c ++ " bytes"
               , fsErrorNo     = Nothing
               , fsErrorStack  = prettyCallStack
@@ -250,6 +333,25 @@ hGetBufExactlyAt hbfs h buf c off = go 0 off buf
                   (currentOffset + fromIntegral readBytes)
                   (currentBuf `Foreign.plusPtr` 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 Foreign.Ptr
+                 -> Handle h
+                 -> Foreign.Ptr Word8 -- ^ Buffer to write bytes from
+                 -> Word64            -- ^ The number of bytes to write
+                 -> m Word64
+hPutBufExactly hbfs h buf c = go 0 buf
+  where
+    go :: Word64 -> Foreign.Ptr Word8 -> m Word64
+    go !remainingCount currentBuf = do
+      writtenBytes <- hPutBufSome hbfs h currentBuf remainingCount
+      let remainingCount' = remainingCount - writtenBytes
+      if remainingCount' == 0
+        then pure c
+        else go remainingCount'
+                (currentBuf `Foreign.plusPtr` fromIntegral writtenBytes)
+
 -- | Wrapper for 'hPutBufSomeAt' that ensures we write exactly as many bytes as
 -- requested.
 hPutBufExactlyAt :: forall m h. (HasCallStack, MonadThrow m)

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

@@ -194,7 +194,7 @@ instance Show (Handle h) where
 -------------------------------------------------------------------------------}
 
 newtype AbsOffset = AbsOffset { unAbsOffset :: Word64 }
-  deriving (Eq, Ord, Enum, Bounded, Num, Show)
+  deriving (Eq, Ord, Enum, Bounded, Num, Show, Real, Integral)
 
 {-------------------------------------------------------------------------------
   Errors

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

@@ -52,6 +52,8 @@ ioHasFS mount = HasFS {
         F.truncate h sz
     , hGetSize = \(Handle h fp) -> liftIO $ rethrowFsError fp $
         F.getSize h
+    , hTell = \(Handle h fp) -> liftIO $ rethrowFsError fp $
+        AbsOffset <$> F.tell h
     , hPutSome = \(Handle h fp) bs -> liftIO $ rethrowFsError fp $ do
         BS.unsafeUseAsCStringLen bs $ \(ptr, len) ->
             fromIntegral <$> F.write h (Foreign.castPtr ptr) (fromIntegral len)
@@ -104,11 +106,14 @@ _rethrowFsError mount fp action = do
 
 ioHasBufFS :: MonadIO m => MountPoint -> HasBufFS m HandleIO Foreign.Ptr
 ioHasBufFS mount = HasBufFS {
-      hGetBufSomeAt = \(Handle h fp) buf c off -> liftIO $ rethrowFsError fp $
+      hGetBufSome = \(Handle h fp) buf c -> liftIO $ rethrowFsError fp $
+        fromIntegral <$> F.readBuf h buf (fromIntegral c)
+    , hGetBufSomeAt = \(Handle h fp) buf c off -> liftIO $ rethrowFsError fp $
         fromIntegral <$> F.preadBuf h buf (fromIntegral c) (fromIntegral $ unAbsOffset off)
+    , hPutBufSome = \(Handle h fp) buf c -> liftIO $ rethrowFsError fp $
+        fromIntegral <$> F.writeBuf h buf (fromIntegral c)
     , 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