Skip to content

Commit 6fb56db

Browse files
jorisdraljorisdral
committed
blockio: move IO-specific functions from API to an internal module
1 parent 099df9e commit 6fb56db

File tree

8 files changed

+88
-71
lines changed

8 files changed

+88
-71
lines changed

‎blockio/blockio.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -71,6 +71,7 @@ library
7171
System.FS.BlockIO.IO
7272
System.FS.BlockIO.Serial
7373

74+
other-modules: System.FS.BlockIO.IO.Internal
7475
build-depends:
7576
, base >=4.16 && <4.22
7677
, deepseq ^>=1.4 || ^>=1.5

‎blockio/src-linux/System/FS/BlockIO/Async.hs‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -16,6 +16,7 @@ import System.FS.API (BufferOffset (..), FsErrorPath, FsPath,
1616
import qualified System.FS.BlockIO.API as API
1717
import System.FS.BlockIO.API (IOOp (..), IOResult (..), LockMode,
1818
ioopHandle)
19+
import qualified System.FS.BlockIO.IO.Internal as IOI
1920
import System.FS.IO (HandleIO)
2021
import System.FS.IO.Handle
2122
import qualified System.IO.BlockIO as I
@@ -72,7 +73,7 @@ submitIO hasFS ioctx ioops = do
7273
-- the exception might change between versions of @blockio-uring@.
7374
-- Nonetheless, it's better than nothing.
7475
if isResourceVanishedError e && ioe_location e == "IOCtx closed"
75-
then throwIO (API.mkClosedError (SomeHasFS hasFS) "submitIO")
76+
then throwIO (IOI.mkClosedError (SomeHasFS hasFS) "submitIO")
7677
else throwIO e
7778

7879
rethrowErrno ::

‎blockio/src-linux/System/FS/BlockIO/Internal.hs‎

Lines changed: 5 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -6,9 +6,9 @@ module System.FS.BlockIO.Internal (
66

77
import qualified System.FS.API as FS
88
import System.FS.API (FsPath, Handle (..), HasFS)
9-
import qualified System.FS.BlockIO.API as FS
109
import System.FS.BlockIO.API (Advice (..), FileOffset, HasBlockIO,
1110
IOCtxParams)
11+
import qualified System.FS.BlockIO.IO.Internal as IOI
1212
import System.FS.IO (HandleIO)
1313
import qualified System.FS.IO.Handle as FS
1414
import qualified System.Posix.Fcntl as Fcntl
@@ -31,21 +31,21 @@ ioHasBlockIO hfs _params =
3131
hSetNoCache
3232
hAdvise
3333
hAllocate
34-
(FS.tryLockFileIO hfs)
34+
(IOI.tryLockFileIO hfs)
3535
hSynchronise
3636
(synchroniseDirectory hfs)
37-
(FS.createHardLinkIO hfs Unix.createLink)
37+
(IOI.createHardLinkIO hfs Unix.createLink)
3838
hfs
3939
#else
4040
ioHasBlockIO hfs params =
4141
Async.asyncHasBlockIO
4242
hSetNoCache
4343
hAdvise
4444
hAllocate
45-
(FS.tryLockFileIO hfs)
45+
(IOI.tryLockFileIO hfs)
4646
hSynchronise
4747
(synchroniseDirectory hfs)
48-
(FS.createHardLinkIO hfs Unix.createLink)
48+
(IOI.createHardLinkIO hfs Unix.createLink)
4949
hfs
5050
params
5151
#endif

‎blockio/src-macos/System/FS/BlockIO/Internal.hs‎

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -4,9 +4,9 @@ module System.FS.BlockIO.Internal (
44

55
import qualified System.FS.API as FS
66
import System.FS.API (FsPath, Handle (..), HasFS)
7-
import qualified System.FS.BlockIO.API as FS
87
import System.FS.BlockIO.API (Advice (..), FileOffset, HasBlockIO,
98
IOCtxParams)
9+
import qualified System.FS.BlockIO.IO.Internal as IOI
1010
import qualified System.FS.BlockIO.Serial as Serial
1111
import System.FS.IO (HandleIO)
1212
import qualified System.FS.IO.Handle as FS
@@ -28,10 +28,10 @@ ioHasBlockIO hfs _params =
2828
hSetNoCache
2929
hAdvise
3030
hAllocate
31-
(FS.tryLockFileIO hfs)
31+
(IOI.tryLockFileIO hfs)
3232
hSynchronise
3333
(synchroniseDirectory hfs)
34-
(FS.createHardLinkIO hfs Unix.createLink)
34+
(IOI.createHardLinkIO hfs Unix.createLink)
3535
hfs
3636

3737
hSetNoCache :: Handle HandleIO -> Bool -> IO ()

‎blockio/src-windows/System/FS/BlockIO/Internal.hs‎

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -9,6 +9,7 @@ import System.FS.API (FsPath, Handle (..), HasFS)
99
import qualified System.FS.BlockIO.API as FS
1010
import System.FS.BlockIO.API (Advice (..), FileOffset, HasBlockIO,
1111
IOCtxParams)
12+
import qualified System.FS.BlockIO.IO.Internal as IOI
1213
import qualified System.FS.BlockIO.Serial as Serial
1314
import System.FS.IO (HandleIO)
1415
import qualified System.FS.IO.Handle as FS
@@ -31,10 +32,10 @@ ioHasBlockIO hfs _params =
3132
hSetNoCache
3233
hAdvise
3334
hAllocate
34-
(FS.tryLockFileIO hfs)
35+
(IOI.tryLockFileIO hfs)
3536
hSynchronise
3637
(synchroniseDirectory hfs)
37-
(FS.createHardLinkIO hfs Windows.createHardLink)
38+
(IOI.createHardLinkIO hfs Windows.createHardLink)
3839
hfs
3940

4041
hSetNoCache :: Handle HandleIO -> Bool -> IO ()

‎blockio/src/System/FS/BlockIO/API.hs‎

Lines changed: 2 additions & 59 deletions
Original file line numberDiff line numberDiff line change
@@ -6,7 +6,6 @@ module System.FS.BlockIO.API (
66
HasBlockIO (..)
77
, IOCtxParams (..)
88
, defaultIOCtxParams
9-
, mkClosedError
109
, IOOp (..)
1110
, ioopHandle
1211
, ioopFileOffset
@@ -25,18 +24,14 @@ module System.FS.BlockIO.API (
2524
-- ** Storage synchronisation
2625
, synchroniseFile
2726
, synchroniseDirectoryRecursive
28-
-- * Defaults for the real file system
29-
, tryLockFileIO
30-
, createHardLinkIO
3127
-- * Re-exports
3228
, ByteCount
3329
, FileOffset
3430
) where
3531

3632
import Control.DeepSeq
3733
import Control.Monad (forM_)
38-
import Control.Monad.Class.MonadThrow (MonadCatch (bracketOnError),
39-
MonadThrow (..), bracketOnError, try)
34+
import Control.Monad.Class.MonadThrow (MonadThrow (..))
4035
import Control.Monad.Primitive (PrimMonad (PrimState))
4136
import Data.Primitive.ByteArray (MutableByteArray)
4237
import qualified Data.Vector as V
@@ -45,15 +40,10 @@ import qualified Data.Vector.Generic.Mutable as VGM
4540
import qualified Data.Vector.Primitive as VP
4641
import qualified Data.Vector.Unboxed as VU
4742
import qualified Data.Vector.Unboxed.Mutable as VUM
48-
import GHC.IO.Exception (IOErrorType (ResourceVanished))
4943
import qualified GHC.IO.Handle.Lock as GHC
5044
import GHC.Stack (HasCallStack)
5145
import qualified System.FS.API as FS
52-
import System.FS.API (BufferOffset, FsError (..), FsPath, Handle (..),
53-
HasFS, SomeHasFS (..))
54-
import System.FS.IO (HandleIO)
55-
import qualified System.IO as GHC
56-
import System.IO.Error (ioeSetErrorString, mkIOError)
46+
import System.FS.API (BufferOffset, FsPath, Handle (..), HasFS)
5747
import System.Posix.Types (ByteCount, FileOffset)
5848
import Text.Printf
5949

@@ -180,14 +170,6 @@ defaultIOCtxParams = IOCtxParams {
180170
ioctxConcurrencyLimit = 64 * 3
181171
}
182172

183-
mkClosedError :: HasCallStack => SomeHasFS m -> String -> FsError
184-
mkClosedError (SomeHasFS hasFS) loc = FS.ioToFsError (FS.mkFsErrorPath hasFS (FS.mkFsPath [])) ioerr
185-
where ioerr =
186-
ioeSetErrorString
187-
(mkIOError ResourceVanished loc Nothing Nothing)
188-
("HasBlockIO closed: " <> loc)
189-
190-
191173
data IOOp s h =
192174
IOOpRead !(Handle h) !FileOffset !(MutableByteArray s) !BufferOffset !ByteCount
193175
| IOOpWrite !(Handle h) !FileOffset !(MutableByteArray s) !BufferOffset !ByteCount
@@ -300,42 +282,3 @@ newtype LockFileHandle m = LockFileHandle {
300282
-- | Release a file lock acquired using 'tryLockFile'.
301283
hUnlock :: m ()
302284
}
303-
304-
tryLockFileIO :: HasFS IO HandleIO -> FsPath -> GHC.LockMode -> IO (Maybe (LockFileHandle IO))
305-
tryLockFileIO hfs fsp mode = do
306-
fp <- FS.unsafeToFilePath hfs fsp -- shouldn't fail because we are in IO
307-
rethrowFsErrorIO hfs fsp $
308-
bracketOnError (GHC.openFile fp GHC.WriteMode) GHC.hClose $ \h -> do
309-
bracketOnError (GHC.hTryLock h mode) (\_ -> GHC.hUnlock h) $ \b -> do
310-
if b then
311-
pure $ Just LockFileHandle { hUnlock = rethrowFsErrorIO hfs fsp $ do
312-
GHC.hUnlock h
313-
`finally` GHC.hClose h
314-
}
315-
else
316-
pure $ Nothing
317-
318-
-- This is copied/adapted from System.FS.IO
319-
rethrowFsErrorIO :: HasCallStack => HasFS IO HandleIO -> FsPath -> IO a -> IO a
320-
rethrowFsErrorIO hfs fp action = do
321-
res <- try action
322-
case res of
323-
Left err -> handleError err
324-
Right a -> pure a
325-
where
326-
handleError :: HasCallStack => IOError -> IO a
327-
handleError ioErr =
328-
throwIO $ FS.ioToFsError (FS.mkFsErrorPath hfs fp) ioErr
329-
330-
{-------------------------------------------------------------------------------
331-
Hard links
332-
-------------------------------------------------------------------------------}
333-
334-
createHardLinkIO ::
335-
HasFS IO HandleIO
336-
-> (FilePath -> FilePath -> IO ())
337-
-> (FsPath -> FsPath -> IO ())
338-
createHardLinkIO hfs f = \source target -> do
339-
source' <- FS.unsafeToFilePath hfs source -- shouldn't fail because we are in IO
340-
target' <- FS.unsafeToFilePath hfs target -- shouldn't fail because we are in IO
341-
f source' target'

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

Lines changed: 70 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,70 @@
1+
{-# LANGUAGE TypeFamilies #-}
2+
{-# LANGUAGE UnboxedTuples #-}
3+
4+
module System.FS.BlockIO.IO.Internal (
5+
mkClosedError
6+
, tryLockFileIO
7+
, createHardLinkIO
8+
) where
9+
10+
import Control.Monad.Class.MonadThrow (MonadCatch (bracketOnError),
11+
MonadThrow (..), bracketOnError, try)
12+
import GHC.IO.Exception (IOErrorType (ResourceVanished))
13+
import qualified GHC.IO.Handle.Lock as GHC
14+
import GHC.Stack (HasCallStack)
15+
import qualified System.FS.API as FS
16+
import System.FS.API (FsError (..), FsPath, HasFS, SomeHasFS (..))
17+
import System.FS.BlockIO.API (LockFileHandle (..))
18+
import System.FS.IO (HandleIO)
19+
import qualified System.IO as GHC
20+
import System.IO.Error (ioeSetErrorString, mkIOError)
21+
22+
mkClosedError :: HasCallStack => SomeHasFS m -> String -> FsError
23+
mkClosedError (SomeHasFS hasFS) loc = FS.ioToFsError (FS.mkFsErrorPath hasFS (FS.mkFsPath [])) ioerr
24+
where ioerr =
25+
ioeSetErrorString
26+
(mkIOError ResourceVanished loc Nothing Nothing)
27+
("HasBlockIO closed: " <> loc)
28+
29+
{-------------------------------------------------------------------------------
30+
File locks
31+
-------------------------------------------------------------------------------}
32+
33+
tryLockFileIO :: HasFS IO HandleIO -> FsPath -> GHC.LockMode -> IO (Maybe (LockFileHandle IO))
34+
tryLockFileIO hfs fsp mode = do
35+
fp <- FS.unsafeToFilePath hfs fsp -- shouldn't fail because we are in IO
36+
rethrowFsErrorIO hfs fsp $
37+
bracketOnError (GHC.openFile fp GHC.WriteMode) GHC.hClose $ \h -> do
38+
bracketOnError (GHC.hTryLock h mode) (\_ -> GHC.hUnlock h) $ \b -> do
39+
if b then
40+
pure $ Just LockFileHandle { hUnlock = rethrowFsErrorIO hfs fsp $ do
41+
GHC.hUnlock h
42+
`finally` GHC.hClose h
43+
}
44+
else
45+
pure $ Nothing
46+
47+
-- This is copied/adapted from System.FS.IO
48+
rethrowFsErrorIO :: HasCallStack => HasFS IO HandleIO -> FsPath -> IO a -> IO a
49+
rethrowFsErrorIO hfs fp action = do
50+
res <- try action
51+
case res of
52+
Left err -> handleError err
53+
Right a -> pure a
54+
where
55+
handleError :: HasCallStack => IOError -> IO a
56+
handleError ioErr =
57+
throwIO $ FS.ioToFsError (FS.mkFsErrorPath hfs fp) ioErr
58+
59+
{-------------------------------------------------------------------------------
60+
Hard links
61+
-------------------------------------------------------------------------------}
62+
63+
createHardLinkIO ::
64+
HasFS IO HandleIO
65+
-> (FilePath -> FilePath -> IO ())
66+
-> (FsPath -> FsPath -> IO ())
67+
createHardLinkIO hfs f = \source target -> do
68+
source' <- FS.unsafeToFilePath hfs source -- shouldn't fail because we are in IO
69+
target' <- FS.unsafeToFilePath hfs target -- shouldn't fail because we are in IO
70+
f source' target'

‎blockio/src/System/FS/BlockIO/Serial.hs‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -13,6 +13,7 @@ import GHC.Stack (HasCallStack)
1313
import System.FS.API
1414
import qualified System.FS.BlockIO.API as API
1515
import System.FS.BlockIO.API (IOOp (..), IOResult (..), LockMode (..))
16+
import qualified System.FS.BlockIO.IO.Internal as IOI
1617

1718
{-# SPECIALISE serialHasBlockIO ::
1819
Eq h
@@ -58,7 +59,7 @@ data IOCtx m = IOCtx { ctxFS :: SomeHasFS m, openVar :: MVar m Bool }
5859
{-# SPECIALISE guardIsOpen :: IOCtx IO -> IO () #-}
5960
guardIsOpen :: (HasCallStack, MonadMVar m, MonadThrow m) => IOCtx m -> m ()
6061
guardIsOpen ctx = readMVar (openVar ctx) >>= \b ->
61-
unless b $ throwIO (API.mkClosedError (ctxFS ctx) "submitIO")
62+
unless b $ throwIO (IOI.mkClosedError (ctxFS ctx) "submitIO")
6263

6364
{-# SPECIALISE initIOCtx :: SomeHasFS IO -> IO (IOCtx IO) #-}
6465
initIOCtx :: MonadMVar m => SomeHasFS m -> m (IOCtx m)

0 commit comments

Comments
 (0)