From 7934c041c1333c569030be49bca7c50cba337247 Mon Sep 17 00:00:00 2001
From: Joris Dral <joris@well-typed.com>
Date: Tue, 19 Mar 2024 14:59:19 +0100
Subject: [PATCH] TOSQUASH

---
 .../src-linux/System/FS/BlockIO/Async.hs      |  5 +++
 .../src-macos/System/FS/BlockIO/Internal.hs   |  5 +++
 .../src-windows/System/FS/BlockIO/Internal.hs |  5 +++
 .../src/System/FS/BlockIO/Serial.hs           | 38 ++++++-------------
 4 files changed, 26 insertions(+), 27 deletions(-)

diff --git a/fs-api-blockio/src-linux/System/FS/BlockIO/Async.hs b/fs-api-blockio/src-linux/System/FS/BlockIO/Async.hs
index f7c772665..f52544604 100644
--- a/fs-api-blockio/src-linux/System/FS/BlockIO/Async.hs
+++ b/fs-api-blockio/src-linux/System/FS/BlockIO/Async.hs
@@ -90,5 +90,10 @@ ioopConv (IOOpWrite h off buf bufOff c) = handleFd h >>= \fd ->
 -- 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.
+--
+-- TODO: if the handle were to have a reader/writer lock, then we could take the
+-- reader lock in 'submitIO'. However, the current implementation of 'Handle'
+-- only allows mutally exclusive access to the underlying file descriptor, so it
+-- would require a change in @fs-api@. See [fs-sim#49].
 handleFd :: Handle HandleIO -> IO Fd
 handleFd h = withOpenHandle "submitIO" (handleRaw h) pure
diff --git a/fs-api-blockio/src-macos/System/FS/BlockIO/Internal.hs b/fs-api-blockio/src-macos/System/FS/BlockIO/Internal.hs
index e661912b0..6a2d6d7ef 100644
--- a/fs-api-blockio/src-macos/System/FS/BlockIO/Internal.hs
+++ b/fs-api-blockio/src-macos/System/FS/BlockIO/Internal.hs
@@ -7,6 +7,11 @@ import           System.FS.BlockIO.API (HasBlockIO, IOCtxParams)
 import qualified System.FS.BlockIO.Serial as Serial
 import           System.FS.IO (HandleIO)
 
+-- | For now we use the portable serial implementation of HasBlockIO. If you
+-- want to provide a proper async I/O implementation for OSX, then this is where
+-- you should put it.
+--
+-- The recommended choice would be to use the POSIX AIO API.
 ioHasBlockIO ::
      HasFS IO HandleIO
   -> HasBufFS IO HandleIO
diff --git a/fs-api-blockio/src-windows/System/FS/BlockIO/Internal.hs b/fs-api-blockio/src-windows/System/FS/BlockIO/Internal.hs
index e661912b0..a226e3fd8 100644
--- a/fs-api-blockio/src-windows/System/FS/BlockIO/Internal.hs
+++ b/fs-api-blockio/src-windows/System/FS/BlockIO/Internal.hs
@@ -7,6 +7,11 @@ import           System.FS.BlockIO.API (HasBlockIO, IOCtxParams)
 import qualified System.FS.BlockIO.Serial as Serial
 import           System.FS.IO (HandleIO)
 
+-- | For now we use the portable serial implementation of HasBlockIO. If you
+-- want to provide a proper async I/O implementation for Windows, then this is
+-- where you should put it.
+--
+-- The recommended choice would be to use the Win32 IOCP API.
 ioHasBlockIO ::
      HasFS IO HandleIO
   -> HasBufFS IO HandleIO
diff --git a/fs-api-blockio/src/System/FS/BlockIO/Serial.hs b/fs-api-blockio/src/System/FS/BlockIO/Serial.hs
index dee18ebc1..d045a2850 100644
--- a/fs-api-blockio/src/System/FS/BlockIO/Serial.hs
+++ b/fs-api-blockio/src/System/FS/BlockIO/Serial.hs
@@ -1,16 +1,17 @@
-{-# LANGUAGE LambdaCase #-}
 
 module System.FS.BlockIO.Serial (
     serialHasBlockIO
   ) where
 
 import           Control.Concurrent.Class.MonadMVar
+import           Control.Monad (unless)
 import           Control.Monad.Class.MonadThrow
 import           System.FS.API
 import qualified System.FS.BlockIO.API as API
 import           System.FS.BlockIO.API (IOOp (..), IOResult (..))
 
--- | IO instantiation of 'HasBlockIO', using serialised I\/O.
+-- | IO instantiation of 'HasBlockIO', using an existing 'HasFS'. Thus this
+-- implementation does not take advantage of parallel I/O.
 serialHasBlockIO ::
      (MonadThrow m, MonadMVar m, Eq h)
   => HasFS m h
@@ -23,32 +24,17 @@ serialHasBlockIO hfs hbfs = do
     , API.submitIO = submitIO hfs hbfs ctx
     }
 
-data IOCtx m = IOCtx { ctxFS :: SomeHasFS m, openVar :: MVar m CtxState }
+data IOCtx m = IOCtx { ctxFS :: SomeHasFS m, openVar :: MVar m Bool }
 
-data CtxState = Open Word | Closing Word | Closed
-
-addSubmitter :: (MonadMVar m, MonadThrow m) => IOCtx m -> m ()
-addSubmitter ctx = modifyMVar_ (openVar ctx) $ \case
-    Open n    -> pure (Open (n+1))
-    Closing _ -> throwIO (API.mkClosedError (ctxFS ctx) "submitIO")
-    Closed    -> throwIO (API.mkClosedError (ctxFS ctx) "submitIO")
-
-removeSubmitter :: (MonadMVar m, MonadThrow m) => IOCtx m -> m ()
-removeSubmitter ctx = modifyMVar_ (openVar ctx) $ \case
-    Open n         -> pure (Open (n-1))
-    Closing n
-      | n - 1 == 0 -> pure Closed
-      | otherwise  -> pure (Closing (n-1))
-    Closed         -> throwIO (API.mkClosedError (ctxFS ctx) "submitIO")
+guardIsOpen :: (MonadMVar m, MonadThrow m) => IOCtx m -> m ()
+guardIsOpen ctx = readMVar (openVar ctx) >>= \b ->
+    unless b $ throwIO (API.mkClosedError (ctxFS ctx) "submitIO")
 
 initIOCtx :: MonadMVar m => SomeHasFS m -> m (IOCtx m)
-initIOCtx someHasFS = IOCtx someHasFS <$> newMVar (Open 0)
+initIOCtx someHasFS = IOCtx someHasFS <$> newMVar True
 
 close :: MonadMVar m => IOCtx m -> m ()
-close ctx = modifyMVar_ (openVar ctx) $ \case
-    Open n    -> pure (Closing n)
-    Closing n -> pure (Closing n)
-    Closed    -> pure Closed
+close ctx = modifyMVar_ (openVar ctx) $ const (pure False)
 
 submitIO ::
      (MonadMVar m, MonadThrow m)
@@ -58,10 +44,8 @@ submitIO ::
   -> [IOOp m h]
   -> m [IOResult]
 submitIO hfs hbfs ctx ioops = do
-  addSubmitter ctx
-  ress <- mapM (ioop hfs hbfs) ioops
-  removeSubmitter ctx
-  pure ress
+  guardIsOpen ctx
+  mapM (ioop hfs hbfs) ioops
 
 -- | Perform the IOOp using synchronous I\/O.
 ioop ::