diff --git a/bench/macro/lsm-tree-bench-lookups.hs b/bench/macro/lsm-tree-bench-lookups.hs index 01f8a146c..cb4ad902e 100644 --- a/bench/macro/lsm-tree-bench-lookups.hs +++ b/bench/macro/lsm-tree-bench-lookups.hs @@ -310,11 +310,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. diff --git a/bench/macro/lsm-tree-bench-wp8.hs b/bench/macro/lsm-tree-bench-wp8.hs index 2ec493a56..2b14ecaea 100644 --- a/bench/macro/lsm-tree-bench-wp8.hs +++ b/bench/macro/lsm-tree-bench-wp8.hs @@ -63,9 +63,7 @@ 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.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 @@ -438,17 +436,8 @@ doSetup gopts opts = do void $ timed_ $ doSetup' gopts opts 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 FS.defaultIOCtxParams - - let name = LSM.toSnapshotName "bench" - +doSetup' gopts opts = + FsIO.withIOHasBlockIO mountPoint FsIO.defaultIOCtxParams $ \hasFS hasBlockIO -> LSM.withOpenSession (mkTracer gopts) hasFS hasBlockIO benchSalt (FS.mkFsPath []) $ \session -> do tbl <- LSM.newTableWith @IO @K @V @B (mkTableConfigSetup gopts opts benchTableConfig) session @@ -462,6 +451,12 @@ doSetup' gopts opts = do ] LSM.saveSnapshot name label tbl + where + mountPoint :: FS.MountPoint + mountPoint = FS.MountPoint (rootDir gopts) + + name = LSM.toSnapshotName "bench" + ------------------------------------------------------------------------------- -- dry-run @@ -600,17 +595,8 @@ 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 FS.defaultIOCtxParams - - let name = LSM.toSnapshotName "bench" - +doRun gopts opts = + FsIO.withIOHasBlockIO mountPoint FsIO.defaultIOCtxParams $ \hasFS hasBlockIO -> LSM.withOpenSession (mkTracer gopts) hasFS hasBlockIO benchSalt (FS.mkFsPath []) $ \session -> withLatencyHandle $ \h -> do -- open snapshot @@ -652,6 +638,11 @@ doRun gopts opts = do let ops = batchCount opts * batchSize opts printf "Operations per second: %7.01f ops/sec\n" (fromIntegral ops / time) + where + mountPoint :: FS.MountPoint + mountPoint = FS.MountPoint (rootDir gopts) + + name = LSM.toSnapshotName "bench" ------------------------------------------------------------------------------- -- sequential diff --git a/bench/micro/Bench/Database/LSMTree.hs b/bench/micro/Bench/Database/LSMTree.hs index b949c24ea..995b1063e 100644 --- a/bench/micro/Bench/Database/LSMTree.hs +++ b/bench/micro/Bench/Database/LSMTree.hs @@ -433,8 +433,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 :: diff --git a/bench/micro/Bench/Database/LSMTree/Internal/Lookup.hs b/bench/micro/Bench/Database/LSMTree/Internal/Lookup.hs index 5c02b3b72..5ca58854b 100644 --- a/bench/micro/Bench/Database/LSMTree/Internal/Lookup.hs +++ b/bench/micro/Bench/Database/LSMTree/Internal/Lookup.hs @@ -191,8 +191,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) diff --git a/bench/micro/Bench/Database/LSMTree/Internal/Merge.hs b/bench/micro/Bench/Database/LSMTree/Internal/Merge.hs index 07b26adc3..7028a48ad 100644 --- a/bench/micro/Bench/Database/LSMTree/Internal/Merge.hs +++ b/bench/micro/Bench/Database/LSMTree/Internal/Merge.hs @@ -373,8 +373,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) diff --git a/blockio/blockio.cabal b/blockio/blockio.cabal index d73587480..70cdccc71 100644 --- a/blockio/blockio.cabal +++ b/blockio/blockio.cabal @@ -18,7 +18,7 @@ license-files: author: Duncan Coutts, Joris Dral, Matthias Heinzel, Wolfgang Jeltsch, Wen Kokke, and Alex Washburn -maintainer: TODO: MAINTAINER EMAIL +maintainer: joris@well-typed.com copyright: (c) 2023 Input Output Global, Inc. (IOG) (c) 2023-2025 INTERSECT @@ -33,13 +33,11 @@ source-repository head location: https://github.com/IntersectMBO/lsm-tree subdir: blockio --- TODO: this tag obviously does not exist yet because the package has not --- been published source-repository this type: git location: https://github.com/IntersectMBO/lsm-tree - tag: blockio-0.1.0.0 subdir: blockio + tag: blockio-0.1.0.0 common warnings ghc-options: @@ -69,6 +67,10 @@ library exposed-modules: System.FS.BlockIO.API System.FS.BlockIO.IO + System.FS.BlockIO.Serial.Internal + + other-modules: + System.FS.BlockIO.IO.Internal System.FS.BlockIO.Serial build-depends: @@ -113,7 +115,7 @@ test-suite test , bytestring , fs-api , primitive - , QuickCheck ^>=2.15.0.1 + , QuickCheck >=2.15.0.1 , tasty , tasty-hunit , tasty-quickcheck @@ -128,12 +130,12 @@ library sim hs-source-dirs: src-sim exposed-modules: System.FS.BlockIO.Sim build-depends: - , base >=4.16 && <4.22 + , base >=4.16 && <4.22 , blockio - , bytestring ^>=0.11.4.0 || ^>=0.12.1.0 + , bytestring ^>=0.11 || ^>=0.12 , fs-api ^>=0.4 , fs-sim ^>=0.4 - , io-classes ^>=1.6 || ^>=1.7 || ^>=1.8.0.1 + , io-classes ^>=1.6 || ^>=1.7 || ^>=1.8.0.1 , io-classes:strict-stm , primitive ^>=0.9 diff --git a/blockio/src-linux/System/FS/BlockIO/Async.hs b/blockio/src-linux/System/FS/BlockIO/Async.hs index 348e4d4bd..41934e4fc 100644 --- a/blockio/src-linux/System/FS/BlockIO/Async.hs +++ b/blockio/src-linux/System/FS/BlockIO/Async.hs @@ -16,6 +16,7 @@ import System.FS.API (BufferOffset (..), FsErrorPath, FsPath, import qualified System.FS.BlockIO.API as API import System.FS.BlockIO.API (IOOp (..), IOResult (..), LockMode, ioopHandle) +import qualified System.FS.BlockIO.IO.Internal as IOI import System.FS.IO (HandleIO) import System.FS.IO.Handle import qualified System.IO.BlockIO as I @@ -32,7 +33,7 @@ asyncHasBlockIO :: -> (FsPath -> IO ()) -> (FsPath -> FsPath -> IO ()) -> HasFS IO HandleIO - -> API.IOCtxParams + -> IOI.IOCtxParams -> IO (API.HasBlockIO IO HandleIO) asyncHasBlockIO hSetNoCache hAdvise hAllocate tryLockFile hSynchronise synchroniseDirectory createHardLink hasFS ctxParams = do ctx <- I.initIOCtx (ctxParamsConv ctxParams) @@ -48,8 +49,8 @@ asyncHasBlockIO hSetNoCache hAdvise hAllocate tryLockFile hSynchronise synchroni , API.createHardLink } -ctxParamsConv :: API.IOCtxParams -> I.IOCtxParams -ctxParamsConv API.IOCtxParams{API.ioctxBatchSizeLimit, API.ioctxConcurrencyLimit} = +ctxParamsConv :: IOI.IOCtxParams -> I.IOCtxParams +ctxParamsConv IOI.IOCtxParams{IOI.ioctxBatchSizeLimit, IOI.ioctxConcurrencyLimit} = I.IOCtxParams { I.ioctxBatchSizeLimit = ioctxBatchSizeLimit , I.ioctxConcurrencyLimit = ioctxConcurrencyLimit @@ -72,7 +73,7 @@ submitIO hasFS ioctx ioops = do -- the exception might change between versions of @blockio-uring@. -- Nonetheless, it's better than nothing. if isResourceVanishedError e && ioe_location e == "IOCtx closed" - then throwIO (API.mkClosedError (SomeHasFS hasFS) "submitIO") + then throwIO (IOI.mkClosedError (SomeHasFS hasFS) "submitIO") else throwIO e rethrowErrno :: diff --git a/blockio/src-linux/System/FS/BlockIO/Internal.hs b/blockio/src-linux/System/FS/BlockIO/Internal.hs index aa5737536..7bff61874 100644 --- a/blockio/src-linux/System/FS/BlockIO/Internal.hs +++ b/blockio/src-linux/System/FS/BlockIO/Internal.hs @@ -6,9 +6,8 @@ module System.FS.BlockIO.Internal ( import qualified System.FS.API as FS import System.FS.API (FsPath, Handle (..), HasFS) -import qualified System.FS.BlockIO.API as FS -import System.FS.BlockIO.API (Advice (..), FileOffset, HasBlockIO, - IOCtxParams) +import System.FS.BlockIO.API (Advice (..), FileOffset, HasBlockIO) +import qualified System.FS.BlockIO.IO.Internal as IOI import System.FS.IO (HandleIO) import qualified System.FS.IO.Handle as FS import qualified System.Posix.Fcntl as Fcntl @@ -23,7 +22,7 @@ import qualified System.FS.BlockIO.Async as Async ioHasBlockIO :: HasFS IO HandleIO - -> IOCtxParams + -> IOI.IOCtxParams -> IO (HasBlockIO IO HandleIO) #if SERIALBLOCKIO ioHasBlockIO hfs _params = @@ -31,10 +30,10 @@ ioHasBlockIO hfs _params = hSetNoCache hAdvise hAllocate - (FS.tryLockFileIO hfs) + (IOI.tryLockFileIO hfs) hSynchronise (synchroniseDirectory hfs) - (FS.createHardLinkIO hfs Unix.createLink) + (IOI.createHardLinkIO hfs Unix.createLink) hfs #else ioHasBlockIO hfs params = @@ -42,10 +41,10 @@ ioHasBlockIO hfs params = hSetNoCache hAdvise hAllocate - (FS.tryLockFileIO hfs) + (IOI.tryLockFileIO hfs) hSynchronise (synchroniseDirectory hfs) - (FS.createHardLinkIO hfs Unix.createLink) + (IOI.createHardLinkIO hfs Unix.createLink) hfs params #endif diff --git a/blockio/src-macos/System/FS/BlockIO/Internal.hs b/blockio/src-macos/System/FS/BlockIO/Internal.hs index abc18dca4..0a24a0701 100644 --- a/blockio/src-macos/System/FS/BlockIO/Internal.hs +++ b/blockio/src-macos/System/FS/BlockIO/Internal.hs @@ -4,9 +4,8 @@ module System.FS.BlockIO.Internal ( import qualified System.FS.API as FS import System.FS.API (FsPath, Handle (..), HasFS) -import qualified System.FS.BlockIO.API as FS -import System.FS.BlockIO.API (Advice (..), FileOffset, HasBlockIO, - IOCtxParams) +import System.FS.BlockIO.API (Advice (..), FileOffset, HasBlockIO) +import qualified System.FS.BlockIO.IO.Internal as IOI import qualified System.FS.BlockIO.Serial as Serial import System.FS.IO (HandleIO) import qualified System.FS.IO.Handle as FS @@ -21,17 +20,17 @@ import qualified System.Posix.Unistd as Unix -- The recommended choice would be to use the POSIX AIO API. ioHasBlockIO :: HasFS IO HandleIO - -> IOCtxParams + -> IOI.IOCtxParams -> IO (HasBlockIO IO HandleIO) ioHasBlockIO hfs _params = Serial.serialHasBlockIO hSetNoCache hAdvise hAllocate - (FS.tryLockFileIO hfs) + (IOI.tryLockFileIO hfs) hSynchronise (synchroniseDirectory hfs) - (FS.createHardLinkIO hfs Unix.createLink) + (IOI.createHardLinkIO hfs Unix.createLink) hfs hSetNoCache :: Handle HandleIO -> Bool -> IO () diff --git a/blockio/src-sim/System/FS/BlockIO/Sim.hs b/blockio/src-sim/System/FS/BlockIO/Sim.hs index 35fb90681..ee34a7b42 100644 --- a/blockio/src-sim/System/FS/BlockIO/Sim.hs +++ b/blockio/src-sim/System/FS/BlockIO/Sim.hs @@ -1,10 +1,18 @@ +-- | Simulated instances of 'HasBlockIO' and 'HasFS'. module System.FS.BlockIO.Sim ( - fromHasFS - -- * Initialisation helpers + -- * Implementation details #impl# + -- $impl + + -- * Runners + runSimHasBlockIO + , runSimErrorHasBlockIO + -- * Initialisation , simHasBlockIO , simHasBlockIO' , simErrorHasBlockIO , simErrorHasBlockIO' + -- ** Unsafe + , unsafeFromHasFS ) where import Control.Concurrent.Class.MonadMVar @@ -18,17 +26,61 @@ import qualified System.FS.API.Lazy as API import qualified System.FS.API.Strict as API import System.FS.BlockIO.API (HasBlockIO (..), LockFileHandle (..), LockMode (..)) -import System.FS.BlockIO.Serial +import System.FS.BlockIO.Serial.Internal import System.FS.CallStack (prettyCallStack) import System.FS.Sim.Error import System.FS.Sim.MockFS hiding (hClose, hOpen) import System.FS.Sim.STM -fromHasFS :: +{- $impl + + We include below some documentation about the effects of calling the interface + functions on the simulated instance of the 'HasBlockIO' interface. + + [IO context]: For uniform behaviour across implementations, the simulation + creates and stores a mocked IO context that has the open/closed behaviour + that is specified by the interface. + + ['close']: Close the mocked context + + ['submitIO']: Submit a batch of I\/O operations using serial I\/O using a + 'HasFS' + + ['hSetNoCache']: No-op + + ['hAdvise']: No-op + + ['hAllocate']: No-op + + ['tryLockFile']: Simulate a lock by putting the lock state into the file + contents + + ['hSynchronise']: No-op + + ['synchroniseDirectory']: No-op + + ['createHardLink']: Copy all file contents from the source path to the target + path. Therefore, this is currently only correctly simulating hard links + for /immutable/ files. +-} + +-- | Simulate a 'HasBlockIO' using the given 'HasFS'. +-- +-- === Unsafe +-- +-- You will probably want to use one of the safe functions like +-- 'runSimHasBlockIO' or 'simErrorHasBlockIO' instead. +-- +-- Only a simulated 'HasFS', like the 'simHasFS' and 'simErrorHasFS' +-- simulations, should be passed to 'unsafeFromHasFS'. Technically, one could +-- pass a 'HasFS' for the /real/ file system, but then the resulting +-- 'HasBlockIO' would contain a mix of simulated functions and real functions, +-- which is probably not what you want. +unsafeFromHasFS :: forall m. (MonadCatch m, MonadMVar m, PrimMonad m) => HasFS m HandleMock -> m (HasBlockIO m HandleMock) -fromHasFS hfs = +unsafeFromHasFS hfs = serialHasBlockIO hSetNoCache hAdvise @@ -142,27 +194,104 @@ simCreateHardLink hfs sourcePath targetPath = void $ API.hPutAll hfs targetHandle bs {------------------------------------------------------------------------------- - Initialisation helpers + Runners -------------------------------------------------------------------------------} +-- | @'runSimHasBlockIO' mockFS action@ runs an @action@ using a pair of +-- simulated 'HasFS' and 'HasBlockIO'. +-- +-- The pair of interfaces share the same mocked file system. The initial state +-- of the mocked file system is set to @mockFs@. The final state of the mocked +-- file system is returned with the result of @action@. +-- +-- If you want to have access to the current state of the mocked file system, +-- use 'simHasBlockIO' instead. +runSimHasBlockIO :: + (MonadSTM m, PrimMonad m, MonadCatch m, MonadMVar m) + => MockFS + -> (HasFS m HandleMock -> HasBlockIO m HandleMock -> m a) + -> m (a, MockFS) +runSimHasBlockIO mockFS k = do + runSimFS mockFS $ \hfs -> do + hbio <- unsafeFromHasFS hfs + k hfs hbio + +-- | @'runSimErrorHasBlockIO' mockFS errors action@ runs an @action@ using a +-- pair of simulated 'HasFS' and 'HasBlockIO' that allow fault injection. +-- +-- The pair of interfaces share the same mocked file system. The initial state +-- of the mocked file system is set to @mockFs@. The final state of the mocked +-- file system is returned with the result of @action@. +-- +-- The pair of interfaces share the same stream of errors. The initial state of +-- the stream of errors is set to @errors@. The final state of the stream of +-- errors is returned with the result of @action@. +-- +-- If you want to have access to the current state of the mocked file system +-- or stream of errors, use 'simErrorHasBlockIO' instead. +runSimErrorHasBlockIO :: + (MonadSTM m, PrimMonad m, MonadCatch m, MonadMVar m) + => MockFS + -> Errors + -> (HasFS m HandleMock -> HasBlockIO m HandleMock -> m a) + -> m (a, MockFS, Errors) +runSimErrorHasBlockIO mockFS errs k = do + fsVar <- newTMVarIO mockFS + errorsVar <- newTVarIO errs + (hfs, hbio) <- simErrorHasBlockIO fsVar errorsVar + a <- k hfs hbio + fs' <- atomically $ takeTMVar fsVar + errs' <- readTVarIO errorsVar + pure (a, fs', errs') + +{------------------------------------------------------------------------------- + Initialisation +-------------------------------------------------------------------------------} + +-- | @'simHasBlockIO' mockFsVar@ creates a pair of simulated 'HasFS' and +-- 'HasBlockIO'. +-- +-- The pair of interfaces share the same mocked file system, which is stored in +-- @mockFsVar@. The current state of the mocked file system can be accessed by +-- the user by reading @mockFsVar@, but note that the user should not leave +-- @mockFsVar@ empty. simHasBlockIO :: (MonadCatch m, MonadMVar m, PrimMonad m, MonadSTM m) => StrictTMVar m MockFS -> m (HasFS m HandleMock, HasBlockIO m HandleMock) simHasBlockIO var = do let hfs = simHasFS var - hbio <- fromHasFS hfs + hbio <- unsafeFromHasFS hfs pure (hfs, hbio) +-- | @'simHasBlockIO' mockFs@ creates a pair of simulated 'HasFS' and +-- 'HasBlockIO' that allow fault injection. +-- +-- The pair of interfaces share the same mocked file system. The initial state +-- of the mocked file system is set to @mockFs@. +-- +-- If you want to have access to the current state of the mocked file system, +-- use 'simHasBlockIO' instead. simHasBlockIO' :: (MonadCatch m, MonadMVar m, PrimMonad m, MonadSTM m) => MockFS -> m (HasFS m HandleMock, HasBlockIO m HandleMock) simHasBlockIO' mockFS = do hfs <- simHasFS' mockFS - hbio <- fromHasFS hfs + hbio <- unsafeFromHasFS hfs pure (hfs, hbio) +-- | @'simErrorHasBlockIO' mockFsVar errorsVar@ creates a pair of simulated +-- 'HasFS' and 'HasBlockIO' that allow fault injection. +-- +-- The pair of interfaces share the same mocked file system, which is stored in +-- @mockFsVar@. The current state of the mocked file system can be accessed by +-- the user by reading @mockFsVar@, but note that the user should not leave +-- @mockFsVar@ empty. +-- +-- The pair of interfaces share the same stream of errors, which is stored in +-- @errorsVar@. The current state of the stream of errors can be accessed by the +-- user by reading @errorsVar@. simErrorHasBlockIO :: forall m. (MonadCatch m, MonadMVar m, PrimMonad m, MonadSTM m) => StrictTMVar m MockFS @@ -170,9 +299,20 @@ simErrorHasBlockIO :: -> m (HasFS m HandleMock, HasBlockIO m HandleMock) simErrorHasBlockIO fsVar errorsVar = do let hfs = simErrorHasFS fsVar errorsVar - hbio <- fromHasFS hfs + hbio <- unsafeFromHasFS hfs pure (hfs, hbio) +-- | @'simErrorHasBlockIO' mockFs errors@ creates a pair of simulated 'HasFS' +-- and 'HasBlockIO' that allow fault injection. +-- +-- The pair of interfaces share the same mocked file system. The initial state +-- of the mocked file system is set to @mockFs@. +-- +-- The pair of interfaces share the same stream of errors. The initial state of +-- the stream of errors is set to @errors@. +-- +-- If you want to have access to the current state of the mocked file system +-- or stream of errors, use 'simErrorHasBlockIO' instead. simErrorHasBlockIO' :: (MonadCatch m, MonadMVar m, PrimMonad m, MonadSTM m) => MockFS @@ -180,5 +320,5 @@ simErrorHasBlockIO' :: -> m (HasFS m HandleMock, HasBlockIO m HandleMock) simErrorHasBlockIO' mockFS errs = do hfs <- simErrorHasFS' mockFS errs - hbio <- fromHasFS hfs + hbio <- unsafeFromHasFS hfs pure (hfs, hbio) diff --git a/blockio/src-windows/System/FS/BlockIO/Internal.hs b/blockio/src-windows/System/FS/BlockIO/Internal.hs index 1b40dc86b..09290f107 100644 --- a/blockio/src-windows/System/FS/BlockIO/Internal.hs +++ b/blockio/src-windows/System/FS/BlockIO/Internal.hs @@ -6,9 +6,8 @@ import Control.Exception (throwIO) import Control.Monad (unless) import qualified System.FS.API as FS import System.FS.API (FsPath, Handle (..), HasFS) -import qualified System.FS.BlockIO.API as FS -import System.FS.BlockIO.API (Advice (..), FileOffset, HasBlockIO, - IOCtxParams) +import System.FS.BlockIO.API (Advice (..), FileOffset, HasBlockIO) +import qualified System.FS.BlockIO.IO.Internal as IOI import qualified System.FS.BlockIO.Serial as Serial import System.FS.IO (HandleIO) import qualified System.FS.IO.Handle as FS @@ -24,17 +23,17 @@ import qualified System.Win32.HardLink as Windows -- The recommended choice would be to use the Win32 IOCP API. ioHasBlockIO :: HasFS IO HandleIO - -> IOCtxParams + -> IOI.IOCtxParams -> IO (HasBlockIO IO HandleIO) ioHasBlockIO hfs _params = Serial.serialHasBlockIO hSetNoCache hAdvise hAllocate - (FS.tryLockFileIO hfs) + (IOI.tryLockFileIO hfs) hSynchronise (synchroniseDirectory hfs) - (FS.createHardLinkIO hfs Windows.createHardLink) + (IOI.createHardLinkIO hfs Windows.createHardLink) hfs hSetNoCache :: Handle HandleIO -> Bool -> IO () diff --git a/blockio/src/System/FS/BlockIO/API.hs b/blockio/src/System/FS/BlockIO/API.hs index 496e707c8..1322ea4e9 100644 --- a/blockio/src/System/FS/BlockIO/API.hs +++ b/blockio/src/System/FS/BlockIO/API.hs @@ -1,12 +1,10 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UnboxedTuples #-} +-- | Abstract interface, types, and utilities. module System.FS.BlockIO.API ( -- * HasBlockIO HasBlockIO (..) - , IOCtxParams (..) - , defaultIOCtxParams - , mkClosedError , IOOp (..) , ioopHandle , ioopFileOffset @@ -25,9 +23,6 @@ module System.FS.BlockIO.API ( -- ** Storage synchronisation , synchroniseFile , synchroniseDirectoryRecursive - -- * Defaults for the real file system - , tryLockFileIO - , createHardLinkIO -- * Re-exports , ByteCount , FileOffset @@ -35,8 +30,7 @@ module System.FS.BlockIO.API ( import Control.DeepSeq import Control.Monad (forM_) -import Control.Monad.Class.MonadThrow (MonadCatch (bracketOnError), - MonadThrow (..), bracketOnError, try) +import Control.Monad.Class.MonadThrow (MonadThrow (..)) import Control.Monad.Primitive (PrimMonad (PrimState)) import Data.Primitive.ByteArray (MutableByteArray) import qualified Data.Vector as V @@ -45,25 +39,58 @@ import qualified Data.Vector.Generic.Mutable as VGM import qualified Data.Vector.Primitive as VP import qualified Data.Vector.Unboxed as VU import qualified Data.Vector.Unboxed.Mutable as VUM -import GHC.IO.Exception (IOErrorType (ResourceVanished)) import qualified GHC.IO.Handle.Lock as GHC import GHC.Stack (HasCallStack) import qualified System.FS.API as FS -import System.FS.API (BufferOffset, FsError (..), FsPath, Handle (..), - HasFS, SomeHasFS (..)) -import System.FS.IO (HandleIO) -import qualified System.IO as GHC -import System.IO.Error (ioeSetErrorString, mkIOError) +import System.FS.API (BufferOffset, FsPath, Handle (..), HasFS) import System.Posix.Types (ByteCount, FileOffset) import Text.Printf --- | Abstract interface for submitting large batches of I\/O operations. +-- | Abstract interface for submitting large batches of I\/O operations. This +-- interface is an extension of the 'HasFS' interface that is provided by the +-- @fs-api@ package. +-- +-- The interface tries to specify uniform behaviour, but each implementation can +-- have subtly different effects for a variety of reasons. However, for the most +-- part the underlying implementation of an instance of the interface should not +-- affect the correctness of programs that use the interface. +-- +-- For uniform behaviour across implementations, functions that create a new +-- instance of the interface should initialise an IO context. This IO context +-- may be of any shape, as long as the context has two modes: open and closed. +-- This context is only important for the 'close' and 'submitIO' functions. As +-- long as the IO context is open, 'submitIO' should perform batches of I\/O +-- operations as expected, but 'submitIO' should throw an error as soon as the +-- IO context is closed. Once the IO context is closed, it can not be re-opened +-- again. Instead, the user should create a new instance of the interface. +-- +-- Note: there are a bunch of functions in the interface that have nothing to do +-- with submitting large batches of I/O operations. In fact, only 'close' and +-- 'submitIO' are related to that. All other functions were put in this record +-- for simplicity because the authors of the library needed them and it was more +-- straightforward to add them here then to add them to @fs-api@. Still these +-- unrelated functions could and should all be moved into @fs-api@ at some point +-- in the future. +-- +-- === Implementations +-- +-- There are currently two known implementations of the interface: +-- +-- * An implementation using the real file system, which can be found in the +-- "System.FS.BlockIO.IO" module. This implementation is platform-dependent. +-- +-- * An implementation using a simulated file system, which can be found in the +-- @System.FS.BlockIO.Sim@ module of the @blockio:sim@ sublibrary. This +-- implementation is uniform across platforms. +-- data HasBlockIO m h = HasBlockIO { - -- | (Idempotent) close the interface. + -- | (Idempotent) close the IO context that is required for running + -- 'submitIO'. + -- + -- Using 'submitIO' after 'close' throws an 'FsError' exception. -- - -- Using 'submitIO' after 'close' should thrown an 'FsError' exception. See - -- 'mkClosedError'. close :: HasCallStack => m () + -- | Submit a batch of I\/O operations and wait for the result. -- -- Results correspond to input 'IOOp's in a pair-wise manner, i.e., one can @@ -71,41 +98,28 @@ data HasBlockIO m h = HasBlockIO { -- position. -- -- If any of the I\/O operations fails, an 'FsError' exception will be thrown. + -- , submitIO :: HasCallStack => V.Vector (IOOp (PrimState m) h) -> m (VU.Vector IOResult) + + -- TODO: once file caching is disabled, subsequent reads/writes with + -- misaligned byte arrays should throw an error. Preferably, this should + -- happen in both the simulation and real implementation, even if the real + -- implementation does not support setting the file caching mode. This would + -- make the behaviour of the file caching mode more uniform across + -- implementations and platforms. + -- | Set the file data caching mode for a file handle. -- - -- This has different effects on different distributions. - -- * [Linux]: set the @O_DIRECT@ flag. - -- * [MacOS]: set the @F_NOCACHE@ flag. - -- * [Windows]: no-op. - -- - -- TODO: subsequent reads/writes with misaligned byte arrays should fail - -- both in simulation and real implementation. , hSetNoCache :: Handle h -> Bool -> m () + -- | Predeclare an access pattern for file data. -- - -- This has different effects on different distributions. - -- * [Linux]: perform @posix_fadvise(2). - -- * [MacOS]: no-op. - -- * [Windows]: no-op. , hAdvise :: Handle h -> FileOffset -> FileOffset -> Advice -> m () + -- | Allocate file space. -- - -- This has different effects on different distributions. - -- * [Linux]: perform @posix_fallocate(2). - -- * [MacOS]: no-op. - -- * [Windows]: no-op. , hAllocate :: Handle h -> FileOffset -> FileOffset -> m () - -- | Try to acquire a file lock without blocking. - -- - -- This uses different locking methods on different distributions. - -- * [Linux]: Open file descriptor (OFD) - -- * [MacOS]: @flock@ - -- * [Windows]: @LockFileEx@ - -- - -- This function can throw 'GHC.FileLockingNotSupported' when file locking - -- is not supported. - -- + -- NOTE: though it would have been nicer to allow locking /file handles/ -- instead of /file paths/, it would make the implementation of this -- function in 'IO' much more complex. In particular, if we want to reuse @@ -126,35 +140,34 @@ data HasBlockIO m h = HasBlockIO { -- that allows you to use 'LockFileHandle' as a 'Handle', but only within a -- limited scope. That is, it has to fit the style of @withHandleToHANDLE :: -- Handle -> (HANDLE -> IO a) -> IO a@ from the @Win32@ package. + + -- | Try to acquire a file lock without blocking. + -- + -- This function throws 'GHC.FileLockingNotSupported' when file locking is + -- not supported. + -- , tryLockFile :: FsPath -> GHC.LockMode -> m (Maybe (LockFileHandle m)) -- | Synchronise file contents with the storage device. -- - -- Ensure that all change to the file handle's contents which exist only in - -- memory (as buffered system cache pages) are transferred/flushed to disk. - -- This will also update the file handle's associated metadata. + -- This ensures that all changes to the file handle's contents, which might + -- exist only in memory as buffered system cache pages, are + -- transferred/flushed to disk. This will also update the file handle's + -- associated metadata. -- - -- This uses different system calls on different distributions. - -- * [Linux]: @fsync(2)@ - -- * [MacOS]: @fsync(2)@ - -- * [Windows]: @flushFileBuffers@ , hSynchronise :: Handle h -> m () -- | Synchronise a directory with the storage device. -- - -- This uses different system calls on different distributions. - -- * [Linux]: @fsync(2)@ - -- * [MacOS]: @fsync(2)@ - -- * [Windows]: no-op + -- This ensures that all changes to the directory, which might exist only in + -- memory as buffered changes, are transferred/flushed to disk. This will + -- also update the directory's associated metadata. + -- , synchroniseDirectory :: FsPath -> m () -- | Create a hard link for an existing file at the source path and a new -- file at the target path. -- - -- This uses different system calls on different distributions. - -- * [Linux]: @link@ - -- * [MacOS]: @link@ - -- * [Windows]: @CreateHardLinkW@ , createHardLink :: FsPath -> FsPath -> m () } @@ -164,30 +177,6 @@ instance NFData (HasBlockIO m h) where rwhnf d `seq` rwhnf e `seq` rwhnf f `seq` rwhnf g `seq` rwhnf h `seq` rwhnf i --- | Concurrency parameters for initialising a 'HasBlockIO. Can be ignored by --- serial implementations. -data IOCtxParams = IOCtxParams { - ioctxBatchSizeLimit :: !Int, - ioctxConcurrencyLimit :: !Int - } - -instance NFData IOCtxParams where - rnf (IOCtxParams x y) = rnf x `seq` rnf y - -defaultIOCtxParams :: IOCtxParams -defaultIOCtxParams = IOCtxParams { - ioctxBatchSizeLimit = 64, - ioctxConcurrencyLimit = 64 * 3 - } - -mkClosedError :: HasCallStack => SomeHasFS m -> String -> FsError -mkClosedError (SomeHasFS hasFS) loc = FS.ioToFsError (FS.mkFsErrorPath hasFS (FS.mkFsPath [])) ioerr - where ioerr = - ioeSetErrorString - (mkIOError ResourceVanished loc Nothing Nothing) - ("HasBlockIO closed: " <> loc) - - data IOOp s h = IOOpRead !(Handle h) !FileOffset !(MutableByteArray s) !BufferOffset !ByteCount | IOOpWrite !(Handle h) !FileOffset !(MutableByteArray s) !BufferOffset !ByteCount @@ -231,7 +220,7 @@ instance VUM.Unbox IOResult Advice -------------------------------------------------------------------------------} --- | Basically "System.Posix.Fcntl.Advice" from the @unix@ package +-- | Copy of "System.Posix.Fcntl.Advice" from the @unix@ package data Advice = AdviceNormal | AdviceRandom @@ -255,7 +244,7 @@ hDropCacheAll hbio h = hAdviseAll hbio h AdviceDontNeed -------------------------------------------------------------------------------} {-# SPECIALISE synchroniseFile :: HasFS IO h -> HasBlockIO IO h -> FsPath -> IO () #-} --- | Synchronise a file and its contents with the storage device. +-- | Synchronise a file's contents and metadata with the storage device. synchroniseFile :: MonadThrow m => HasFS m h -> HasBlockIO m h -> FsPath -> m () synchroniseFile hfs hbio path = FS.withFile hfs path (FS.ReadWriteMode FS.MustExist) $ hSynchronise hbio @@ -266,8 +255,8 @@ synchroniseFile hfs hbio path = -> FsPath -> IO () #-} --- | Synchronise a directory and recursively its contents with the storage --- device. +-- | Synchronise a directory's contents and metadata with the storage device, +-- and recursively for all entries in the directory. synchroniseDirectoryRecursive :: MonadThrow m => HasFS m h @@ -300,42 +289,3 @@ newtype LockFileHandle m = LockFileHandle { -- | Release a file lock acquired using 'tryLockFile'. hUnlock :: m () } - -tryLockFileIO :: HasFS IO HandleIO -> FsPath -> GHC.LockMode -> IO (Maybe (LockFileHandle IO)) -tryLockFileIO hfs fsp mode = do - fp <- FS.unsafeToFilePath hfs fsp -- shouldn't fail because we are in IO - rethrowFsErrorIO hfs fsp $ - bracketOnError (GHC.openFile fp GHC.WriteMode) GHC.hClose $ \h -> do - bracketOnError (GHC.hTryLock h mode) (\_ -> GHC.hUnlock h) $ \b -> do - if b then - pure $ Just LockFileHandle { hUnlock = rethrowFsErrorIO hfs fsp $ do - GHC.hUnlock h - `finally` GHC.hClose h - } - else - pure $ Nothing - --- This is copied/adapted from System.FS.IO -rethrowFsErrorIO :: HasCallStack => HasFS IO HandleIO -> FsPath -> IO a -> IO a -rethrowFsErrorIO hfs fp action = do - res <- try action - case res of - Left err -> handleError err - Right a -> pure a - where - handleError :: HasCallStack => IOError -> IO a - handleError ioErr = - throwIO $ FS.ioToFsError (FS.mkFsErrorPath hfs fp) ioErr - -{------------------------------------------------------------------------------- - Hard links --------------------------------------------------------------------------------} - -createHardLinkIO :: - HasFS IO HandleIO - -> (FilePath -> FilePath -> IO ()) - -> (FsPath -> FsPath -> IO ()) -createHardLinkIO hfs f = \source target -> do - source' <- FS.unsafeToFilePath hfs source -- shouldn't fail because we are in IO - target' <- FS.unsafeToFilePath hfs target -- shouldn't fail because we are in IO - f source' target' diff --git a/blockio/src/System/FS/BlockIO/IO.hs b/blockio/src/System/FS/BlockIO/IO.hs index 79e78c705..0b798cadc 100644 --- a/blockio/src/System/FS/BlockIO/IO.hs +++ b/blockio/src/System/FS/BlockIO/IO.hs @@ -1,25 +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.BlockIO.API (HasBlockIO (..), IOCtxParams) +import System.FS.API (HasFS, MountPoint) +import System.FS.BlockIO.API (HasBlockIO (..)) import qualified System.FS.BlockIO.Internal as I -import System.FS.IO (HandleIO) +import qualified System.FS.BlockIO.IO.Internal as IOI +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 - -> IOCtxParams + -> 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 - -> IOCtxParams + -> 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) diff --git a/blockio/src/System/FS/BlockIO/IO/Internal.hs b/blockio/src/System/FS/BlockIO/IO/Internal.hs new file mode 100644 index 000000000..dc83f3cf2 --- /dev/null +++ b/blockio/src/System/FS/BlockIO/IO/Internal.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UnboxedTuples #-} + +module System.FS.BlockIO.IO.Internal ( + IOCtxParams (..) + , defaultIOCtxParams + , mkClosedError + , tryLockFileIO + , createHardLinkIO + ) where + +import Control.DeepSeq (NFData (..)) +import Control.Monad.Class.MonadThrow (MonadCatch (bracketOnError), + MonadThrow (..), bracketOnError, try) +import GHC.IO.Exception (IOErrorType (ResourceVanished)) +import qualified GHC.IO.Handle.Lock as GHC +import GHC.Stack (HasCallStack) +import qualified System.FS.API as FS +import System.FS.API (FsError (..), FsPath, HasFS, SomeHasFS (..)) +import System.FS.BlockIO.API (LockFileHandle (..)) +import System.FS.IO (HandleIO) +import qualified System.IO as GHC +import System.IO.Error (ioeSetErrorString, mkIOError) + +{------------------------------------------------------------------------------- + IO context +-------------------------------------------------------------------------------} + +-- | Concurrency parameters for initialising the 'IO' context in a 'HasBlockIO' +-- instance. +-- +-- [IO context parameters]: These parameters are interpreted differently based +-- on the underlying platform: +-- +-- * Linux: Pass the parameters to 'initIOCtx' in the @blockio-uring@ package +-- * MacOS: Ignore the parameters +-- * Windows: Ignore the parameters +-- +-- For more information about what these parameters mean and how to configure +-- them, see the @blockio-uring@ package. +data IOCtxParams = IOCtxParams { + ioctxBatchSizeLimit :: !Int, + ioctxConcurrencyLimit :: !Int + } + +instance NFData IOCtxParams where + rnf (IOCtxParams x y) = rnf x `seq` rnf y + +-- | Default parameters. Some manual tuning of parameters might be required to +-- achieve higher performance targets (see 'IOCtxParams'). +defaultIOCtxParams :: IOCtxParams +defaultIOCtxParams = IOCtxParams { + ioctxBatchSizeLimit = 64, + ioctxConcurrencyLimit = 64 * 3 + } + +mkClosedError :: HasCallStack => SomeHasFS m -> String -> FsError +mkClosedError (SomeHasFS hasFS) loc = FS.ioToFsError (FS.mkFsErrorPath hasFS (FS.mkFsPath [])) ioerr + where ioerr = + ioeSetErrorString + (mkIOError ResourceVanished loc Nothing Nothing) + ("HasBlockIO closed: " <> loc) + +{------------------------------------------------------------------------------- + File locks +-------------------------------------------------------------------------------} + +tryLockFileIO :: HasFS IO HandleIO -> FsPath -> GHC.LockMode -> IO (Maybe (LockFileHandle IO)) +tryLockFileIO hfs fsp mode = do + fp <- FS.unsafeToFilePath hfs fsp -- shouldn't fail because we are in IO + rethrowFsErrorIO hfs fsp $ + bracketOnError (GHC.openFile fp GHC.WriteMode) GHC.hClose $ \h -> do + bracketOnError (GHC.hTryLock h mode) (\_ -> GHC.hUnlock h) $ \b -> do + if b then + pure $ Just LockFileHandle { hUnlock = rethrowFsErrorIO hfs fsp $ do + GHC.hUnlock h + `finally` GHC.hClose h + } + else + pure $ Nothing + +-- This is copied/adapted from System.FS.IO +rethrowFsErrorIO :: HasCallStack => HasFS IO HandleIO -> FsPath -> IO a -> IO a +rethrowFsErrorIO hfs fp action = do + res <- try action + case res of + Left err -> handleError err + Right a -> pure a + where + handleError :: HasCallStack => IOError -> IO a + handleError ioErr = + throwIO $ FS.ioToFsError (FS.mkFsErrorPath hfs fp) ioErr + +{------------------------------------------------------------------------------- + Hard links +-------------------------------------------------------------------------------} + +createHardLinkIO :: + HasFS IO HandleIO + -> (FilePath -> FilePath -> IO ()) + -> (FsPath -> FsPath -> IO ()) +createHardLinkIO hfs f = \source target -> do + source' <- FS.unsafeToFilePath hfs source -- shouldn't fail because we are in IO + target' <- FS.unsafeToFilePath hfs target -- shouldn't fail because we are in IO + f source' target' diff --git a/blockio/src/System/FS/BlockIO/Serial.hs b/blockio/src/System/FS/BlockIO/Serial.hs index c8d75019c..a6276ca7e 100644 --- a/blockio/src/System/FS/BlockIO/Serial.hs +++ b/blockio/src/System/FS/BlockIO/Serial.hs @@ -13,6 +13,7 @@ import GHC.Stack (HasCallStack) import System.FS.API import qualified System.FS.BlockIO.API as API import System.FS.BlockIO.API (IOOp (..), IOResult (..), LockMode (..)) +import qualified System.FS.BlockIO.IO.Internal as IOI {-# SPECIALISE serialHasBlockIO :: Eq h @@ -58,7 +59,7 @@ data IOCtx m = IOCtx { ctxFS :: SomeHasFS m, openVar :: MVar m Bool } {-# SPECIALISE guardIsOpen :: IOCtx IO -> IO () #-} guardIsOpen :: (HasCallStack, MonadMVar m, MonadThrow m) => IOCtx m -> m () guardIsOpen ctx = readMVar (openVar ctx) >>= \b -> - unless b $ throwIO (API.mkClosedError (ctxFS ctx) "submitIO") + unless b $ throwIO (IOI.mkClosedError (ctxFS ctx) "submitIO") {-# SPECIALISE initIOCtx :: SomeHasFS IO -> IO (IOCtx IO) #-} initIOCtx :: MonadMVar m => SomeHasFS m -> m (IOCtx m) diff --git a/blockio/src/System/FS/BlockIO/Serial/Internal.hs b/blockio/src/System/FS/BlockIO/Serial/Internal.hs new file mode 100644 index 000000000..a0a968af9 --- /dev/null +++ b/blockio/src/System/FS/BlockIO/Serial/Internal.hs @@ -0,0 +1,12 @@ +-- | This is an internal module that has to be exposed for technical reasons. Do +-- not use it. +module System.FS.BlockIO.Serial.Internal ( + -- We have to re-export from somewhere so that the @blockio:sim@ sub-library + -- can use it. Unfortunately, this makes the function part of the public API + -- even though we'd prefer to keep it truly hidden. There are ways around + -- this, for example using a new private sub-library that contains the + -- "System.FS.BlockIO.Serial" module, but it's a lot of boilerplate. + serialHasBlockIO + ) where + +import System.FS.BlockIO.Serial (serialHasBlockIO) diff --git a/blockio/test/Main.hs b/blockio/test/Main.hs index 537be7052..452b7748f 100644 --- a/blockio/test/Main.hs +++ b/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 FS.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 FS.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 FS.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 FS.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 diff --git a/lsm-tree.cabal b/lsm-tree.cabal index 16976fc28..9aef05bb2 100644 --- a/lsm-tree.cabal +++ b/lsm-tree.cabal @@ -613,7 +613,7 @@ library , bytestring ^>=0.11.4.0 || ^>=0.12.1.0 , cborg ^>=0.2.10.0 , containers ^>=0.6 || ^>=0.7 - , contra-tracer ^>=0.2 + , contra-tracer ^>=0.1 || ^>=0.2 , crc32c ^>=0.2.1 , deepseq ^>=1.4 || ^>=1.5 , filepath diff --git a/src/Database/LSMTree.hs b/src/Database/LSMTree.hs index 25495f1f5..988c6ed54 100644 --- a/src/Database/LSMTree.hs +++ b/src/Database/LSMTree.hs @@ -274,9 +274,10 @@ import Database.LSMTree.Internal.Unsafe (BlobRefInvalidError (..), import qualified Database.LSMTree.Internal.Unsafe as Internal import Prelude hiding (lookup, take, takeWhile) import System.FS.API (FsPath, HasFS (..), MountPoint (..), mkFsPath) -import System.FS.BlockIO.API (HasBlockIO (..), defaultIOCtxParams) -import System.FS.BlockIO.IO (ioHasBlockIO, withIOHasBlockIO) -import System.FS.IO (HandleIO, ioHasFS) +import System.FS.BlockIO.API (HasBlockIO (..)) +import System.FS.BlockIO.IO (defaultIOCtxParams, ioHasBlockIO, + withIOHasBlockIO) +import System.FS.IO (HandleIO) import System.Random (randomIO) -------------------------------------------------------------------------------- @@ -471,9 +472,8 @@ withOpenSessionIO :: withOpenSessionIO tracer sessionDir action = do let mountPoint = MountPoint sessionDir let sessionDirFsPath = mkFsPath [] - let hasFS = ioHasFS mountPoint sessionSalt <- randomIO - withIOHasBlockIO hasFS defaultIOCtxParams $ \hasBlockIO -> + withIOHasBlockIO mountPoint defaultIOCtxParams $ \hasFS hasBlockIO -> withOpenSession tracer hasFS hasBlockIO sessionSalt sessionDirFsPath action {- | @@ -631,11 +631,10 @@ openSessionIO :: openSessionIO tracer sessionDir = do let mountPoint = MountPoint sessionDir let sessionDirFsPath = mkFsPath [] - let hasFS = ioHasFS mountPoint sessionSalt <- randomIO - let acquireHasBlockIO = ioHasBlockIO hasFS defaultIOCtxParams - let releaseHasBlockIO HasBlockIO{close} = close - bracketOnError acquireHasBlockIO releaseHasBlockIO $ \hasBlockIO -> + let acq = ioHasBlockIO mountPoint defaultIOCtxParams + let rel (_, HasBlockIO{close}) = close + bracketOnError acq rel $ \(hasFS, hasBlockIO) -> openSession tracer hasFS hasBlockIO sessionSalt sessionDirFsPath {- | diff --git a/src/Database/LSMTree/Internal/Unsafe.hs b/src/Database/LSMTree/Internal/Unsafe.hs index 588b4a247..e6b55d370 100644 --- a/src/Database/LSMTree/Internal/Unsafe.hs +++ b/src/Database/LSMTree/Internal/Unsafe.hs @@ -315,12 +315,19 @@ data TableTrace = #endif deriving stock Show -contramapTraceMerge :: Monad m => Tracer m TableTrace -> Tracer m (AtLevel MergeTrace) +contramapTraceMerge :: forall m. Monad m => Tracer m TableTrace -> Tracer m (AtLevel MergeTrace) +#if MIN_VERSION_contra_tracer(0,2,0) #ifdef DEBUG_TRACES contramapTraceMerge t = TraceMerge `contramap` t #else contramapTraceMerge t = traceMaybe (const Nothing) t #endif +#else +contramapTraceMerge _t = nullTracer + where + -- See #766 + _unused = pure @m () +#endif -- | Trace messages related to cursors. data CursorTrace = diff --git a/test/Test/Database/LSMTree/Internal/Merge.hs b/test/Test/Database/LSMTree/Internal/Merge.hs index 7dbca8c1d..da72e6c18 100644 --- a/test/Test/Database/LSMTree/Internal/Merge.hs +++ b/test/Test/Database/LSMTree/Internal/Merge.hs @@ -51,10 +51,7 @@ tests = testGroup "Test.Database.LSMTree.Internal.Merge" => (FS.HasFS IO FsSim.HandleMock -> FS.HasBlockIO IO FsSim.HandleMock -> IO p) -> Property ioPropertyWithMockFS prop = ioProperty $ do - (res, mockFS) <- - FsSim.runSimErrorFS FsSim.empty FsSim.emptyErrors $ \_ fs -> do - hbio <- FsSim.fromHasFS fs - prop fs hbio + (res, mockFS, _) <- FsSim.runSimErrorHasBlockIO FsSim.empty FsSim.emptyErrors prop pure $ res .&&. counterexample "open handles" (FsSim.numOpenHandles mockFS === 0) diff --git a/test/Test/Database/LSMTree/Internal/Readers.hs b/test/Test/Database/LSMTree/Internal/Readers.hs index cc8b8b247..22750eba1 100644 --- a/test/Test/Database/LSMTree/Internal/Readers.hs +++ b/test/Test/Database/LSMTree/Internal/Readers.hs @@ -39,7 +39,6 @@ import qualified System.FS.API as FS import qualified System.FS.BlockIO.API as FS import qualified System.FS.BlockIO.Sim as FsSim import qualified System.FS.Sim.MockFS as MockFS -import qualified System.FS.Sim.STM as FsSim import qualified Test.QuickCheck as QC import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck @@ -55,8 +54,7 @@ tests = testGroup "Database.LSMTree.Internal.Readers" [ testProperty "prop_lockstep" $ Lockstep.runActionsBracket (Proxy @ReadersState) mempty mempty $ \act () -> do - (prop, mockFS) <- FsSim.runSimFS MockFS.empty $ \hfs -> do - hbio <- FsSim.fromHasFS hfs + (prop, mockFS) <- FsSim.runSimHasBlockIO MockFS.empty $ \hfs hbio -> do (prop, RealState _ mCtx) <- runRealMonad hfs hbio (RealState 0 Nothing) act traverse_ closeReadersCtx mCtx -- close current readers diff --git a/test/Test/Database/LSMTree/Internal/Run.hs b/test/Test/Database/LSMTree/Internal/Run.hs index b703b037f..3056df92a 100644 --- a/test/Test/Database/LSMTree/Internal/Run.hs +++ b/test/Test/Database/LSMTree/Internal/Run.hs @@ -39,7 +39,6 @@ import qualified System.FS.API as FS import qualified System.FS.API.Lazy as FSL import qualified System.FS.BlockIO.API as FS import qualified System.FS.BlockIO.IO as FS -import qualified System.FS.IO as FsIO import qualified System.FS.Sim.MockFS as MockFS import qualified System.IO.Temp as Temp import Test.Database.LSMTree.Internal.RunReader (readKOps) @@ -105,8 +104,7 @@ testSalt = 4 -- | Runs in IO, with a real file system. testSingleInsert :: FilePath -> SerialisedKey -> SerialisedValue -> Maybe SerialisedBlob -> IO () testSingleInsert sessionRoot key val mblob = - let fs = FsIO.ioHasFS (FS.MountPoint sessionRoot) in - FS.withIOHasBlockIO fs FS.defaultIOCtxParams $ \hbio -> do + FS.withIOHasBlockIO (FS.MountPoint sessionRoot) FS.defaultIOCtxParams $ \fs hbio -> do -- flush write buffer let e = case mblob of Nothing -> Insert val; Just blob -> InsertWithBlob val blob wb = Map.singleton key e diff --git a/test/Test/Database/LSMTree/StateMachine.hs b/test/Test/Database/LSMTree/StateMachine.hs index 0024524e5..b8814a354 100644 --- a/test/Test/Database/LSMTree/StateMachine.hs +++ b/test/Test/Database/LSMTree/StateMachine.hs @@ -105,9 +105,9 @@ import NoThunks.Class import Prelude hiding (init) import System.Directory (removeDirectoryRecursive) import System.FS.API (FsError (..), HasFS, MountPoint (..), mkFsPath) -import System.FS.BlockIO.API (HasBlockIO, close, defaultIOCtxParams) -import System.FS.BlockIO.IO (ioHasBlockIO) -import System.FS.IO (HandleIO, ioHasFS) +import System.FS.BlockIO.API (HasBlockIO, close) +import System.FS.BlockIO.IO (defaultIOCtxParams, ioHasBlockIO) +import System.FS.IO (HandleIO) import qualified System.FS.Sim.Error as FSSim import System.FS.Sim.Error (Errors) import qualified System.FS.Sim.MockFS as MockFS @@ -469,8 +469,7 @@ createSystemTempDirectory :: [Char] -> IO (FilePath, HasFS IO HandleIO, HasBloc createSystemTempDirectory prefix = do systemTempDir <- getCanonicalTemporaryDirectory tempDir <- createTempDirectory systemTempDir prefix - let hasFS = ioHasFS (MountPoint tempDir) - hasBlockIO <- ioHasBlockIO hasFS defaultIOCtxParams + (hasFS, hasBlockIO) <- ioHasBlockIO (MountPoint tempDir) defaultIOCtxParams pure (tempDir, hasFS, hasBlockIO) {------------------------------------------------------------------------------- diff --git a/test/Test/Util/FS.hs b/test/Test/Util/FS.hs index 384fd9b00..3a89d9855 100644 --- a/test/Test/Util/FS.hs +++ b/test/Test/Util/FS.hs @@ -74,8 +74,8 @@ import GHC.Stack import System.FS.API as FS import qualified System.FS.API.Lazy as FSL import System.FS.BlockIO.API -import System.FS.BlockIO.IO -import System.FS.BlockIO.Sim (fromHasFS) +import System.FS.BlockIO.IO hiding (unsafeFromHasFS) +import System.FS.BlockIO.Sim (unsafeFromHasFS) import System.FS.IO import System.FS.Sim.Error import System.FS.Sim.MockFS (HandleMock, MockFS, numOpenHandles, @@ -99,9 +99,8 @@ withTempIOHasFS path action = withSystemTempDirectory path $ \dir -> do 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 + withIOHasBlockIO (MountPoint dir) defaultIOCtxParams action {------------------------------------------------------------------------------- Simulated file system @@ -137,7 +136,7 @@ withSimHasBlockIO :: -> m Property withSimHasBlockIO post fs k = do withSimHasFS post fs $ \hfs fsVar -> do - hbio <- fromHasFS hfs + hbio <- unsafeFromHasFS hfs k hfs hbio fsVar {------------------------------------------------------------------------------- @@ -181,7 +180,7 @@ withSimErrorHasBlockIO :: -> m Property withSimErrorHasBlockIO post fs errs k = withSimErrorHasFS post fs errs $ \hfs fsVar errsVar -> do - hbio <- fromHasFS hfs + hbio <- unsafeFromHasFS hfs k hfs hbio fsVar errsVar {------------------------------------------------------------------------------- diff --git a/test/Test/Util/FS/Error.hs b/test/Test/Util/FS/Error.hs index 22b798237..4f9632dd5 100644 --- a/test/Test/Util/FS/Error.hs +++ b/test/Test/Util/FS/Error.hs @@ -114,7 +114,7 @@ simErrorHasBlockIOLogged :: -> m (HasFS m HandleMock, HasBlockIO m HandleMock) simErrorHasBlockIOLogged fsVar errorsVar logVar = do let hfs = simErrorHasFSLogged fsVar errorsVar logVar - hbio <- fromHasFS hfs + hbio <- unsafeFromHasFS hfs pure (hfs, hbio) -- | Produce a simulated file system with injected errors and a logger for those