New hTell function for requesting the current absolute file offset

fs-api/CHANGELOG.md

@@ -1,5 +1,12 @@
 # Revision history for fs-api
 
+## next release -- ????-??-??
+
+### Breaking
+
+* Add `hTell` function to `HasFS`, which returns the absolute file offset that
+  is stored in a file handle.
+
 ## 0.2.0.1 -- 2023-10-30
 
 ### Patch

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

@@ -12,6 +12,7 @@ module System.FS.IO.Internal (
   , read
   , sameError
   , seek
+  , tell
   , truncate
   , write
   ) where
@@ -28,7 +29,7 @@ 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 (Fd (..))
 import           System.Posix.IO.ByteString.Ext (fdPreadBuf)
 
 type FHandle = HandleOS Fd
@@ -123,6 +124,11 @@ seek :: FHandle -> SeekMode -> Int64 -> IO ()
 seek h seekMode offset = withOpenHandle "seek" h $ \fd ->
     void $ Posix.fdSeek fd seekMode (fromIntegral offset)
 
+-- | Request the absolute file offset stored in the handle
+tell :: FHandle -> IO Word64
+tell h = withOpenHandle "tell" h $ \fd ->
+    fromIntegral <$> Posix.fdSeek fd RelativeSeek 0
+
 -- | Reads a given number of bytes from the input 'FHandle'.
 read :: FHandle -> Word64 -> IO ByteString
 read h bytes = withOpenHandle "read" h $ \fd ->

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

@@ -11,6 +11,7 @@ module System.FS.IO.Internal (
   , read
   , sameError
   , seek
+  , tell
   , truncate
   , write
   ) where
@@ -65,6 +66,10 @@ seek :: FHandle -> SeekMode -> Int64 -> IO ()
 seek fh seekMode size = void <$> withOpenHandle "seek" fh $ \h ->
   setFilePointerEx h size (fromSeekMode seekMode)
 
+-- | Request the absolute file offset stored in the handle
+tell :: FHandle -> IO Word64
+tell h = withOpenHandle "tell" h $ fmap fromIntegral . getCurrentFileOffset
+
 fromSeekMode :: SeekMode -> FilePtrDirection
 fromSeekMode AbsoluteSeek = fILE_BEGIN
 fromSeekMode RelativeSeek = fILE_CURRENT

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

@@ -58,6 +58,16 @@ data HasFS m h = HasFS {
     -- and we don't want to emulate it's behaviour.
   , hSeek                    :: HasCallStack => Handle h -> SeekMode -> Int64 -> m ()
 
+    -- | Return the current absolute offset into the file
+    --
+    -- NOTE: may provide different answers on Windows than on Unix-based systems
+    -- in two cases, (1) when opening a existing file in append-only mode, or
+    -- (2) right after a file has been truncated. It seems that on Windows
+    -- systems, the offset is immediately up-to-date, whereas on Unix-based
+    -- systems the file offset may not be updated until you start writing >0
+    -- bytes to the file handle.
+  , hTell                    :: HasCallStack => Handle h -> m AbsOffset
+
     -- | Try to read @n@ bytes from a handle
     --
     -- When at the end of the file, an empty bytestring will be returned.

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

@@ -50,6 +50,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 (castPtr ptr) (fromIntegral len)

fs-sim/CHANGELOG.md

@@ -1,5 +1,22 @@
 # Revision history for fs-sim
 
+## next release -- ????-??-??
+
+### Breaking
+
+* Add simulation implementations (`pureHasFS`, `simHasFS` and `mkSimErrorHasFS`)
+  for the new `hTell` function in the `HasFS` interface. The simulation has two
+  known limitations regarding `hTell` because of differing behaviour between
+  Windows and Unix-based systems.
+* Add an error stream to `Errors` for `hTell`.
+
+### Patch
+
+* `allNull` was not actually checking whether all streams in the argument
+  `Errors` are empty.
+* The `Show Errors` instance was not printing every stream.
+* The shrinker for `Errors` was not shrinking every stream.
+
 ## 0.2.1.1 -- 2023-10-30
 
 ### Patch

fs-sim/fs-sim.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:        Testing
 build-type:      Simple
 extra-doc-files: CHANGELOG.md

fs-sim/src/System/FS/Sim/Error.hs

@@ -211,6 +211,7 @@ data Errors = Errors
   , hOpenE                    :: ErrorStream
   , hCloseE                   :: ErrorStream
   , hSeekE                    :: ErrorStream
+  , hTellE                    :: ErrorStream
   , hGetSomeE                 :: ErrorStreamGetSome
   , hGetSomeAtE               :: ErrorStreamGetSome
   , hPutSomeE                 :: ErrorStreamPutSome
@@ -230,28 +231,74 @@ data Errors = Errors
 
 -- | Return 'True' if all streams are empty ('null').
 allNull :: Errors -> Bool
-allNull Errors {..} = Stream.null dumpStateE
-                   && Stream.null hOpenE
-                   && Stream.null hCloseE
-                   && Stream.null hSeekE
-                   && Stream.null hGetSomeE
-                   && Stream.null hGetSomeAtE
-                   && Stream.null hPutSomeE
-                   && Stream.null hTruncateE
-                   && Stream.null hGetSizeE
-                   && Stream.null createDirectoryE
-                   && Stream.null createDirectoryIfMissingE
-                   && Stream.null listDirectoryE
-                   && Stream.null doesDirectoryExistE
-                   && Stream.null doesFileExistE
-                   && Stream.null removeFileE
-                   && Stream.null renameFileE
-
+allNull errs =
+       Stream.null dumpStateE
+    && Stream.null hOpenE
+    && Stream.null hCloseE
+    && Stream.null hSeekE
+    && Stream.null hTellE
+    && Stream.null hGetSomeE
+    && Stream.null hGetSomeAtE
+    && Stream.null hPutSomeE
+    && Stream.null hTruncateE
+    && Stream.null hGetSizeE
+    && Stream.null createDirectoryE
+    && Stream.null createDirectoryIfMissingE
+    && Stream.null listDirectoryE
+    && Stream.null doesDirectoryExistE
+    && Stream.null doesFileExistE
+    && Stream.null removeDirectoryRecursiveE
+    && Stream.null removeFileE
+    && Stream.null renameFileE
+  where
+      -- a (non-record) pattern match ensures that we are not missing any fields
+    Errors
+      dumpStateE
+      hOpenE
+      hCloseE
+      hSeekE
+      hTellE
+      hGetSomeE
+      hGetSomeAtE
+      hPutSomeE
+      hTruncateE
+      hGetSizeE
+      createDirectoryE
+      createDirectoryIfMissingE
+      listDirectoryE
+      doesDirectoryExistE
+      doesFileExistE
+      removeDirectoryRecursiveE
+      removeFileE
+      renameFileE
+      = errs
 
 instance Show Errors where
-  show Errors {..} =
+  show errs =
       "Errors {"  <> intercalate ", " streams <> "}"
     where
+      -- a (non-record) pattern match ensures that we are not missing any fields
+      Errors
+        dumpStateE
+        hOpenE
+        hCloseE
+        hSeekE
+        hTellE
+        hGetSomeE
+        hGetSomeAtE
+        hPutSomeE
+        hTruncateE
+        hGetSizeE
+        createDirectoryE
+        createDirectoryIfMissingE
+        listDirectoryE
+        doesDirectoryExistE
+        doesFileExistE
+        removeDirectoryRecursiveE
+        removeFileE
+        renameFileE
+        = errs
+
       -- | Show a stream unless it is empty
       s :: Show a => String -> Stream a -> Maybe String
       s fld str | Stream.null str = Nothing
@@ -263,6 +310,7 @@ instance Show Errors where
         , s "hOpenE"                    hOpenE
         , s "hCloseE"                   hCloseE
         , s "hSeekE"                    hSeekE
+        , s "hTellE"                    hTellE
         , s "hGetSomeE"                 hGetSomeE
         , s "hGetSomeAtE"               hGetSomeAtE
         , s "hPutSomeE"                 hPutSomeE
@@ -273,6 +321,7 @@ instance Show Errors where
         , s "listDirectoryE"            listDirectoryE
         , s "doesDirectoryExistE"       doesDirectoryExistE
         , s "doesFileExistE"            doesFileExistE
+        , s "removeDirectyRecursiveE"   removeDirectoryRecursiveE
         , s "removeFileE"               removeFileE
         , s "renameFileE"               renameFileE
         ]
@@ -288,6 +337,7 @@ simpleErrors es = Errors
     , hOpenE                    = es
     , hCloseE                   = es
     , hSeekE                    = es
+    , hTellE                    = es
     , hGetSomeE                 =  Left                <$> es
     , hGetSomeAtE               =  Left                <$> es
     , hPutSomeE                 = (Left . (, Nothing)) <$> es
@@ -327,6 +377,7 @@ genErrors genPartialWrites genSubstituteWithJunk = do
       , FsResourceAlreadyInUse, FsResourceAlreadyExist
       , FsInsufficientPermissions, FsTooManyOpenFiles ]
     hSeekE      <- streamGen 3 [ FsReachedEOF ]
+    hTellE      <- streamGen 3 [ FsIllegalOperation ]
     hGetSomeE   <- streamGen' 20
       [ (1, return $ Left FsReachedEOF)
       , (3, Right <$> arbitrary) ]
@@ -365,11 +416,12 @@ genErrors genPartialWrites genSubstituteWithJunk = do
 instance Arbitrary Errors where
   arbitrary = genErrors True True
 
-  shrink err@Errors {..} = filter (not . allNull) $ concat
+  shrink err = filter (not . allNull) $ concat
       [ (\s' -> err { dumpStateE = s' })                <$> Stream.shrinkStream dumpStateE
       , (\s' -> err { hOpenE = s' })                    <$> Stream.shrinkStream hOpenE
       , (\s' -> err { hCloseE = s' })                   <$> Stream.shrinkStream hCloseE
       , (\s' -> err { hSeekE = s' })                    <$> Stream.shrinkStream hSeekE
+      , (\s' -> err { hTellE = s' })                    <$> Stream.shrinkStream hTellE
       , (\s' -> err { hGetSomeE = s' })                 <$> Stream.shrinkStream hGetSomeE
       , (\s' -> err { hGetSomeAtE = s' })               <$> Stream.shrinkStream hGetSomeAtE
       , (\s' -> err { hPutSomeE = s' })                 <$> Stream.shrinkStream hPutSomeE
@@ -380,9 +432,32 @@ instance Arbitrary Errors where
       , (\s' -> err { listDirectoryE = s' })            <$> Stream.shrinkStream listDirectoryE
       , (\s' -> err { doesDirectoryExistE = s' })       <$> Stream.shrinkStream doesDirectoryExistE
       , (\s' -> err { doesFileExistE = s' })            <$> Stream.shrinkStream doesFileExistE
+      , (\s' -> err { removeDirectoryRecursiveE = s' }) <$> Stream.shrinkStream removeDirectoryRecursiveE
       , (\s' -> err { removeFileE = s' })               <$> Stream.shrinkStream removeFileE
       , (\s' -> err { renameFileE = s' })               <$> Stream.shrinkStream renameFileE
       ]
+    where
+      -- a (non-record) pattern match ensures that we are not missing any fields
+      Errors
+        dumpStateE
+        hOpenE
+        hCloseE
+        hSeekE
+        hTellE
+        hGetSomeE
+        hGetSomeAtE
+        hPutSomeE
+        hTruncateE
+        hGetSizeE
+        createDirectoryE
+        createDirectoryIfMissingE
+        listDirectoryE
+        doesDirectoryExistE
+        doesFileExistE
+        removeDirectoryRecursiveE
+        removeFileE
+        renameFileE
+        = err
 
 {-------------------------------------------------------------------------------
   Simulate Errors monad
@@ -419,6 +494,9 @@ mkSimErrorHasFS fsVar errorsVar =
         , hSeek      = \h m n ->
             withErr' errorsVar h (hSeek h m n) "hSeek"
             hSeekE (\e es -> es { hSeekE = e })
+        , hTell      = \h ->
+            withErr' errorsVar h (hTell h) "hTell"
+            hTellE (\e es -> es { hTellE = e })
         , hGetSome   = hGetSome' errorsVar hGetSome
         , hGetSomeAt = hGetSomeAt' errorsVar hGetSomeAt
         , hPutSome   = hPutSome' errorsVar hPutSome
@@ -537,8 +615,7 @@ withErr' :: (MonadSTM m, MonadThrow m, HasCallStack)
          -> (Errors -> ErrorStream)           -- ^ @getter@
          -> (ErrorStream -> Errors -> Errors) -- ^ @setter@
          -> m a
-withErr' errorsVar handle action msg getter setter =
-    withErr errorsVar (handlePath handle) action msg getter setter
+withErr' errorsVar handle = withErr errorsVar (handlePath handle)
 
 -- | Execute the wrapped 'hGetSome', throw an error, or simulate a partial
 -- read, depending on the corresponding 'ErrorStreamGetSome' (see