Merge pull request #61 from input-output-hk/jdral/merge-hasbuffs-into…

…-hasfs

Merge `HasBufFS` into `HasFS`

fs-api/CHANGELOG.md

@@ -6,15 +6,17 @@
 
 * New `primitive ^>=0.9` dependency
 * Remove orphan `Show` instance for `Foreign.C.Error.Errno`.
+* Provide implementations for the new primitives in the `IO` implementation of
+  `HasFS`. As a result, `ioHasFS` now requires that `PrimState IO ~ PrimState m`.
 
 ### Non-breaking
 
-* Add new `HasBufFS` interface for performing I/O using buffers. Note that it is
-  likely that this interfaced is unified with the `HasFS` interface in the
-  future.
-* Add compound functions, built from primitives in `HasBufFS`: `hGetAllAt`,
-  `hGetBufExactly`, `hPutBufExactly`, `hGetBufExactlyAt` and `hPutBufExactlyAt`
-* Provide an instantiation of the `HasBufFS` interface for `IO`.
+* Add new primitives to the `HasFS` interface for performing file I/O with
+  user-supplied buffers: `hGetBufSome`, `hGetBufSomeAt`, `hPutBufSome`, and
+  `hPutBufSomeAt`.
+* Add compound functions, built from the new primitives in `HasFS`:
+  `hGetBufExactly`, `hGetBufExactlyAt`, `hPutBufExactly`,  and
+  `hPutBufExactlyAt`.
 
 ### Patch
 

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

@@ -19,9 +19,8 @@ module System.FS.API (
   , withFile
     -- * SomeHasFS
   , SomeHasFS (..)
-    -- * HasBufFS
+    -- * File I\/O with user-supplied buffers
   , BufferOffset (..)
-  , HasBufFS (..)
   , hGetBufExactly
   , hGetBufExactlyAt
   , hPutBufExactly
@@ -45,6 +44,13 @@ import           Util.CallStack
   Record that abstracts over the filesystem
 ------------------------------------------------------------------------------}
 
+-- | Abstract interface for performing file I\/O
+--
+-- [User-supplied buffers #user-supplied-buffers#]: For functions that require
+--     user-supplied buffers (i.e., 'MutableByteArray'), 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.
 data HasFS m h = HasFS {
     -- | Debugging: human-readable description of file system state
     dumpState                :: m String
@@ -159,6 +165,44 @@ data HasFS m h = HasFS {
     -- Postcondition: Should throw an error for any @m@ that is not @IO@
     -- (or for which we do not have @'MonadIO' m@).
   , unsafeToFilePath         :: FsPath -> m FilePath
+
+    -- === File I\/O with user-supplied buffers
+
+    -- | Like 'hGetSome', but the bytes are read into a user-supplied buffer.
+    -- See [__User-supplied buffers__](#user-supplied-buffers).
+  , hGetBufSome   :: HasCallStack
+                  => Handle h
+                  -> MutableByteArray (PrimState m) -- ^ Buffer to read bytes into
+                  -> BufferOffset -- ^ Offset into buffer
+                  -> ByteCount -- ^ The number of bytes to read
+                  -> m ByteCount
+    -- | Like 'hGetSomeAt', but the bytes are read into a user-supplied buffer.
+    -- See [__User-supplied buffers__](#user-supplied-buffers).
+  , hGetBufSomeAt :: HasCallStack
+                  => Handle h
+                  -> MutableByteArray (PrimState m)   -- ^ Buffer to read bytes into
+                  -> BufferOffset -- ^ Offset into buffer
+                  -> ByteCount -- ^ The number of bytes to read
+                  -> AbsOffset -- ^ The file offset at which to read
+                  -> m ByteCount
+    -- | Like 'hPutSome', but the bytes are written from a user-supplied buffer.
+    -- See [__User-supplied buffers__](#user-supplied-buffers).
+  , hPutBufSome   :: HasCallStack
+                  => Handle h
+                  -> MutableByteArray (PrimState m) -- ^ Buffer to write bytes from
+                  -> BufferOffset -- ^ Offset into buffer
+                  -> ByteCount -- ^ The number of bytes to write
+                  -> m ByteCount
+    -- | 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__](#user-supplied-buffers).
+  , hPutBufSomeAt :: HasCallStack
+                  => Handle h
+                  -> MutableByteArray (PrimState m)   -- ^ Buffer to write bytes from
+                  -> BufferOffset -- ^ Offset into buffer
+                  -> ByteCount -- ^ The number of bytes to write
+                  -> AbsOffset -- ^ The file offset at which to write
+                  -> m ByteCount
   }
 
 {-------------------------------------------------------------------------------
@@ -189,7 +233,7 @@ data SomeHasFS m where
   SomeHasFS :: Eq h => HasFS m h -> SomeHasFS m
 
 {-------------------------------------------------------------------------------
-  HasBufFS
+  File I\/O with user-supplied buffers
 -------------------------------------------------------------------------------}
 
 -- | Absolute offset into a buffer (i.e., 'MutableByteArray').
@@ -201,70 +245,23 @@ data SomeHasFS m where
 newtype BufferOffset = BufferOffset { unBufferOffset :: Int }
   deriving (Eq, Ord, Enum, Bounded, Num, Show)
 
--- | 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
-                     -> BufferOffset -- ^ Offset into buffer
-                     -> ByteCount -- ^ The number of bytes to read
-                     -> m ByteCount
-    -- | 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
-                     -> BufferOffset -- ^ Offset into buffer
-                     -> ByteCount -- ^ The number of bytes to read
-                     -> AbsOffset -- ^ The file offset at which to read
-                     -> m ByteCount
-    -- | 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
-                     -> BufferOffset -- ^ Offset into buffer
-                     -> ByteCount -- ^ The number of bytes to write
-                     -> m ByteCount
-    -- | 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
-                     -> BufferOffset -- ^ Offset into buffer
-                     -> ByteCount -- ^ The number of bytes to write
-                     -> AbsOffset -- ^ The file offset at which to write
-                     -> m ByteCount
-  }
-
 -- | 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
                -> BufferOffset -- ^ Offset into buffer
                -> ByteCount  -- ^ The number of bytes to read
                -> m ByteCount
-hGetBufExactly hfs hbfs h buf bufOff c = go c bufOff
+hGetBufExactly hfs h buf bufOff c = go c bufOff
   where
     go :: ByteCount -> BufferOffset -> m ByteCount
     go !remainingCount !currentBufOff
       | remainingCount == 0 = pure c
       | otherwise            = do
-          readBytes <- hGetBufSome hbfs h buf currentBufOff c
+          readBytes <- hGetBufSome hfs h buf currentBufOff c
           if readBytes == 0 then
             throwIO FsError {
                 fsErrorType   = FsReachedEOF
@@ -283,20 +280,19 @@ hGetBufExactly hfs hbfs h buf bufOff c = go c bufOff
 -- 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
                  -> BufferOffset -- ^ Offset into buffer
                  -> ByteCount -- ^ The number of bytes to read
                  -> AbsOffset -- ^ The file offset at which to read
                  -> m ByteCount
-hGetBufExactlyAt hfs hbfs h buf bufOff c off = go c off bufOff
+hGetBufExactlyAt hfs h buf bufOff c off = go c off bufOff
   where
     go :: ByteCount -> AbsOffset -> BufferOffset -> m ByteCount
     go !remainingCount !currentOffset !currentBufOff
       | remainingCount == 0 = pure c
       | otherwise            = do
-          readBytes <- hGetBufSomeAt hbfs h buf currentBufOff c currentOffset
+          readBytes <- hGetBufSomeAt hfs h buf currentBufOff c currentOffset
           if readBytes == 0 then
             throwIO FsError {
                 fsErrorType   = FsReachedEOF
@@ -314,7 +310,7 @@ hGetBufExactlyAt hfs hbfs h buf bufOff c off = go c off bufOff
 -- | Wrapper for 'hPutBufSome' that ensures we write exactly as many bytes as
 -- requested.
 hPutBufExactly :: forall m h. (HasCallStack, MonadThrow m)
-                 => HasBufFS m h
+                 => HasFS m h
                  -> Handle h
                  -> MutableByteArray (PrimState m) -- ^ Buffer to write bytes from
                  -> BufferOffset -- ^ Offset into buffer
@@ -334,7 +330,7 @@ hPutBufExactly hbfs h buf bufOff c = go c bufOff
 -- | Wrapper for 'hPutBufSomeAt' that ensures we write exactly as many bytes as
 -- requested.
 hPutBufExactlyAt :: forall m h. (HasCallStack, MonadThrow m)
-                 => HasBufFS m h
+                 => HasFS m h
                  -> Handle h
                  -> MutableByteArray (PrimState m)   -- ^ Buffer to write bytes from
                  -> BufferOffset -- ^ Offset into buffer

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

@@ -1,12 +1,11 @@
 {-# LANGUAGE TypeFamilies  #-}
 {-# LANGUAGE TypeOperators #-}
 
--- | IO implementation of the 'HasFS' class
+-- | IO implementation of the 'HasFS' interface
 module System.FS.IO (
     -- * IO implementation & monad
     HandleIO
   , ioHasFS
-  , ioHasBufFS
   ) where
 
 import           Control.Concurrent.MVar
@@ -32,7 +31,7 @@ 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
 
-ioHasFS :: MonadIO m => MountPoint -> HasFS m HandleIO
+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
       -- the stuff available at the 'MountPoint'.
@@ -77,6 +76,18 @@ ioHasFS mount = HasFS {
         Dir.renameFile (root fp1) (root fp2)
     , mkFsErrorPath = fsToFsErrorPath mount
     , unsafeToFilePath = pure . root
+    , hGetBufSome = \(Handle h fp) buf bufOff c ->  liftIO $ rethrowFsError fp $
+        withMutableByteArrayContents buf $ \ptr ->
+          F.readBuf h (ptr `Foreign.plusPtr` unBufferOffset bufOff) c
+    , hGetBufSomeAt = \(Handle h fp) buf bufOff c off -> liftIO $ rethrowFsError fp $
+        withMutableByteArrayContents buf $ \ptr ->
+          F.preadBuf h (ptr `Foreign.plusPtr` unBufferOffset bufOff) c (fromIntegral $ unAbsOffset off)
+    , hPutBufSome = \(Handle h fp) buf bufOff c -> liftIO $ rethrowFsError fp $
+        withMutableByteArrayContents buf $ \ptr ->
+          F.writeBuf h (ptr `Foreign.plusPtr` unBufferOffset bufOff) c
+    , hPutBufSomeAt = \(Handle h fp) buf bufOff c off -> liftIO $ rethrowFsError fp $
+        withMutableByteArrayContents buf $ \ptr ->
+          F.pwriteBuf h (ptr `Foreign.plusPtr` unBufferOffset bufOff) c (fromIntegral $ unAbsOffset off)
     }
   where
     root :: FsPath -> FilePath
@@ -101,28 +112,3 @@ _rethrowFsError mount fp action = do
 
     errorPath :: FsErrorPath
     errorPath = fsToFsErrorPath mount fp
-
-{-------------------------------------------------------------------------------
-  HasBufFS
--------------------------------------------------------------------------------}
-
-ioHasBufFS ::
-     (MonadIO m, PrimState IO ~ PrimState m)
-  => MountPoint
-  -> HasBufFS m HandleIO
-ioHasBufFS mount = HasBufFS {
-      hGetBufSome = \(Handle h fp) buf bufOff c ->  liftIO $ rethrowFsError fp $
-        withMutableByteArrayContents buf $ \ptr ->
-          F.readBuf h (ptr `Foreign.plusPtr` unBufferOffset bufOff) c
-    , hGetBufSomeAt = \(Handle h fp) buf bufOff c off -> liftIO $ rethrowFsError fp $
-        withMutableByteArrayContents buf $ \ptr ->
-          F.preadBuf h (ptr `Foreign.plusPtr` unBufferOffset bufOff) c (fromIntegral $ unAbsOffset off)
-    , hPutBufSome = \(Handle h fp) buf bufOff c -> liftIO $ rethrowFsError fp $
-        withMutableByteArrayContents buf $ \ptr ->
-          F.writeBuf h (ptr `Foreign.plusPtr` unBufferOffset bufOff) c
-    , hPutBufSomeAt = \(Handle h fp) buf bufOff c off -> liftIO $ rethrowFsError fp $
-        withMutableByteArrayContents buf $ \ptr ->
-          F.pwriteBuf h (ptr `Foreign.plusPtr` unBufferOffset bufOff) c (fromIntegral $ unAbsOffset off)
-    }
-  where
-    rethrowFsError = _rethrowFsError mount

fs-api/test/Test/System/FS/IO.hs

@@ -45,10 +45,8 @@ toByteString n mba = freezeByteArray mba 0 n >>= \(ByteArray ba) -> pure (SBS.fr
 
 -- | A write-then-read roundtrip test for buffered I\/O in 'IO'.
 --
--- The 'ByteString'\'s internal pointer doubles as the buffer used for the I\/O
--- operations, and we only write/read a prefix of the bytestring. This does not
--- test what happens if we try to write/read more bytes than fits in the buffer,
--- because the behaviour is then undefined.
+-- This does not test what happens if we try to write/read more bytes than fits
+-- in the buffer, because the behaviour is then undefined.
 prop_roundtrip_hPutGetBufSome ::
      ByteString
   -> Small ByteCount -- ^ Prefix length
@@ -57,15 +55,14 @@ prop_roundtrip_hPutGetBufSome bs (Small c) =
   BS.length bs >= fromIntegral c ==>
   ioProperty $ withSystemTempDirectory "prop_roundtrip_hPutGetBufSome" $ \dirPath -> do
     let hfs  = IO.ioHasFS (FS.MountPoint dirPath)
-        hbfs = IO.ioHasBufFS (FS.MountPoint dirPath)
 
     FS.withFile hfs (FS.mkFsPath ["temp"]) (FS.WriteMode FS.MustBeNew) $ \h -> do
       putBuf <- fromByteString bs
-      m <- FS.hPutBufSome hbfs h putBuf 0 c
+      m <- FS.hPutBufSome hfs h putBuf 0 c
       let writeTest = counterexample "wrote too many bytes" ((if c > 0 then 1 .<= m else property True) .&&. m .<= c)
       FS.hSeek hfs h FS.AbsoluteSeek 0
       getBuf <- newPinnedByteArray (fromIntegral m)
-      o <- FS.hGetBufSome hbfs h getBuf 0 m
+      o <- FS.hGetBufSome hfs h getBuf 0 m
       let readTest = counterexample "read too many bytes"   ((if c > 0 then 1 .<= o else property True) .&&. o .<= m)
       bs' <- toByteString (fromIntegral o) getBuf
       let cmpTest = counterexample "(prefix of) input and output bytestring do not match"
@@ -82,14 +79,13 @@ prop_roundtrip_hPutGetBufSomeAt bs (Small c) off =
   BS.length bs >= fromIntegral c ==>
   ioProperty $ withSystemTempDirectory "prop_roundtrip_hPutGetBufSomeAt" $ \dirPath -> do
     let hfs  = IO.ioHasFS (FS.MountPoint dirPath)
-        hbfs = IO.ioHasBufFS (FS.MountPoint dirPath)
 
     FS.withFile hfs (FS.mkFsPath ["temp"]) (FS.WriteMode FS.MustBeNew) $ \h -> do
       putBuf <- fromByteString bs
-      m <- FS.hPutBufSomeAt hbfs h putBuf 0 c off
+      m <- FS.hPutBufSomeAt hfs h putBuf 0 c off
       let writeTest = counterexample "wrote too many bytes" ((if c > 0 then 1 .<= m else property True) .&&. m .<= c)
       getBuf <- newPinnedByteArray (fromIntegral m)
-      o <- FS.hGetBufSomeAt hbfs h getBuf 0 m off
+      o <- FS.hGetBufSomeAt hfs h getBuf 0 m off
       let readTest = counterexample "read too many bytes"   ((if c > 0 then 1 .<= o else property True) .&&. o .<= m)
       bs' <- toByteString (fromIntegral o) getBuf
       let cmpTest = counterexample "(prefix of) input and output bytestring do not match"
@@ -106,15 +102,14 @@ prop_roundtrip_hPutGetBufExactly bs (Small c) =
   BS.length bs >= fromIntegral c ==>
   ioProperty $ withSystemTempDirectory "prop_roundtrip_hPutGetBufExactly" $ \dirPath -> do
     let hfs  = IO.ioHasFS (FS.MountPoint dirPath)
-        hbfs = IO.ioHasBufFS (FS.MountPoint dirPath)
 
     FS.withFile hfs (FS.mkFsPath ["temp"]) (FS.WriteMode FS.MustBeNew) $ \h -> do
       putBuf <- fromByteString bs
-      m <- FS.hPutBufExactly hbfs h putBuf 0 c
+      m <- FS.hPutBufExactly hfs h putBuf 0 c
       let writeTest = counterexample "wrote too few bytes" (m === c)
       FS.hSeek hfs h FS.AbsoluteSeek 0
       getBuf <- newPinnedByteArray (fromIntegral c)
-      o <- FS.hGetBufExactly hfs hbfs h getBuf 0 c
+      o <- FS.hGetBufExactly hfs h getBuf 0 c
       let readTest = counterexample "read too few byes"    (o === c)
       bs' <- toByteString (fromIntegral c) getBuf
       let cmpTest = counterexample "input and output bytestring do not match"
@@ -132,14 +127,13 @@ prop_roundtrip_hPutGetBufExactlyAt bs (Small c) off =
   BS.length bs >= fromIntegral c ==>
   ioProperty $ withSystemTempDirectory "prop_roundtrip_hPutGetBufExactlyAt" $ \dirPath -> do
     let hfs  = IO.ioHasFS (FS.MountPoint dirPath)
-        hbfs = IO.ioHasBufFS (FS.MountPoint dirPath)
 
     FS.withFile hfs (FS.mkFsPath ["temp"]) (FS.WriteMode FS.MustBeNew) $ \h -> do
       putBuf <- fromByteString bs
-      m <- FS.hPutBufExactlyAt hbfs h putBuf 0 c off
+      m <- FS.hPutBufExactlyAt hfs h putBuf 0 c off
       let writeTest = counterexample "wrote too few bytes" (m === c)
       getBuf <- newPinnedByteArray (fromIntegral c)
-      o <- FS.hGetBufExactlyAt hfs hbfs h getBuf 0 c off
+      o <- FS.hGetBufExactlyAt hfs h getBuf 0 c off
       let readTest = counterexample "read too few byes"    (o === c)
       bs' <- toByteString (fromIntegral c) getBuf
       let cmpTest = counterexample "input and output bytestring do not match"

fs-sim/CHANGELOG.md

@@ -11,6 +11,20 @@
   * Replace `hGetSomePartial` by `partialiseByteCount`/`partialiseWord64`.
   * Replace `hPutSomePartial` by `partialiseByteString`
   * Replace `corrupt` by `corruptByteString`
+* Remove `System.FS.Sim.Pure` module.
+* Adapt `simHasFS` to the new `HasFS` primitives. This leads to two breaking
+  changes:
+  * Add a `PrimMonad m` constraint to `runSimFS`, `simHasFS'` and `simHasFS`.
+  * Change the `StrictTVar` argument to `simHasFS` to a `StrictTMVar`.
+* Adapt `mkSimErrorHasFS` to the new `HasFS` primitives. This leads to two
+  breaking changes:
+  * Add a `PrimMonad m` constraint to `runSimErrorFS`, `mkSimErrorHasFS'` and `mkSimErrorHasFS`.
+  * Change the `StrictTVar` argument to `mkSimErrorHasFS` to a `StrictTMVar`.
+
+### Non-breaking
+
+* New constructors for the `Errors` type: `hGetBufSomeE`, `hGetBufSomeAtE`,
+  `hGetBufSomeE`, and `hPutBufSomeAtE`.
 
 ### Patch