diff --git a/README.md b/README.md index 8456377d4..c1e75dea9 100644 --- a/README.md +++ b/README.md @@ -26,7 +26,8 @@ key-value store. ## System requirements -This library only supports 64-bit, little-endian systems. +This library only supports 64-bit, little-endian systems. On Windows, the +library only works probably on drives with NTFS. Provide the -threaded flag to executables, test suites and benchmark suites if you use this library on Linux systems. diff --git a/blockio-api/src-linux/System/FS/BlockIO/Async.hs b/blockio-api/src-linux/System/FS/BlockIO/Async.hs index 17b9543d0..3edfc300d 100644 --- a/blockio-api/src-linux/System/FS/BlockIO/Async.hs +++ b/blockio-api/src-linux/System/FS/BlockIO/Async.hs @@ -32,10 +32,13 @@ asyncHasBlockIO :: -> (Handle HandleIO -> FileOffset -> FileOffset -> API.Advice -> IO ()) -> (Handle HandleIO -> FileOffset -> FileOffset -> IO ()) -> (FsPath -> LockMode -> IO (Maybe (API.LockFileHandle IO))) + -> (Handle HandleIO -> IO ()) + -> (FsPath -> IO ()) + -> (FsPath -> FsPath -> IO ()) -> HasFS IO HandleIO -> API.IOCtxParams -> IO (API.HasBlockIO IO HandleIO) -asyncHasBlockIO hSetNoCache hAdvise hAllocate tryLockFile hasFS ctxParams = do +asyncHasBlockIO hSetNoCache hAdvise hAllocate tryLockFile hSynchronise synchroniseDirectory createHardLink hasFS ctxParams = do ctx <- I.initIOCtx (ctxParamsConv ctxParams) pure $ API.HasBlockIO { API.close = I.closeIOCtx ctx @@ -44,6 +47,9 @@ asyncHasBlockIO hSetNoCache hAdvise hAllocate tryLockFile hasFS ctxParams = do , API.hAdvise , API.hAllocate , API.tryLockFile + , API.hSynchronise + , API.synchroniseDirectory + , API.createHardLink } ctxParamsConv :: API.IOCtxParams -> I.IOCtxParams @@ -110,11 +116,18 @@ ioopConv (IOOpWrite h off buf bufOff c) = handleFd h >>= \fd -> -- -- 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 +-- only allows mutually 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 +{-# SPECIALISE hzipWithM :: + (VUM.Unbox b, VUM.Unbox c) + => (a -> b -> IO c) + -> V.Vector a + -> VU.Vector b + -> IO (VU.Vector c) + #-} -- | Heterogeneous blend of `V.zipWithM` and `VU.zipWithM` -- -- The @vector@ package does not provide functions that take distinct vector diff --git a/blockio-api/src-linux/System/FS/BlockIO/Internal.hs b/blockio-api/src-linux/System/FS/BlockIO/Internal.hs index 9f188a84b..5c5202e8a 100644 --- a/blockio-api/src-linux/System/FS/BlockIO/Internal.hs +++ b/blockio-api/src-linux/System/FS/BlockIO/Internal.hs @@ -4,7 +4,8 @@ module System.FS.BlockIO.Internal ( ioHasBlockIO ) where -import System.FS.API (Handle (..), HasFS) +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) @@ -12,6 +13,8 @@ import System.FS.IO (HandleIO) import qualified System.FS.IO.Handle as FS import qualified System.Posix.Fcntl as Fcntl import qualified System.Posix.Fcntl.NoCache as Unix +import qualified System.Posix.Files as Unix +import qualified System.Posix.Unistd as Unix #if SERIALBLOCKIO import qualified System.FS.BlockIO.Serial as Serial @@ -24,9 +27,28 @@ ioHasBlockIO :: -> IOCtxParams -> IO (HasBlockIO IO HandleIO) #if SERIALBLOCKIO -ioHasBlockIO hfs _params = Serial.serialHasBlockIO hSetNoCache hAdvise hAllocate (FS.tryLockFileIO hfs) hfs +ioHasBlockIO hfs _params = + Serial.serialHasBlockIO + hSetNoCache + hAdvise + hAllocate + (FS.tryLockFileIO hfs) + hSynchronise + (synchroniseDirectory hfs) + (FS.createHardLinkIO hfs Unix.createLink) + hfs #else -ioHasBlockIO hfs params = Async.asyncHasBlockIO hSetNoCache hAdvise hAllocate (FS.tryLockFileIO hfs) hfs params +ioHasBlockIO hfs params = + Async.asyncHasBlockIO + hSetNoCache + hAdvise + hAllocate + (FS.tryLockFileIO hfs) + hSynchronise + (synchroniseDirectory hfs) + (FS.createHardLinkIO hfs Unix.createLink) + hfs + params #endif hSetNoCache :: Handle HandleIO -> Bool -> IO () @@ -48,3 +70,11 @@ hAdvise h off len advice = FS.withOpenHandle "hAdvise" (handleRaw h) $ \fd -> hAllocate :: Handle HandleIO -> FileOffset -> FileOffset -> IO () hAllocate h off len = FS.withOpenHandle "hAllocate" (handleRaw h) $ \fd -> Fcntl.fileAllocate fd off len + +hSynchronise :: Handle HandleIO -> IO () +hSynchronise h = FS.withOpenHandle "hSynchronise" (handleRaw h) $ \fd -> + Unix.fileSynchronise fd + +synchroniseDirectory :: HasFS IO HandleIO -> FsPath -> IO () +synchroniseDirectory hfs path = + FS.withFile hfs path FS.ReadMode $ hSynchronise diff --git a/blockio-api/src-macos/System/FS/BlockIO/Internal.hs b/blockio-api/src-macos/System/FS/BlockIO/Internal.hs index 50370b372..f7e2e86d3 100644 --- a/blockio-api/src-macos/System/FS/BlockIO/Internal.hs +++ b/blockio-api/src-macos/System/FS/BlockIO/Internal.hs @@ -2,7 +2,8 @@ module System.FS.BlockIO.Internal ( ioHasBlockIO ) where -import System.FS.API (Handle (..), HasFS) +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) @@ -10,6 +11,8 @@ import qualified System.FS.BlockIO.Serial as Serial import System.FS.IO (HandleIO) import qualified System.FS.IO.Handle as FS import qualified System.Posix.Fcntl.NoCache as Unix +import qualified System.Posix.Files as Unix +import qualified System.Posix.Unistd as Unix -- | 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 @@ -20,7 +23,16 @@ ioHasBlockIO :: HasFS IO HandleIO -> IOCtxParams -> IO (HasBlockIO IO HandleIO) -ioHasBlockIO hfs _params = Serial.serialHasBlockIO hSetNoCache hAdvise hAllocate (FS.tryLockFileIO hfs) hfs +ioHasBlockIO hfs _params = + Serial.serialHasBlockIO + hSetNoCache + hAdvise + hAllocate + (FS.tryLockFileIO hfs) + hSynchronise + (synchroniseDirectory hfs) + (FS.createHardLinkIO hfs Unix.createLink) + hfs hSetNoCache :: Handle HandleIO -> Bool -> IO () hSetNoCache h b = @@ -34,3 +46,11 @@ hAdvise _h _off _len _advice = pure () hAllocate :: Handle HandleIO -> FileOffset -> FileOffset -> IO () hAllocate _h _off _len = pure () + +hSynchronise :: Handle HandleIO -> IO () +hSynchronise h = FS.withOpenHandle "hSynchronise" (handleRaw h) $ \fd -> + Unix.fileSynchronise fd + +synchroniseDirectory :: HasFS IO HandleIO -> FsPath -> IO () +synchroniseDirectory hfs path = + FS.withFile hfs path FS.ReadMode $ hSynchronise diff --git a/blockio-api/src-windows/System/FS/BlockIO/Internal.hs b/blockio-api/src-windows/System/FS/BlockIO/Internal.hs index 243967f88..1b40dc86b 100644 --- a/blockio-api/src-windows/System/FS/BlockIO/Internal.hs +++ b/blockio-api/src-windows/System/FS/BlockIO/Internal.hs @@ -2,12 +2,20 @@ module System.FS.BlockIO.Internal ( ioHasBlockIO ) where -import System.FS.API (Handle (..), HasFS) +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 qualified System.FS.BlockIO.Serial as Serial import System.FS.IO (HandleIO) +import qualified System.FS.IO.Handle as FS +import System.IO.Error (doesNotExistErrorType, ioeSetErrorString, + mkIOError) +import qualified System.Win32.File as Windows +import qualified System.Win32.HardLink as Windows -- | 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 @@ -18,7 +26,16 @@ ioHasBlockIO :: HasFS IO HandleIO -> IOCtxParams -> IO (HasBlockIO IO HandleIO) -ioHasBlockIO hfs _params = Serial.serialHasBlockIO hSetNoCache hAdvise hAllocate (FS.tryLockFileIO hfs) hfs +ioHasBlockIO hfs _params = + Serial.serialHasBlockIO + hSetNoCache + hAdvise + hAllocate + (FS.tryLockFileIO hfs) + hSynchronise + (synchroniseDirectory hfs) + (FS.createHardLinkIO hfs Windows.createHardLink) + hfs hSetNoCache :: Handle HandleIO -> Bool -> IO () hSetNoCache _h _b = pure () @@ -28,3 +45,18 @@ hAdvise _h _off _len _advice = pure () hAllocate :: Handle HandleIO -> FileOffset -> FileOffset -> IO () hAllocate _h _off _len = pure () + +hSynchronise :: Handle HandleIO -> IO () +hSynchronise h = FS.withOpenHandle "hAdvise" (handleRaw h) $ \fd -> + Windows.flushFileBuffers fd + +synchroniseDirectory :: HasFS IO HandleIO -> FsPath -> IO () +synchroniseDirectory hfs path = do + b <- FS.doesDirectoryExist hfs path + unless b $ + throwIO $ FS.ioToFsError (FS.mkFsErrorPath hfs (FS.mkFsPath [])) ioerr + where + ioerr = + ioeSetErrorString + (mkIOError doesNotExistErrorType "synchroniseDirectory" Nothing Nothing) + ("synchroniseDirectory: directory does not exist") diff --git a/blockio-api/src/System/FS/BlockIO/API.hs b/blockio-api/src/System/FS/BlockIO/API.hs index bcd9cf0f3..4d85bb5b8 100644 --- a/blockio-api/src/System/FS/BlockIO/API.hs +++ b/blockio-api/src/System/FS/BlockIO/API.hs @@ -8,6 +8,7 @@ {-# LANGUAGE UnboxedTuples #-} module System.FS.BlockIO.API ( + -- * HasBlockIO HasBlockIO (..) , IOCtxParams (..) , defaultIOCtxParams @@ -19,15 +20,19 @@ module System.FS.BlockIO.API ( , ioopBufferOffset , ioopByteCount , IOResult (..) - -- * Advice + -- ** Advice , Advice (..) , hAdviseAll , hDropCacheAll - -- * File locks + -- ** File locks , GHC.LockMode (..) , GHC.FileLockingNotSupported (..) , LockFileHandle (..) + -- ** Storage synchronisation + , synchroniseFile + -- * Defaults for the real file system , tryLockFileIO + , createHardLinkIO -- * Re-exports , ByteCount , FileOffset @@ -52,7 +57,8 @@ 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.IO.Error (doesNotExistErrorType, ioeSetErrorString, + mkIOError) import System.Posix.Types (ByteCount, FileOffset) -- | Abstract interface for submitting large batches of I\/O operations. @@ -125,12 +131,42 @@ data HasBlockIO m h = HasBlockIO { -- limited scope. That is, it has to fit the style of @withHandleToHANDLE :: -- Handle -> (HANDLE -> IO a) -> IO a@ from the @Win32@ package. , 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 transfered/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 + , 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 () } instance NFData (HasBlockIO m h) where - rnf (HasBlockIO a b c d e f) = + rnf (HasBlockIO a b c d e f g h i) = rwhnf a `seq` rwhnf b `seq` rnf c `seq` - rwhnf d `seq` rwhnf e `seq` rwhnf f + 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. @@ -195,6 +231,10 @@ deriving via (VU.UnboxViaPrim IOResult) instance VG.Vector VU.Vector IOResult instance VUM.Unbox IOResult +{------------------------------------------------------------------------------- + Advice +-------------------------------------------------------------------------------} + -- | Basically "System.Posix.Fcntl.Advice" from the @unix@ package data Advice = AdviceNormal @@ -214,6 +254,36 @@ hAdviseAll hbio h advice = hAdvise hbio h 0 0 advice -- len=0 implies until the hDropCacheAll :: HasBlockIO m h -> Handle h -> m () hDropCacheAll hbio h = hAdviseAll hbio h AdviceDontNeed +{------------------------------------------------------------------------------- + Storage synchronisation +-------------------------------------------------------------------------------} + +-- TODO: currently, we perform an explicit check to see if the file exists and +-- throw an error when it does not exist. We would prefer to be able to rely on +-- withFile to throw an error for us that we could rethrow with an upated +-- description/location. Unfortunately, we have to open te file in ReadWriteMode +-- on Windows, and withFile currently does not support such errors. The only +-- options are: +-- +-- * AllowExisting: silently create a file if it does not exist +-- * MustBeNew: throw an error if the file exists +-- +-- We would need to add a third option to fs-api: +-- +-- * MustExist: throw an error if the file *does not* exist +synchroniseFile :: MonadThrow m => HasFS m h -> HasBlockIO m h -> FsPath -> m () +synchroniseFile hfs hbio path = do + b <- FS.doesFileExist hfs path + if b then + FS.withFile hfs path (FS.ReadWriteMode FS.AllowExisting) $ hSynchronise hbio + else + throwIO $ FS.ioToFsError (FS.mkFsErrorPath hfs (FS.mkFsPath [])) ioerr + where + ioerr = + ioeSetErrorString + (mkIOError doesNotExistErrorType "synchroniseFile" Nothing Nothing) + ("synchroniseFile: file does not exist") + {------------------------------------------------------------------------------- File locks -------------------------------------------------------------------------------} @@ -249,3 +319,16 @@ rethrowFsErrorIO hfs fp action = do 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-api/src/System/FS/BlockIO/Serial.hs b/blockio-api/src/System/FS/BlockIO/Serial.hs index fcdda2c57..08f6c1914 100644 --- a/blockio-api/src/System/FS/BlockIO/Serial.hs +++ b/blockio-api/src/System/FS/BlockIO/Serial.hs @@ -8,7 +8,7 @@ module System.FS.BlockIO.Serial ( import Control.Concurrent.Class.MonadMVar import Control.Monad (unless) import Control.Monad.Class.MonadThrow -import Control.Monad.Primitive (PrimMonad, PrimState) +import Control.Monad.Primitive (PrimMonad, PrimState, RealWorld) import qualified Data.Vector as V import qualified Data.Vector.Unboxed as VU import qualified Data.Vector.Unboxed.Mutable as VUM @@ -16,6 +16,18 @@ import System.FS.API import qualified System.FS.BlockIO.API as API import System.FS.BlockIO.API (IOOp (..), IOResult (..), LockMode (..)) +{-# SPECIALISE serialHasBlockIO :: + Eq h + => (Handle h -> Bool -> IO ()) + -> (Handle h -> API.FileOffset -> API.FileOffset -> API.Advice -> IO ()) + -> (Handle h -> API.FileOffset -> API.FileOffset -> IO ()) + -> (FsPath -> LockMode -> IO (Maybe (API.LockFileHandle IO))) + -> (Handle h -> IO ()) + -> (FsPath -> IO ()) + -> (FsPath -> FsPath -> IO ()) + -> HasFS IO h + -> IO (API.HasBlockIO IO h) + #-} -- | IO instantiation of 'HasBlockIO', using an existing 'HasFS'. Thus this -- implementation does not take advantage of parallel I/O. serialHasBlockIO :: @@ -24,9 +36,12 @@ serialHasBlockIO :: -> (Handle h -> API.FileOffset -> API.FileOffset -> API.Advice -> m ()) -> (Handle h -> API.FileOffset -> API.FileOffset -> m ()) -> (FsPath -> LockMode -> m (Maybe (API.LockFileHandle m))) + -> (Handle h -> m ()) + -> (FsPath -> m ()) + -> (FsPath -> FsPath -> m ()) -> HasFS m h -> m (API.HasBlockIO m h) -serialHasBlockIO hSetNoCache hAdvise hAllocate tryLockFile hfs = do +serialHasBlockIO hSetNoCache hAdvise hAllocate tryLockFile hSynchronise synchroniseDirectory createHardLink hfs = do ctx <- initIOCtx (SomeHasFS hfs) pure $ API.HasBlockIO { API.close = close ctx @@ -35,20 +50,30 @@ serialHasBlockIO hSetNoCache hAdvise hAllocate tryLockFile hfs = do , API.hAdvise , API.hAllocate , API.tryLockFile + , API.hSynchronise + , API.synchroniseDirectory + , API.createHardLink } data IOCtx m = IOCtx { ctxFS :: SomeHasFS m, openVar :: MVar m Bool } +{-# SPECIALISE guardIsOpen :: IOCtx IO -> IO () #-} guardIsOpen :: (MonadMVar m, MonadThrow m) => IOCtx m -> m () guardIsOpen ctx = readMVar (openVar ctx) >>= \b -> unless b $ throwIO (API.mkClosedError (ctxFS ctx) "submitIO") +{-# SPECIALISE initIOCtx :: SomeHasFS IO -> IO (IOCtx IO) #-} initIOCtx :: MonadMVar m => SomeHasFS m -> m (IOCtx m) initIOCtx someHasFS = IOCtx someHasFS <$> newMVar True +{-# SPECIALISE close :: IOCtx IO -> IO () #-} close :: MonadMVar m => IOCtx m -> m () close ctx = modifyMVar_ (openVar ctx) $ const (pure False) +{-# SPECIALISE submitIO :: + HasFS IO h + -> IOCtx IO -> V.Vector (IOOp RealWorld h) + -> IO (VU.Vector IOResult) #-} submitIO :: (MonadMVar m, MonadThrow m, PrimMonad m) => HasFS m h @@ -59,6 +84,7 @@ submitIO hfs ctx ioops = do guardIsOpen ctx hmapM (ioop hfs) ioops +{-# SPECIALISE ioop :: HasFS IO h -> IOOp RealWorld h -> IO IOResult #-} -- | Perform the IOOp using synchronous I\/O. ioop :: MonadThrow m @@ -70,6 +96,11 @@ ioop hfs (IOOpRead h off buf bufOff c) = ioop hfs (IOOpWrite h off buf bufOff c) = IOResult <$> hPutBufExactlyAt hfs h buf bufOff c (fromIntegral off) +{-# SPECIALISE hmapM :: + VUM.Unbox b + => (a -> IO b) + -> V.Vector a + -> IO (VU.Vector b) #-} -- | Heterogeneous blend of 'V.mapM' and 'VU.mapM'. -- -- The @vector@ package does not provide functions that take distinct vector diff --git a/blockio-api/test/Main.hs b/blockio-api/test/Main.hs index 2b424308c..c681c3b24 100644 --- a/blockio-api/test/Main.hs +++ b/blockio-api/test/Main.hs @@ -15,6 +15,7 @@ import Control.Monad import Control.Monad.Primitive import Data.ByteString (ByteString) import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC import Data.Foldable (traverse_) import Data.Functor.Compose (Compose (Compose)) import Data.Maybe (catMaybes) @@ -22,8 +23,8 @@ import Data.Primitive.ByteArray import Data.Typeable import qualified Data.Vector as V import qualified Data.Vector.Unboxed as VU -import qualified System.FS.API as FS import System.FS.API +import qualified System.FS.API.Strict as FS import System.FS.API.Strict (hPutAllStrict) import qualified System.FS.BlockIO.API as FS import System.FS.BlockIO.API @@ -47,6 +48,11 @@ tests = testGroup "blockio-api" [ , testProperty "prop_readWrite" prop_readWrite , testProperty "prop_submitToClosedCtx" prop_submitToClosedCtx , testProperty "prop_tryLockFileExclusiveTwice" prop_tryLockFileExclusiveTwice + , testProperty "prop_synchronise" prop_synchronise + , testProperty "prop_synchroniseFile_fileDoesNotExist" + prop_synchroniseFile_fileDoesNotExist + , testProperty "prop_synchroniseDirectory_directoryDoesNotExist" + prop_synchroniseDirectory_directoryDoesNotExist ] instance Arbitrary ByteString where @@ -164,3 +170,38 @@ prop_tryLockFileExclusiveTwice = ioProperty $ False where fsp = FS.mkFsPath ["lockfile"] + +{------------------------------------------------------------------------------- + Storage synchronisation +-------------------------------------------------------------------------------} + +prop_synchronise :: Property +prop_synchronise = + ioProperty $ + withTempIOHasBlockIO "temp" $ \hfs hbio -> do + FS.createDirectory hfs dir + FS.withFile hfs file (FS.ReadWriteMode FS.MustBeNew) $ \h -> + void $ FS.hPutAllStrict hfs h (BSC.pack "file-contents") + FS.synchroniseFile hfs hbio file + FS.synchroniseDirectory hbio dir + where + dir = FS.mkFsPath ["dir"] + file = dir FS. FS.mkFsPath ["file"] + +prop_synchroniseFile_fileDoesNotExist :: Property +prop_synchroniseFile_fileDoesNotExist = + expectFailure $ + ioProperty $ + withTempIOHasBlockIO "temp" $ \hfs hbio -> do + FS.synchroniseFile hfs hbio file + where + file = FS.mkFsPath ["file"] + +prop_synchroniseDirectory_directoryDoesNotExist :: Property +prop_synchroniseDirectory_directoryDoesNotExist = + expectFailure $ + ioProperty $ + withTempIOHasBlockIO "temp" $ \_hfs hbio -> do + FS.synchroniseDirectory hbio dir + where + dir = FS.mkFsPath ["dir"] diff --git a/blockio-sim/src/System/FS/BlockIO/Sim.hs b/blockio-sim/src/System/FS/BlockIO/Sim.hs index 124eebc34..d6d88621b 100644 --- a/blockio-sim/src/System/FS/BlockIO/Sim.hs +++ b/blockio-sim/src/System/FS/BlockIO/Sim.hs @@ -1,5 +1,6 @@ module System.FS.BlockIO.Sim ( fromHasFS + -- * Initialisation helpers , simHasBlockIO , simHasBlockIO' , simErrorHasBlockIO @@ -8,6 +9,7 @@ module System.FS.BlockIO.Sim ( import Control.Concurrent.Class.MonadMVar import Control.Concurrent.Class.MonadSTM.Strict +import Control.Monad (void) import Control.Monad.Class.MonadThrow import Control.Monad.Primitive (PrimMonad) import qualified Data.ByteString.Char8 as BS @@ -27,7 +29,15 @@ fromHasFS :: => HasFS m HandleMock -> m (HasBlockIO m HandleMock) fromHasFS hfs = - serialHasBlockIO hSetNoCache hAdvise hAllocate (simTryLockFile hfs) hfs + serialHasBlockIO + hSetNoCache + hAdvise + hAllocate + (simTryLockFile hfs) + simHSynchronise + simSynchroniseDirectory + (simCreateHardLink hfs) + hfs where -- TODO: It should be possible for the implementations and simulation to -- throw an FsError when doing file I/O with misaligned byte arrays after @@ -37,6 +47,10 @@ fromHasFS hfs = hAdvise _ _ _ _ = pure () hAllocate _ _ _ = pure () + -- Disk operations are durable by construction + simHSynchronise _ = pure () + simSynchroniseDirectory _ = pure () + -- | Lock files are reader\/writer locks. -- -- We implement this using the content of the lock file. The content is a @@ -110,6 +124,27 @@ simTryLockFile hfs path lockmode = fsLimitation = False } +-- | @'simCreateHardLink' hfs source target@ creates a simulated hard link for +-- the @source@ path at the @target@ path. +-- +-- The hard link is simulated by simply copying the source file to the target +-- path, which means that it should only be used to create hard links for files +-- that are not modified afterwards! +-- +-- TODO: if we wanted to simulate proper hard links, we would have to bake the +-- feature into @fs-sim@. +simCreateHardLink :: MonadThrow m => HasFS m h -> FsPath -> FsPath -> m () +simCreateHardLink hfs sourcePath targetPath = + API.withFile hfs sourcePath API.ReadMode $ \sourceHandle -> + API.withFile hfs targetPath (API.WriteMode API.MustBeNew) $ \targetHandle -> do + -- This should /hopefully/ stream using lazy IO + bs <- API.hGetAll hfs sourceHandle + void $ API.hPutAll hfs targetHandle bs + +{------------------------------------------------------------------------------- + Initialisation helpers +-------------------------------------------------------------------------------} + simHasBlockIO :: (MonadCatch m, MonadMVar m, PrimMonad m, MonadSTM m) => StrictTMVar m MockFS diff --git a/lsm-tree.cabal b/lsm-tree.cabal index 4861fc075..b21424390 100644 --- a/lsm-tree.cabal +++ b/lsm-tree.cabal @@ -765,11 +765,15 @@ library blockio-api elif os(osx) hs-source-dirs: blockio-api/src-macos - build-depends: lsm-tree:fcntl-nocache + build-depends: + , lsm-tree:fcntl-nocache + , unix ^>=2.8 + other-modules: System.FS.BlockIO.Internal elif os(windows) hs-source-dirs: blockio-api/src-windows + build-depends: Win32 ^>=2.14 other-modules: System.FS.BlockIO.Internal if flag(serialblockio) diff --git a/src/Database/LSMTree/Internal.hs b/src/Database/LSMTree/Internal.hs index 717604be0..65638f82f 100644 --- a/src/Database/LSMTree/Internal.hs +++ b/src/Database/LSMTree/Internal.hs @@ -1088,6 +1088,7 @@ createSnapshot resolve snap label tableType t = do withOpenTable t $ \thEnv -> withTempRegistry $ \reg -> do -- TODO: use the temp registry for all side effects let hfs = tableHasFS thEnv + hbio = tableHasBlockIO thEnv -- Guard that the snapshot does not exist already let snapDir = Paths.namedSnapshotDir (tableSessionRoot thEnv) snap @@ -1131,7 +1132,7 @@ createSnapshot resolve snap label tableType t = do -- Convert to snapshot format snapLevels <- toSnapLevels (tableLevels content) -- Hard link runs into the named snapshot directory - snapLevels' <- snapshotRuns reg snapDir snapLevels + snapLevels' <- snapshotRuns reg hbio snapDir snapLevels let snapMetaData = SnapshotMetaData label tableType (tableConfig t) snapLevels' SnapshotMetaDataFile contentPath = Paths.snapshotMetaDataFile snapDir diff --git a/src/Database/LSMTree/Internal/Snapshot.hs b/src/Database/LSMTree/Internal/Snapshot.hs index 9a20482fe..149988e2d 100644 --- a/src/Database/LSMTree/Internal/Snapshot.hs +++ b/src/Database/LSMTree/Internal/Snapshot.hs @@ -18,14 +18,15 @@ module Database.LSMTree.Internal.Snapshot ( -- * Opening from levels snapshot format , fromSnapLevels -- * Hard links + , HardLinkDurable (..) , hardLinkRunFiles ) where import Control.Concurrent.Class.MonadMVar.Strict import Control.Concurrent.Class.MonadSTM (MonadSTM) -import Control.Monad (void) +import Control.Monad (when) import Control.Monad.Class.MonadST (MonadST) -import Control.Monad.Class.MonadThrow (MonadMask, MonadThrow) +import Control.Monad.Class.MonadThrow (MonadMask) import Control.Monad.Primitive (PrimMonad) import Control.RefCount import Control.TempRegistry @@ -50,7 +51,7 @@ import Database.LSMTree.Internal.UniqCounter (UniqCounter, incrUniqCounter, uniqueToRunNumber) import qualified System.FS.API as FS import System.FS.API (HasFS) -import qualified System.FS.API.Lazy as FS +import qualified System.FS.BlockIO.API as FS import System.FS.BlockIO.API (HasBlockIO) {------------------------------------------------------------------------------- @@ -190,25 +191,33 @@ toSnapMergingRunState (OngoingMerge rs (SpentCreditsVar spentCreditsVar) m) = do {-# SPECIALISE snapshotRuns :: TempRegistry IO + -> HasBlockIO IO h -> NamedSnapshotDir -> SnapLevels (Ref (Run IO h)) -> IO (SnapLevels RunNumber) #-} --- | @'snapshotRuns' _ targetDir levels@ creates hard links for all run files +-- | @'snapshotRuns' _ _ targetDir levels@ creates hard links for all run files -- associated with the runs in @levels@, and puts the new directory entries in --- the @targetDir@ directory. +-- the @targetDir@ directory. The hard links and the @targetDir@ are made +-- durable on disk. snapshotRuns :: (MonadMask m, MonadMVar m) => TempRegistry m + -> HasBlockIO m h -> NamedSnapshotDir -> SnapLevels (Ref (Run m h)) -> m (SnapLevels RunNumber) -snapshotRuns reg (NamedSnapshotDir targetDir) levels = - for levels $ \run@(DeRef Run.Run { Run.runHasFS = hfs, - Run.runHasBlockIO = hbio }) -> do - let sourcePaths = Run.runFsPaths run - let targetPaths = sourcePaths { runDir = targetDir } - hardLinkRunFiles reg hfs hbio sourcePaths targetPaths - pure (runNumber targetPaths) +snapshotRuns reg hbio0 (NamedSnapshotDir targetDir) levels = do + levels' <- + for levels $ \run@(DeRef Run.Run { + Run.runHasFS = hfs, + Run.runHasBlockIO = hbio + }) -> do + let sourcePaths = Run.runFsPaths run + let targetPaths = sourcePaths { runDir = targetDir } + hardLinkRunFiles reg hfs hbio HardLinkDurable sourcePaths targetPaths + pure (runNumber targetPaths) + FS.synchroniseDirectory hbio0 targetDir + pure levels' {-# SPECIALISE openRuns :: TempRegistry IO @@ -247,7 +256,7 @@ openRuns let sourcePaths = RunFsPaths sourceDir runNum runNum' <- uniqueToRunNumber <$> incrUniqCounter uc let targetPaths = RunFsPaths targetDir runNum' - hardLinkRunFiles reg hfs hbio sourcePaths targetPaths + hardLinkRunFiles reg hfs hbio NoHardLinkDurable sourcePaths targetPaths allocateTemp reg (Run.openFromDisk hfs hbio caching targetPaths) @@ -342,55 +351,39 @@ fromSnapLevels reg hfs hbio conf@TableConfig{..} uc resolve dir (SnapLevels leve Hard links -------------------------------------------------------------------------------} +data HardLinkDurable = HardLinkDurable | NoHardLinkDurable + deriving stock Eq + {-# SPECIALISE hardLinkRunFiles :: TempRegistry IO -> HasFS IO h -> HasBlockIO IO h + -> HardLinkDurable -> RunFsPaths -> RunFsPaths -> IO () #-} --- | @'hardLinkRunFiles' _hfs hbio sourcePaths targetPaths@ creates a hard link +-- | @'hardLinkRunFiles' _ _ _ dur sourcePaths targetPaths@ creates a hard link -- for each @sourcePaths@ path using the corresponding @targetPaths@ path as the --- name for the new directory entry. +-- name for the new directory entry. If @dur == HardLinkDurabl@, the links will +-- also be made durable on disk. hardLinkRunFiles :: (MonadMask m, MonadMVar m) => TempRegistry m -> HasFS m h -> HasBlockIO m h + -> HardLinkDurable -> RunFsPaths -> RunFsPaths -> m () -hardLinkRunFiles reg hfs hbio sourceRunFsPaths targetRunFsPaths = do +hardLinkRunFiles reg hfs hbio dur sourceRunFsPaths targetRunFsPaths = do let sourcePaths = pathsForRunFiles sourceRunFsPaths targetPaths = pathsForRunFiles targetRunFsPaths sequenceA_ (hardLinkTemp <$> sourcePaths <*> targetPaths) - hardLink hfs hbio (runChecksumsPath sourceRunFsPaths) (runChecksumsPath targetRunFsPaths) + hardLinkTemp (runChecksumsPath sourceRunFsPaths) (runChecksumsPath targetRunFsPaths) where - hardLinkTemp sourcePath targetPath = + hardLinkTemp sourcePath targetPath = do allocateTemp reg - (hardLink hfs hbio sourcePath targetPath) + (FS.createHardLink hbio sourcePath targetPath) (\_ -> FS.removeFile hfs targetPath) - -{-# SPECIALISE hardLink :: - HasFS IO h - -> HasBlockIO IO h - -> FS.FsPath - -> FS.FsPath - -> IO () #-} --- | @'hardLink' hfs hbio source target@ creates a hard link for the @source@ --- path at the @target@ path. --- --- TODO: as a temporary implementation/hack, this copies file contents instead --- of creating hard links. -hardLink :: MonadThrow m => HasFS m h -> HasBlockIO m h -> FS.FsPath -> FS.FsPath -> m () -hardLink hfs _hbio sourcePath targetPath = - FS.withFile hfs sourcePath FS.ReadMode $ \sourceHandle -> - FS.withFile hfs targetPath (FS.WriteMode FS.MustBeNew) $ \targetHandle -> do - -- TODO: this is obviously not creating any hard links, but until we have - -- functions to create hard links in HasBlockIO, this is the temporary - -- implementation/hack to "emulate" hard links. - -- - -- This should /hopefully/ stream using lazy IO, though even if it does - -- not, it is only a temporary placeholder hack. - bs <- FS.hGetAll hfs sourceHandle - void $ FS.hPutAll hfs targetHandle bs + when (dur == HardLinkDurable) $ + FS.synchroniseFile hfs hbio targetPath diff --git a/test/Test/Database/LSMTree/Internal/Run.hs b/test/Test/Database/LSMTree/Internal/Run.hs index 05883eda3..9612bd722 100644 --- a/test/Test/Database/LSMTree/Internal/Run.hs +++ b/test/Test/Database/LSMTree/Internal/Run.hs @@ -190,7 +190,7 @@ prop_WriteAndOpen fs hbio wb = withTempRegistry $ \reg -> do let paths = Run.runFsPaths written paths' = paths { runNumber = RunNumber 17} - hardLinkRunFiles reg fs hbio paths paths' + hardLinkRunFiles reg fs hbio NoHardLinkDurable paths paths' loaded <- openFromDisk fs hbio CacheRunData (simplePath 17) Run.size written @=? Run.size loaded