blockio: refactor and document the IO module

Author: jorisdral

bench/macro/lsm-tree-bench-lookups.hs

@@ -307,11 +307,10 @@ totalNumEntriesSanityCheck l1 runSizes =
 withFS ::
      (FS.HasFS IO FS.HandleIO -> FS.HasBlockIO IO FS.HandleIO -> IO a)
   -> IO a
-withFS action = do
-    let hfs = FS.ioHasFS (FS.MountPoint "_bench_lookups")
-    exists <- FS.doesDirectoryExist hfs (FS.mkFsPath [""])
-    unless exists $ error ("_bench_lookups directory does not exist")
-    FS.withIOHasBlockIO hfs FS.defaultIOCtxParams $ \hbio ->
+withFS action =
+    FS.withIOHasBlockIO (FS.MountPoint "_bench_lookups") FS.defaultIOCtxParams $ \hfs hbio -> do
+      exists <- FS.doesDirectoryExist hfs (FS.mkFsPath [""])
+      unless exists $ error ("_bench_lookups directory does not exist")
       action hfs hbio
 
 -- | Input environment for benchmarking lookup functions.

bench/macro/lsm-tree-bench-wp8.hs

@@ -62,9 +62,6 @@ import qualified MCG
 import qualified Options.Applicative as O
 import           Prelude hiding (lookup)
 import qualified System.Clock as Clock
-import qualified System.FS.API as FS
-import qualified System.FS.BlockIO.IO as FsIO
-import qualified System.FS.IO as FsIO
 import           System.IO
 import           System.Mem (performMajorGC)
 import qualified System.Random as Random
@@ -402,17 +399,8 @@ doSetup gopts opts = do
 
 doSetup' :: GlobalOpts -> SetupOpts -> IO ()
 doSetup' gopts opts = do
-    let mountPoint :: FS.MountPoint
-        mountPoint = FS.MountPoint (rootDir gopts)
-
-    let hasFS :: FS.HasFS IO FsIO.HandleIO
-        hasFS = FsIO.ioHasFS mountPoint
-
-    hasBlockIO <- FsIO.ioHasBlockIO hasFS FsIO.defaultIOCtxParams
-
     let name = LSM.toSnapshotName "bench"
-
-    LSM.withSession (mkTracer gopts) hasFS hasBlockIO (FS.mkFsPath []) $ \session -> do
+    LSM.withSessionIO (mkTracer gopts) (rootDir gopts) $ \session -> do
         tbl <- LSM.newTableWith @IO @K @V @B (mkTableConfigSetup gopts opts benchTableConfig) session
 
         forM_ (groupsOfN 256 [ 0 .. initialSize gopts ]) $ \batch -> do
@@ -564,17 +552,9 @@ toOperations lookups inserts = (batch1, batch2)
 
 doRun :: GlobalOpts -> RunOpts -> IO ()
 doRun gopts opts = do
-    let mountPoint :: FS.MountPoint
-        mountPoint = FS.MountPoint (rootDir gopts)
-
-    let hasFS :: FS.HasFS IO FsIO.HandleIO
-        hasFS = FsIO.ioHasFS mountPoint
-
-    hasBlockIO <- FsIO.ioHasBlockIO hasFS FsIO.defaultIOCtxParams
-
     let name = LSM.toSnapshotName "bench"
 
-    LSM.withSession (mkTracer gopts) hasFS hasBlockIO (FS.mkFsPath []) $ \session ->
+    LSM.withSessionIO (mkTracer gopts) (rootDir gopts) $ \session ->
       withLatencyHandle $ \h -> do
         -- open snapshot
         -- In checking mode we start with an empty table, since our pure

bench/micro/Bench/Database/LSMTree.hs

@@ -429,8 +429,7 @@ mkFiles ::
 mkFiles = do
     sysTmpDir <- getCanonicalTemporaryDirectory
     benchTmpDir <- createTempDirectory sysTmpDir "full"
-    let hfs = FS.ioHasFS (FS.MountPoint benchTmpDir)
-    hbio <- FS.ioHasBlockIO hfs FS.defaultIOCtxParams
+    (hfs, hbio) <- FS.ioHasBlockIO (FS.MountPoint benchTmpDir) FS.defaultIOCtxParams
     pure (benchTmpDir, hfs, hbio)
 
 cleanupFiles ::

bench/micro/Bench/Database/LSMTree/Internal/Lookup.hs

@@ -187,8 +187,7 @@ lookupsInBatchesEnv Config {..} = do
     sysTmpDir <- getCanonicalTemporaryDirectory
     benchTmpDir <- createTempDirectory sysTmpDir "lookupsInBatchesEnv"
     (storedKeys, lookupKeys) <- lookupsEnv (mkStdGen 17) nentries npos nneg
-    let hasFS = FS.ioHasFS (FS.MountPoint benchTmpDir)
-    hasBlockIO <- FS.ioHasBlockIO hasFS (fromMaybe FS.defaultIOCtxParams ioctxps)
+    (hasFS, hasBlockIO) <- FS.ioHasBlockIO (FS.MountPoint benchTmpDir) (fromMaybe FS.defaultIOCtxParams ioctxps)
     wbblobs <- WBB.new hasFS (FS.mkFsPath ["0.wbblobs"])
     wb <- WB.fromMap <$> traverse (traverse (WBB.addBlob hasFS wbblobs)) storedKeys
     let fsps = RunFsPaths (FS.mkFsPath []) (RunNumber 0)

bench/micro/Bench/Database/LSMTree/Internal/Merge.hs

@@ -369,8 +369,7 @@ mergeEnv ::
 mergeEnv config = do
     sysTmpDir <- getCanonicalTemporaryDirectory
     benchTmpDir <- createTempDirectory sysTmpDir "mergeEnv"
-    let hasFS = FS.ioHasFS (FS.MountPoint benchTmpDir)
-    hasBlockIO <- FS.ioHasBlockIO hasFS FS.defaultIOCtxParams
+    (hasFS, hasBlockIO) <- FS.ioHasBlockIO (FS.MountPoint benchTmpDir) FS.defaultIOCtxParams
     runs <- randomRuns hasFS hasBlockIO config (mkStdGen 17)
     pure (benchTmpDir, hasFS, hasBlockIO, runs)
 

blockio/src/System/FS/BlockIO/IO.hs

@@ -1,28 +1,174 @@
+-- | Implementations using the real file system.
+--
+-- The implementation of the 'HasBlockIO' interface provided in this module is
+-- platform-dependent. Most importantly, on Linux, the implementation of
+-- 'submitIO' is backed by @blockio-uring@: a library for asynchronous I/O. On
+-- Windows and MacOS, the implementation of 'submitIO' only supports serial I/O.
 module System.FS.BlockIO.IO (
+    -- * Implementation details #impl#
+    -- $impl
+
+    -- * Initialisation
     ioHasBlockIO
   , withIOHasBlockIO
+    -- ** Parameters
   , IOI.IOCtxParams (..)
   , IOI.defaultIOCtxParams
+    -- ** Unsafe
+  , unsafeFromHasFS
+  , withUnsafeFromHasFS
   ) where
 
 import           Control.Exception (bracket)
-import           System.FS.API (HasFS)
+import           System.FS.API (HasFS, MountPoint)
 import           System.FS.BlockIO.API (HasBlockIO (..))
 import qualified System.FS.BlockIO.Internal as I
 import qualified System.FS.BlockIO.IO.Internal as IOI
-import           System.FS.IO (HandleIO)
+import           System.FS.IO (HandleIO, ioHasFS)
 
--- | Platform-dependent IO instantiation of 'HasBlockIO'.
-ioHasBlockIO ::
+{- $impl
+
+  Though the 'HasBlockIO' interface tries to capture uniform behaviour, each
+  function in this implementation for the real file system can have subtly
+  different effects depending on the underlying patform. For example, some
+  features are not provided by some operating systems, and in some cases the
+  features behave subtly differently for different operating systems. For this
+  reason, we include below some documentation about the effects of calling the
+  interface functions on different platforms.
+
+  Note: if the @serialblockio@ Cabal flag is enabled, then the Linux implementation
+  uses a mocked context and serial I/O for 'close' and 'submitIO', just like the
+  MacOS and Windows implementations do.
+
+  [IO context]:  When an instance of the 'HasBlockIO' interface for Linux
+    systems is initialised, an @io_uring@ context is created using the
+    @blockio-uring@ package and stored in the 'HasBlockIO' closure. For uniform
+    behaviour, each other platform creates and stores a mocked IO context that
+    has the same open/closed behaviour as an @io_uring@ context. In summary,
+    each platform creates:
+
+    * Linux: an @io_uring@ context provided by the @blockio-uring@ package
+    * MacOS: a mocked context using an @MVar@
+    * Windows: a mocked conext using an @MVar@
+
+  ['close']:
+
+    * Linux: close the @io_uring@ context through the @blockio-uring@ package
+    * MacOS: close the mocked context
+    * Windows: close the mocked context
+
+  ['submitIO']: Submit a batch of I/O operations using:
+
+    * Linux: the @submitIO@ function from the @blockio-uring@ package
+    * MacOS: serial I/O using a 'HasFS'
+    * Windows: serial I/O using a 'HasFS'
+
+  ['hSetNoCache']:
+
+    * Linux: set the @O_DIRECT@ flag
+    * MacOS: set the @F_NOCACHE@ flag
+    * Windows: no-op
+
+  ['hAdvise']:
+
+    * Linux: perform @posix_fadvise(2)@
+    * MacOS: no-op
+    * Windows: no-op
+
+  ['hAllocate']:
+
+    * Linux: perform @posix_fallocate(2)@
+    * MacOS: no-op
+    * Windows: no-op
+
+  ['tryLockFile']: This uses different locking methods depending on the OS.
+
+    * Linux: Open file descriptor (OFD)
+    * MacOS: @flock@
+    * Windows: @LockFileEx@
+
+  ['hSynchronise']:
+
+    * Linux: perform @fsync(2)@
+    * MacOS: perform @fsync(2)@
+    * Windows: perform @flushFileBuffers@
+
+  ['synchroniseDirectory']:
+
+    * Linux: perform @fsync(2)@
+    * MacOS: perform @fsync(2)@
+    * Windows: no-op
+
+  ['createHardLink']:
+
+    * Linux: perform @link@
+    * MacOS: perform @link@
+    * Windows: perform @CreateHardLinkW@
+-}
+
+-- | An implementation of the 'HasBlockIO' interface using the real file system.
+--
+-- Make sure to use 'close' the resulting 'HasBlockIO' when it is no longer
+-- used. 'withUnsafeFromHasFS' does this automatically.
+--
+-- === Unsafe
+--
+-- You will probably want to use 'ioHasBlockIO' or 'withIOHasBlockIO' instead.
+--
+-- Only a 'HasFS' for the real file system, like 'ioHasFS', should be passed to
+-- 'unsafeFromHasFS'. Technically, one could pass a 'HasFS' for a simulated file
+-- system, but then the resulting 'HasBlockIO' would contain a mix of simulated
+-- and real functions, which is probably not what you want.
+unsafeFromHasFS ::
      HasFS IO HandleIO
   -> IOI.IOCtxParams
   -> IO (HasBlockIO IO HandleIO)
-ioHasBlockIO = I.ioHasBlockIO
+unsafeFromHasFS = I.ioHasBlockIO
 
-withIOHasBlockIO ::
+-- | Perform an action using a 'HasBlockIO' instance that is only open for the
+-- duration of the action.
+--
+-- The 'HasBlockIO' is initialised using 'unsafeFromHasFS'.
+--
+-- === Unsafe
+--
+-- You will probably want to use 'ioHasBlockIO' or 'withIOHasBlockIO' instead.
+--
+-- Only a 'HasFS' for the real file system, like 'ioHasFS', should be passed to
+-- 'withUnsafeFromHasFS'. Technically, one could pass a 'HasFS' for a simulated
+-- file system, but then the resulting 'HasBlockIO' would contain a mix of
+-- simulated and real functions, which is probably not what you want.
+withUnsafeFromHasFS ::
      HasFS IO HandleIO
   -> IOI.IOCtxParams
   -> (HasBlockIO IO HandleIO -> IO a)
   -> IO a
-withIOHasBlockIO hfs params action =
-    bracket (ioHasBlockIO hfs params) (\HasBlockIO{close} -> close) action
+withUnsafeFromHasFS hfs params =
+    bracket (unsafeFromHasFS hfs params) (\HasBlockIO{close} -> close)
+
+-- | An implementation of the 'HasBlockIO' interface using the real file system.
+--
+-- Make sure to use 'close' the resulting 'HasBlockIO' when it is no longer
+-- used. 'withIOHasBlockIO' does this automatically.
+--
+-- The 'HasFS' interface is instantiated using 'ioHasFS'.
+ioHasBlockIO ::
+     MountPoint
+  -> IOI.IOCtxParams
+  -> IO (HasFS IO HandleIO, HasBlockIO IO HandleIO)
+ioHasBlockIO mount params = do
+    let hfs = ioHasFS mount
+    hbio <- unsafeFromHasFS hfs params
+    pure (hfs, hbio)
+
+-- | Perform an action using a 'HasFS' and a 'HasBlockIO' instance. The latter
+-- is only open for the duration of the action.
+--
+-- The 'HasFS' and 'HasBlockIO' interfaces are initialised using 'ioHasBlockIO'.
+withIOHasBlockIO ::
+     MountPoint
+  -> IOI.IOCtxParams
+  -> (HasFS IO HandleIO -> HasBlockIO IO HandleIO -> IO a)
+  -> IO a
+withIOHasBlockIO mount params action =
+    bracket (ioHasBlockIO mount params) (\(_, HasBlockIO{close}) -> close) (uncurry action)

blockio/test/Main.hs

@@ -24,8 +24,6 @@ import           System.FS.API.Strict (hPutAllStrict)
 import qualified System.FS.BlockIO.API as FS
 import           System.FS.BlockIO.API
 import qualified System.FS.BlockIO.IO as IO
-import           System.FS.BlockIO.IO
-import qualified System.FS.IO as IO
 import           System.FS.IO
 import           System.IO.Temp
 import           Test.QuickCheck
@@ -68,15 +66,12 @@ toByteString n mba = do
 example_initClose :: Assertion
 example_initClose = withSystemTempDirectory "example_initClose" $ \dirPath -> do
     let mount = FS.MountPoint dirPath
-        hfs = IO.ioHasFS mount
-    hbio <- IO.ioHasBlockIO hfs IO.defaultIOCtxParams
-    close hbio
+    IO.withIOHasBlockIO mount IO.defaultIOCtxParams $ \_ _ -> pure ()
 
 example_closeIsIdempotent :: Assertion
 example_closeIsIdempotent = withSystemTempDirectory "example_closeIsIdempotent" $ \dirPath -> do
     let mount = FS.MountPoint dirPath
-        hfs = IO.ioHasFS mount
-    hbio <- IO.ioHasBlockIO hfs IO.defaultIOCtxParams
+    hbio <- IO.withIOHasBlockIO mount IO.defaultIOCtxParams $ \_ hbio -> pure hbio
     close hbio
     eith <- try @SomeException (close hbio)
     case eith of
@@ -88,61 +83,48 @@ example_closeIsIdempotent = withSystemTempDirectory "example_closeIsIdempotent"
 prop_readWrite :: ByteString -> Property
 prop_readWrite bs = ioProperty $ withSystemTempDirectory "prop_readWrite" $ \dirPath -> do
     let mount = FS.MountPoint dirPath
-        hfs = IO.ioHasFS mount
-    hbio <- IO.ioHasBlockIO hfs IO.defaultIOCtxParams
-    prop <- FS.withFile hfs (FS.mkFsPath ["temp"]) (FS.WriteMode FS.MustBeNew) $ \h -> do
-      let n = BS.length bs
-      writeBuf <- fromByteStringPinned bs
-      [IOResult m] <- VU.toList <$> submitIO hbio (V.singleton (IOOpWrite h 0 writeBuf 0 (fromIntegral n)))
-      let writeTest = n === fromIntegral m
-      readBuf <- newPinnedByteArray n
-      [IOResult o] <- VU.toList <$> submitIO hbio (V.singleton (IOOpRead h 0 readBuf 0 (fromIntegral n)))
-      let readTest = o === m
-      bs' <- toByteString n readBuf
-      let cmpTest = bs === bs'
-      pure $ writeTest .&&. readTest .&&. cmpTest
-    close hbio
-    pure prop
+    IO.withIOHasBlockIO mount IO.defaultIOCtxParams $ \hfs hbio -> do
+      FS.withFile hfs (FS.mkFsPath ["temp"]) (FS.WriteMode FS.MustBeNew) $ \h -> do
+        let n = BS.length bs
+        writeBuf <- fromByteStringPinned bs
+        [IOResult m] <- VU.toList <$> submitIO hbio (V.singleton (IOOpWrite h 0 writeBuf 0 (fromIntegral n)))
+        let writeTest = n === fromIntegral m
+        readBuf <- newPinnedByteArray n
+        [IOResult o] <- VU.toList <$> submitIO hbio (V.singleton (IOOpRead h 0 readBuf 0 (fromIntegral n)))
+        let readTest = o === m
+        bs' <- toByteString n readBuf
+        let cmpTest = bs === bs'
+        pure $ writeTest .&&. readTest .&&. cmpTest
 
 prop_submitToClosedCtx :: ByteString -> Property
 prop_submitToClosedCtx bs = ioProperty $ withSystemTempDirectory "prop_a" $ \dir -> do
     let mount = FS.MountPoint dir
-        hfs = IO.ioHasFS mount
-    hbio <- IO.ioHasBlockIO hfs IO.defaultIOCtxParams
-
-    props <- FS.withFile hfs (FS.mkFsPath ["temp"]) (FS.WriteMode FS.MustBeNew) $ \h -> do
-      void $ hPutAllStrict hfs h bs
-      syncVar <- newMVar False
-      forConcurrently [0 .. BS.length bs - 1] $ \i ->
-        if i == 0 then do
-          threadDelay 15
-          modifyMVar_ syncVar $ \_ -> do
-            close hbio
-            pure True
-          pure Nothing
-        else do
-          readBuf <- newPinnedByteArray (BS.length bs)
-          withMVar syncVar $ \b -> do
-            eith <- try @SomeException $ submitIO hbio (V.singleton (IOOpRead h 0 readBuf (fromIntegral i) 1))
-            pure $ case eith of
-              Left _  -> Just $ tabulate "submitIO successful" [show False] $ counterexample "expected failure, but got success" (b === True)
-              Right _ -> Just $ tabulate "submitIO successful" [show True]  $ counterexample "expected success, but got failure" (b === False)
-    pure $ conjoin (catMaybes props)
-
+    IO.withIOHasBlockIO mount IO.defaultIOCtxParams $ \hfs hbio -> do
+      FS.withFile hfs (FS.mkFsPath ["temp"]) (FS.WriteMode FS.MustBeNew) $ \h -> do
+        void $ hPutAllStrict hfs h bs
+        syncVar <- newMVar False
+        fmap (conjoin . catMaybes) $ forConcurrently [0 .. BS.length bs - 1] $ \i ->
+          if i == 0 then do
+            threadDelay 15
+            modifyMVar_ syncVar $ \_ -> do
+              close hbio
+              pure True
+            pure Nothing
+          else do
+            readBuf <- newPinnedByteArray (BS.length bs)
+            withMVar syncVar $ \b -> do
+              eith <- try @SomeException $ submitIO hbio (V.singleton (IOOpRead h 0 readBuf (fromIntegral i) 1))
+              pure $ case eith of
+                Left _  -> Just $ tabulate "submitIO successful" [show False] $ counterexample "expected failure, but got success" (b === True)
+                Right _ -> Just $ tabulate "submitIO successful" [show True]  $ counterexample "expected success, but got failure" (b === False)
 
 {-------------------------------------------------------------------------------
   File locks
 -------------------------------------------------------------------------------}
 
-withTempIOHasFS :: FilePath -> (HasFS IO HandleIO -> IO a) -> IO a
-withTempIOHasFS path action = withSystemTempDirectory path $ \dir -> do
-    let hfs = ioHasFS (MountPoint dir)
-    action hfs
-
 withTempIOHasBlockIO :: FilePath -> (HasFS IO HandleIO -> HasBlockIO IO HandleIO -> IO a) -> IO a
-withTempIOHasBlockIO path action =
-    withTempIOHasFS path $ \hfs -> do
-      withIOHasBlockIO hfs defaultIOCtxParams (action hfs)
+withTempIOHasBlockIO path action = withSystemTempDirectory path $ \dir -> do
+    IO.withIOHasBlockIO (MountPoint dir) IO.defaultIOCtxParams action
 
 showLeft :: Show a => String -> Either a b -> String
 showLeft x = \case