From 2fa9bf415fc33a7b74dae6860e63511cb180bb79 Mon Sep 17 00:00:00 2001 From: Joris Dral Date: Wed, 6 Mar 2024 11:32:03 +0100 Subject: [PATCH] TOSQUASH --- fs-api/fs-api.cabal | 2 +- fs-api/src-unix/System/FS/IO/Internal.hs | 21 ++++++++-- fs-api/src-win32/System/FS/IO/Internal.hs | 16 ++++++++ fs-api/src/System/FS/API.hs | 21 ++++++++++ fs-api/src/System/FS/IO.hs | 49 ++++++++++++++++------- fs-sim/fs-sim.cabal | 2 +- 6 files changed, 91 insertions(+), 20 deletions(-) diff --git a/fs-api/fs-api.cabal b/fs-api/fs-api.cabal index 5b07daf..0b6dcf4 100644 --- a/fs-api/fs-api.cabal +++ b/fs-api/fs-api.cabal @@ -10,7 +10,7 @@ license-files: copyright: 2019-2023 Input Output Global Inc (IOG) author: IOG Engineering Team -maintainer: operations@iohk.io, Joris Dral +maintainer: operations@iohk.io, Joris Dral (joris@well-typed.com) category: System build-type: Simple extra-doc-files: CHANGELOG.md diff --git a/fs-api/src-unix/System/FS/IO/Internal.hs b/fs-api/src-unix/System/FS/IO/Internal.hs index 5a00ba1..8dc9614 100644 --- a/fs-api/src-unix/System/FS/IO/Internal.hs +++ b/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 () diff --git a/fs-api/src-win32/System/FS/IO/Internal.hs b/fs-api/src-win32/System/FS/IO/Internal.hs index d0e074c..6b0dc1c 100644 --- a/fs-api/src-win32/System/FS/IO/Internal.hs +++ b/fs-api/src-win32/System/FS/IO/Internal.hs @@ -87,6 +87,22 @@ pread fh bytes pos = withOpenHandle "pread" fh $ \h -> _ <- setFilePointerEx h initialOffset fILE_BEGIN return n +preadBuf :: Handle FHandle -> Ptr Word8 -> ByteCount -> FileOffset -> IO ByteCount +preadBuf fh bufptr c off = withOpenHandle "preadBuf" (handleRaw 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 :: Handle FHandle -> Ptr Word8 -> ByteCount -> FileOffset -> IO ByteCount +pwriteBuf fh bufptr c off = withOpenHandle "pwriteBuf" (handleRaw 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 () diff --git a/fs-api/src/System/FS/API.hs b/fs-api/src/System/FS/API.hs index 806c39f..157d33c 100644 --- a/fs-api/src/System/FS/API.hs +++ b/fs-api/src/System/FS/API.hs @@ -17,6 +17,8 @@ module System.FS.API ( , withFile -- * SomeHasFS , SomeHasFS (..) + -- * Buffer filesystem access + , HasBufFS (..) ) where import Control.Monad.Class.MonadThrow @@ -175,3 +177,22 @@ 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 +-------------------------------------------------------------------------------} + +data HasBufFS m h ptr = HasBufFS { + 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 + , hPutBufSomeAt :: HasCallStack + => Handle h + -> ptr Word8 -- ^ Buffer to write bytes into + -> Word64 -- ^ The number of bytes to write + -> AbsOffset -- ^ The file offset at which to write + -> m Word64 + } diff --git a/fs-api/src/System/FS/IO.hs b/fs-api/src/System/FS/IO.hs index 268c697..97deb0d 100644 --- a/fs-api/src/System/FS/IO.hs +++ b/fs-api/src/System/FS/IO.hs @@ -3,6 +3,8 @@ module System.FS.IO ( -- * IO implementation & monad HandleIO , ioHasFS + -- * HasBufFS + , ioHasBufFS ) where import Control.Concurrent.MVar @@ -10,7 +12,7 @@ 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,35 @@ 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 +-- | 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) + } + where + rethrowFsError = _rethrowFsError mount diff --git a/fs-sim/fs-sim.cabal b/fs-sim/fs-sim.cabal index 8448b49..004fd36 100644 --- a/fs-sim/fs-sim.cabal +++ b/fs-sim/fs-sim.cabal @@ -10,7 +10,7 @@ license-files: copyright: 2019-2023 Input Output Global Inc (IOG) author: IOG Engineering Team -maintainer: operations@iohk.io, Joris Dral +maintainer: operations@iohk.io, Joris Dral (joris@well-typed.com) category: Testing build-type: Simple extra-doc-files: CHANGELOG.md