Abstraction for blockio-style file operations

Changes include:
* Add an abstract API that captures the file
operations from `blockio-uring`.
* Implementations of this for three different
operating systems: Linux, MacOS, or Windows. The
Linux implementation uses `blockio-uring` and
benefits from async IO. MacOS and Windows use a
simple implementation that performs file I/O
sequentially instead of in asynchronous batches.
* Implement a basic roundtrip test for the API.

.github/workflows/haskell.yml

@@ -26,8 +26,14 @@ jobs:
         cabal: ["3.10.2.1"]
         os: [ubuntu-latest, windows-latest, macOS-latest]
         exclude:
-          - os: windows-latest
-          - os: macOS-latest
+          - ghc: "9.4.8"
+            os: windows-latest
+          - ghc: "9.4.8"
+            os: macOS-latest
+          - ghc: "9.8.1"
+            os: windows-latest
+          - ghc: "9.8.1"
+            os: macOS-latest
 
     steps:
     - name: Checkout repository

README.md

@@ -16,4 +16,6 @@ It has a number of custom features that are primarily tailored towards performan
 
 ## System requirements
 
-This library only supports 64-bit, little-endian systems.
+This library only supports 64-bit, little-endian systems.
+
+Use -threaded if you depend on this library in Linux

cabal.project

@@ -34,7 +34,8 @@ source-repository-package
 -- Luckily, bloomfilter is not commonly used package, so this is good enough.
 constraints: bloomfilter <0
 
-source-repository-package
-  type: git
-  location: https://github.com/well-typed/blockio-uring
-  tag: bdac50eb4155ea3096b1db9b828307f4fd19ddb3
+if(os(linux))
+  source-repository-package
+    type: git
+    location: https://github.com/well-typed/blockio-uring
+    tag: bdac50eb4155ea3096b1db9b828307f4fd19ddb3

fs-api-blockio/src-linux/System/FS/BlockIO/Internal.hs

@@ -0,0 +1,36 @@
+module System.FS.BlockIO.Internal (
+    I.IOCtx
+  , I.IOCtxParams (..)
+  , I.defaultIOCtxParams
+  , I.initIOCtx
+  , I.closeIOCtx
+  , submitIO
+  ) where
+
+import           System.FS.API (Handle (..))
+import           System.FS.BlockIO.API (IOOp (..), IOResult (..))
+import           System.FS.IO.Internal
+import           System.FS.IO.Internal.Handle
+import qualified System.IO.BlockIO as I
+import           System.Posix.Types
+
+submitIO :: I.IOCtx -> [IOOp FHandle] -> IO [IOResult]
+submitIO ioctx ioops = do
+  ioops' <- mapM fIOOp ioops
+  fmap fIOResult <$> I.submitIO ioctx ioops'
+
+fIOOp :: IOOp FHandle -> IO I.IOOp
+fIOOp (IOOpRead  h off bufptr c) = handleFD h >>= \fd -> pure (I.IOOpRead  fd off bufptr c)
+fIOOp (IOOpWrite h off bufptr c) = handleFD h >>= \fd -> pure (I.IOOpWrite fd off bufptr c)
+
+-- TODO: complete pragma
+fIOResult :: I.IOResult -> IOResult
+fIOResult (I.IOResult c) = IOResult c
+fIOResult (I.IOError  e) = IOError  e
+fIOResult _              = error "mapIOResult: missing incomplete pragma"
+
+-- This only checks whether the handle is open when we convert to an Fd. After
+-- that, the handle could be closed when we're still performing blockio
+-- operations.
+handleFD :: Handle FHandle -> IO Fd
+handleFD h = withOpenHandle "submitIO" (handleRaw h) pure

fs-api-blockio/src-macos/System/FS/BlockIO/Internal.hs

@@ -0,0 +1,49 @@
+module System.FS.BlockIO.Internal (
+    IOCtx
+  , IOCtxParams (..)
+  , defaultIOCtxParams
+  , initIOCtx
+  , closeIOCtx
+  , submitIO
+  ) where
+
+import           Data.Word
+import           Foreign.Ptr
+import           System.FS.API
+import           System.FS.BlockIO.API (ByteCount, FileOffset, IOOp (..),
+                     IOResult (IOResult_))
+import           System.FS.IO.Internal
+import           System.FS.IO.Internal.Handle
+import           System.Posix.IO.ByteString.Ext
+
+-- TODO: use something like an MVar to keep track of open/closed state
+data IOCtx = IOCtx
+
+data IOCtxParams = IOCtxParams
+
+defaultIOCtxParams :: IOCtxParams
+defaultIOCtxParams = IOCtxParams
+
+initIOCtx :: IOCtxParams -> IO IOCtx
+initIOCtx IOCtxParams = pure IOCtx
+
+closeIOCtx :: IOCtx -> IO ()
+closeIOCtx IOCtx = pure ()
+
+submitIO :: IOCtx -> [IOOp FHandle] -> IO [IOResult]
+submitIO IOCtx = mapM fIOOp
+
+-- TODO: catch exceptions and rethrow them as IOResult_
+fIOOp :: IOOp FHandle -> IO IOResult
+fIOOp (IOOpRead h off bufptr c) =
+    preadBuf h bufptr c off >>= \c' -> pure (IOResult_ $ fromIntegral c')
+fIOOp (IOOpWrite h off bufptr c) =
+    pwriteBuf h bufptr c off >>= \c' -> pure (IOResult_ $ fromIntegral c')
+
+-- TODO: possibly upstream to fs-api
+preadBuf :: Handle FHandle -> Ptr Word8 -> ByteCount -> FileOffset -> IO ByteCount
+preadBuf fh bufptr c off = withOpenHandle "preadBuf" (handleRaw fh) $ \h -> fdPreadBuf h bufptr c off
+
+-- TODO: possibly upstream to fs-api
+pwriteBuf :: Handle FHandle -> Ptr Word8 -> ByteCount -> FileOffset -> IO ByteCount
+pwriteBuf fh bufptr c off = withOpenHandle "pwriteBuf" (handleRaw fh) $ \h -> fdPwriteBuf h bufptr c off

fs-api-blockio/src-windows/System/FS/BlockIO/Internal.hs

@@ -0,0 +1,66 @@
+-- TODO: unify with the implementation for MacOS, since the implementation is
+-- the same except for 'preadBuf' and 'pwriteBuf'.
+module System.FS.BlockIO.Internal (
+    IOCtx
+  , IOCtxParams (..)
+  , defaultIOCtxParams
+  , initIOCtx
+  , closeIOCtx
+  , submitIO
+  ) where
+
+import           Data.Int
+import           Data.Word
+import           Foreign.Ptr
+import           System.FS.API
+import           System.FS.BlockIO.API (ByteCount, FileOffset, IOOp (..),
+                     IOResult (IOResult_))
+import           System.FS.IO.Internal
+import           System.FS.IO.Internal.Handle
+import           System.Win32
+
+-- TODO: use something like an MVar to keep track of open/closed state
+data IOCtx = IOCtx
+
+data IOCtxParams = IOCtxParams
+
+defaultIOCtxParams :: IOCtxParams
+defaultIOCtxParams = IOCtxParams
+
+initIOCtx :: IOCtxParams -> IO IOCtx
+initIOCtx IOCtxParams = pure IOCtx
+
+closeIOCtx :: IOCtx -> IO ()
+closeIOCtx IOCtx = pure ()
+
+submitIO :: IOCtx -> [IOOp FHandle] -> IO [IOResult]
+submitIO IOCtx = mapM fIOOp
+
+-- TODO: catch exceptions and rethrow them as IOResult_
+fIOOp :: IOOp FHandle -> IO IOResult
+fIOOp (IOOpRead h off bufptr c) =
+    preadBuf h bufptr c off >>= \c' -> pure (IOResult_ $ fromIntegral c')
+fIOOp (IOOpWrite h off bufptr c) =
+    pwriteBuf h bufptr c off >>= \c' -> pure (IOResult_ $ fromIntegral c')
+
+-- TODO: copied from fs-api
+getCurrentFileOffset :: HANDLE -> IO Int64
+getCurrentFileOffset h = setFilePointerEx h 0 fILE_CURRENT
+
+-- TODO: possibly upstream to fs-api
+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
+
+-- TODO: possibly upstream to fs-api
+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

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

@@ -0,0 +1,66 @@
+{-# LANGUAGE GADTs           #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ViewPatterns    #-}
+
+module System.FS.BlockIO.API (
+    SomeHasBlockIO (..)
+  , HasBlockIO (..)
+  , IOOp (..)
+  , IOResult (IOResult, IOError)
+  , ByteCount
+  , FileOffset
+  , Errno (..)
+    -- Internal
+  , pattern IOResult_
+  ) where
+
+import           Data.Word
+import           Foreign.C
+import           Foreign.Ptr
+import           System.FS.API
+import           System.Posix.Types
+
+data SomeHasBlockIO m where
+  SomeHasBlockIO ::
+       Eq h
+    => HasFS m h
+    -> HasBlockIO m h ioctxparams ioctx
+    -> SomeHasBlockIO m
+
+-- TODO: see if we can get away with monomorphising @ioctxparams@
+--
+-- TODO: make this compatible with fs-sim simulation
+data HasBlockIO m h ioctxparams ioctx = HasBlockIO {
+    defaultIOCtxParams :: ioctxparams
+  , initIOCtx          :: ioctxparams -> m ioctx
+  , closeIOCtx         :: ioctx -> m ()
+  , submitIO           :: ioctx -> [IOOp h] -> m [IOResult]
+  }
+
+data IOOp h = IOOpRead  !(Handle h) !FileOffset !(Ptr Word8) !ByteCount
+            | IOOpWrite !(Handle h) !FileOffset !(Ptr Word8) !ByteCount
+  deriving Show
+
+newtype IOResult = IOResult_ CInt
+
+{-# COMPLETE IOResult, IOError #-}
+
+pattern IOResult :: ByteCount -> IOResult
+pattern IOResult c <- (viewIOResult -> Just c)
+  where
+    IOResult count = IOResult_ ((fromIntegral :: CSize -> CInt) count)
+
+pattern IOError :: Errno -> IOResult
+pattern IOError e <- (viewIOError -> Just e)
+  where
+    IOError (Errno e) = IOResult_ (-e)
+
+viewIOResult :: IOResult -> Maybe ByteCount
+viewIOResult (IOResult_ c)
+  | c >= 0    = Just ((fromIntegral :: CInt -> CSize) c)
+  | otherwise = Nothing
+
+viewIOError  :: IOResult -> Maybe Errno
+viewIOError (IOResult_ e)
+  | e < 0     = Just (Errno e)
+  | otherwise = Nothing

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

@@ -0,0 +1,17 @@
+module System.FS.BlockIO.IO (
+    ioHasBlockIO
+  , I.IOCtx
+  , I.IOCtxParams (..)
+  ) where
+
+import           System.FS.BlockIO.API
+import qualified System.FS.BlockIO.Internal as I
+import           System.FS.IO
+
+ioHasBlockIO :: HasBlockIO IO HandleIO I.IOCtxParams I.IOCtx
+ioHasBlockIO = HasBlockIO {
+      defaultIOCtxParams = I.defaultIOCtxParams
+    , initIOCtx          = I.initIOCtx
+    , closeIOCtx         = I.closeIOCtx
+    , submitIO           = I.submitIO
+    }

fs-api-blockio/test/Main.hs

@@ -0,0 +1,59 @@
+{-# LANGUAGE BangPatterns #-}
+
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+{- HLINT ignore "Use camelCase" -}
+
+module Main (main) where
+
+import           Data.ByteString
+import qualified Data.ByteString as BS
+import           Data.ByteString.Unsafe as BSU
+import           Foreign (castPtr)
+import qualified System.FS.API as FS
+import           System.FS.BlockIO.API
+import qualified System.FS.BlockIO.IO as IO
+import qualified System.FS.IO as IO
+import           System.IO.Temp
+import           Test.Tasty
+import           Test.Tasty.HUnit
+import           Test.Tasty.QuickCheck
+
+main :: IO ()
+main = defaultMain tests
+
+tests :: TestTree
+tests = testGroup "fs-api-blockio" [
+      testCase "example_initClose" example_initClose
+    , testProperty "prop_readWrite" prop_readWrite
+    ]
+
+instance Arbitrary ByteString where
+  arbitrary = BS.pack <$> arbitrary
+  shrink = fmap BS.pack . shrink .  BS.unpack
+
+example_initClose :: Assertion
+example_initClose = do
+    let !hbio = IO.ioHasBlockIO
+    ctx <- initIOCtx hbio (defaultIOCtxParams hbio)
+    closeIOCtx hbio ctx
+
+prop_readWrite :: ByteString -> Property
+prop_readWrite bs = ioProperty $ withSystemTempDirectory "prop_readWrite" $ \dirPath -> do
+    let hfs  = IO.ioHasFS (FS.MountPoint dirPath)
+        hbio = IO.ioHasBlockIO
+        !bsCopy = BS.copy bs
+    ctx <- initIOCtx hbio (defaultIOCtxParams hbio)
+    prop <- FS.withFile hfs (FS.mkFsPath ["temp"]) (FS.WriteMode FS.MustBeNew) $ \h -> do
+      BSU.unsafeUseAsCStringLen bs $ \(ptr, n) -> do
+        [writeRes] <- submitIO hbio ctx [IOOpWrite h 0 (castPtr ptr) (fromIntegral n)]
+        let writeTest = case writeRes of
+              IOError e  -> counterexample (show e) (property False)
+              IOResult m -> n === fromIntegral m
+        [readRes] <- submitIO hbio ctx [IOOpRead h 0 (castPtr ptr) (fromIntegral n)]
+        let readTest = case readRes of
+              IOError e  -> counterexample (show e) (property False)
+              IOResult m -> n === fromIntegral m
+        pure $ writeTest .&&. readTest
+    closeIOCtx hbio ctx
+    pure (prop .&&. bs === bsCopy)