diff --git a/lsm-tree/CHANGELOG.md b/lsm-tree/CHANGELOG.md index e514b9d65..8dcd21bb9 100644 --- a/lsm-tree/CHANGELOG.md +++ b/lsm-tree/CHANGELOG.md @@ -1,5 +1,105 @@ # Revision history for `lsm-tree` +## 1.2.0.0 -- 2026-07-27 + +### Breaking changes + +* The constructor for `SnapshotImportDirDoesNotExistError` was renamed to + `ErrSnapshotImportDirDoesNotExist` and its field is now of type `FsErrorPath`. + +* The constructor for `SnapshotExportDirExistsError` was renamed to + `ErrSnapshotExportDirExists` and its field is now of type `FsErrorPath`. + +* The type of `importSnapshot` was changed from... + + ```hs + importSnapshot :: + forall m h. + (IOLike m) => + Session m -> + SnapshotName -> + FsPath -> + m () + ``` + + ...to... + + ```hs + importSnapshot :: + forall m h. + (IOLike m) => + Session m -> + SnapshotName -> + (Maybe (HasFS m h), FsPath) -> + m () + ``` + + In the previous release, the source directory was passed as an `FsPath`, + which was interpreted relative to the session mount point. From this release + onwards, it is passed as a pair of an `FsPath` with an optional `HasFS` + instance. If the `HasFS` instance is provided, the `FsPath` path is + interpreted as a path in the corresponding filesystem, and the snapshot is + always copied. If the `HasFS` instance is not provided, the `FsPath` path is + interpreted relative to the session mount point, as before, and the snapshot + is hard linked with a fallback to copying. + + Likewise, the type of `exportSnapshot` was changed from... + + ```hs + exportSnapshot :: + forall m h. + (IOLike m) => + Session m -> + SnapshotName -> + FsPath -> + m () + ``` + + ...to... + + ```hs + exportSnapshot :: + forall m h. + (IOLike m) => + Session m -> + SnapshotName -> + (Maybe (HasFS m h), FsPath) -> + m () + ``` + + The change in the type of the destination directory has the same + interpretation as for `importSnapshot`. + +### New features + +#### Full API + +* Add a new `importSnapshotIO` function that imports snapshots from disk using + a `FilePath` path. + +* Add a new `exportSnapshotIO` function that exports snapshots to disk using + a `FilePath` path. + +#### Simple API + +* Add a new `importSnapshot` function that imports snapshots from disk using + a `FilePath` path and a variant of `SnapshotImportDirDoesNotExistError` with + a `FilePath` field. + +* Add a new `exportSnapshot` function that exports snapshots to disk using + a `FilePath` path and a variant of `SnapshotExportDirExistsError` with a + `FilePath` field. + +### Minor changes + +* Revert the deprecation of `withOpenSessionIO`, since the other changes in this + version have made it safe to use with `importSnapshot` and `exportSnapshot`. + +### Bug fixes + +* If an `SnapshotExportDirExistsError` is thrown, this now contains the + destination directory, rather than the directory of the internap snapshot. + ## 1.1.1.0 -- 2026-07-21 ### Breaking changes diff --git a/lsm-tree/lsm-tree.cabal b/lsm-tree/lsm-tree.cabal index e80b0bf7f..22add8d58 100644 --- a/lsm-tree/lsm-tree.cabal +++ b/lsm-tree/lsm-tree.cabal @@ -549,6 +549,8 @@ library , blockio ^>=0.1 || ^>=0.2 , contra-tracer ^>=0.1 || ^>=0.2 , deepseq ^>=1.4 || ^>=1.5 + , directory ^>=1.3 + , filepath ^>=1.4 || ^>=1.5 , fs-api ^>=0.4 , io-classes ^>=1.6 || ^>=1.7 || ^>=1.8.0.1 || ^>=1.9 || ^>=1.10 , io-classes:strict-mvar diff --git a/lsm-tree/src-core/Database/LSMTree/Internal/FS.hs b/lsm-tree/src-core/Database/LSMTree/Internal/FS.hs index f16fcb93e..bdf03e98d 100644 --- a/lsm-tree/src-core/Database/LSMTree/Internal/FS.hs +++ b/lsm-tree/src-core/Database/LSMTree/Internal/FS.hs @@ -4,6 +4,9 @@ module Database.LSMTree.Internal.FS ( , hardLinkDirectoryRecursive -- * Copy file , copyFile + -- * Hard links with fallback + , Mode (..) + , hardLinkOrCopyDirectoryRecursive ) where import Control.ActionRegistry @@ -11,6 +14,7 @@ import Control.Monad (forM_, void) import Control.Monad.Class.MonadThrow import Control.Monad.Primitive (PrimMonad) +import Foreign.C.Error (eXDEV) import qualified System.FS.API as FS import System.FS.API import qualified System.FS.API.Lazy as FSL @@ -109,9 +113,127 @@ copyFile :: -> FS.FsPath -> FS.FsPath -> m () -copyFile hfs reg sourcePath destinationPath = - flip (withRollback_ reg) (FS.removeFile hfs destinationPath) $ - FS.withFile hfs sourcePath FS.ReadMode $ \sourceHandle -> - FS.withFile hfs destinationPath (FS.WriteMode FS.MustBeNew) $ \targetHandle -> do - bs <- FSL.hGetAll hfs sourceHandle - void $ FSL.hPutAll hfs targetHandle bs +copyFile hfs = copyFile' hfs hfs + +{-# SPECIALISE + copyFile' :: + HasFS IO h + -> HasFS IO h' + -> ActionRegistry IO + -> FS.FsPath + -> FS.FsPath + -> IO () + #-} +-- | @'copyFile' sourceFS destinationFS reg sourcePath destinationPath@ copies the file +-- contents of @sourcePath@ on @sourceFS@ to the @destinationPath@ on @destinationFS@. +copyFile' :: + (MonadMask m, PrimMonad m) + => HasFS m h -- ^ The 'HasFS' instance for the source filesystem + -> HasFS m h' -- ^ The 'HasFS' instance for the target filesystem + -> ActionRegistry m + -> FS.FsPath + -> FS.FsPath + -> m () +copyFile' sourceFS destinationFS reg sourcePath destinationPath = + flip (withRollback_ reg) (FS.removeFile destinationFS destinationPath) $ + FS.withFile sourceFS sourcePath FS.ReadMode $ \sourceHandle -> + FS.withFile destinationFS destinationPath (FS.WriteMode FS.MustBeNew) $ \destinationHandle -> do + bs <- FSL.hGetAll sourceFS sourceHandle + void $ FSL.hPutAll destinationFS destinationHandle bs + +{------------------------------------------------------------------------------- + Hard link with fallback +-------------------------------------------------------------------------------} + +{- | +The file transfer mode to be used by a snapshot import or export. +-} +data Mode m h + = HardLink + -- | Whether or not to allow fallback to copying. + !Bool + -- | The 'HasBlockIO' instance that enables hard linking. + !(HasBlockIO m h) + | forall h'. + Copy + -- | The 'HasFS' instance that enables copying. + !(HasFS m h') + +{-# SPECIALISE + hardLinkOrCopy :: + HasFS IO h + -> Mode IO h + -> ActionRegistry IO + -> FS.FsPath + -> FS.FsPath + -> IO () + #-} +-- | @'hardLinkOrCopy' sourceFS destinationFS hbio reg sourcePath destinationPath@ +-- attemtps to create a hard link from @sourcePath@ to @destinationPath@ if +-- both are on the same file system and copies the file otherwise. +hardLinkOrCopy :: + (MonadMask m, PrimMonad m) + => -- | The 'HasFS' instance for the source filesystem + HasFS m h + -> -- | Either a 'HasBlockIO' instance for the source filesystem, + -- or a 'HasFS' instance for the destination filesystem + Mode m h + -> ActionRegistry m + -> FS.FsPath -- ^ The source path + -> FS.FsPath -- ^ The destination path + -> m () +hardLinkOrCopy sourceFS (HardLink fallback sourceBIO) reg sourcePath destinationPath = do + let -- NOTE: On Windows, the error code is ERROR_NOT_SAME_DEVICE (17), + -- but the Win32 primitive for creating hard links maps this + -- to the POSIX error code EXDEV using the maperrno builtin. + isEXDEV :: FsError -> Bool + isEXDEV e = fsErrorNo e == Just eXDEV + ifEXDEV e = if isEXDEV e then Just e else Nothing + + doHardLink = hardLink sourceFS sourceBIO reg sourcePath destinationPath + doFallBack = copyFile sourceFS reg sourcePath destinationPath + doHardLinkThenFallBack = catchJust ifEXDEV doHardLink (const doFallBack) + + if fallback then doHardLinkThenFallBack else doHardLink + +hardLinkOrCopy sourceFS (Copy destinationFS) reg sourcePath destinationPath = + copyFile' sourceFS destinationFS reg sourcePath destinationPath + +{-# SPECIALISE + hardLinkOrCopyDirectoryRecursive :: + HasFS IO h + -> Mode IO h + -> ActionRegistry IO + -> FS.FsPath + -> FS.FsPath + -> IO () + #-} +hardLinkOrCopyDirectoryRecursive :: + (MonadMask m, PrimMonad m) + => -- | The 'HasFS' instance for the source filesystem + HasFS m h + -> -- | Either a 'HasBlockIO' instance for the source filesystem, + -- or a 'HasFS' instance for the destination filesystem + Mode m h + -> ActionRegistry m + -- | Source path + -> FS.FsPath + -- | Destination path + -> FS.FsPath + -> m () +hardLinkOrCopyDirectoryRecursive sourceFS mode reg sourcePath destinationPath = do + entries <- FS.listDirectory sourceFS sourcePath + forM_ entries $ \entry -> do + let sourcePath' = sourcePath FS. FS.mkFsPath [entry] + destinationPath' = destinationPath FS. FS.mkFsPath [entry] + isFile <- FS.doesFileExist sourceFS sourcePath' + if isFile then + hardLinkOrCopy sourceFS mode reg sourcePath' destinationPath' + else do + isDirectory <- FS.doesDirectoryExist sourceFS sourcePath' + if isDirectory then do + hardLinkOrCopyDirectoryRecursive sourceFS mode reg sourcePath' destinationPath' + else + error $ printf + "hardLinkOrCopyDirectoryRecursive: %s is not a file or directory" + (show sourcePath') diff --git a/lsm-tree/src-core/Database/LSMTree/Internal/Unsafe.hs b/lsm-tree/src-core/Database/LSMTree/Internal/Unsafe.hs index d0b3d1f8d..6548d6dce 100644 --- a/lsm-tree/src-core/Database/LSMTree/Internal/Unsafe.hs +++ b/lsm-tree/src-core/Database/LSMTree/Internal/Unsafe.hs @@ -77,6 +77,7 @@ module Database.LSMTree.Internal.Unsafe ( , readCursorWhile -- * Snapshots , SnapshotLabel + , SnapshotMode (..) , saveSnapshot , openTableFromSnapshot , deleteSnapshot @@ -1913,26 +1914,70 @@ listSnapshots sesh = do if b then pure $ Just snap else pure $ Nothing +{- | +The mode to be used by a snapshot import or export. +-} +data SnapshotMode m h + = HardLink + -- | Whether or not to allow fallback to copying. + !Bool + | Copy + -- | The 'HasFS' instance used for copying. + !(HasFS m h) + +{- | +Internal helper. + +Get an 'FsErrorPath' for an 'FsPath' interpreted under the given 'SnapshotMode'. +-} +snapshotFsErrorPath :: + HasFS m h + -> SnapshotMode m h' + -> FsPath + -> FsErrorPath +snapshotFsErrorPath hfs mode fsPath = + case mode of + HardLink {} -> FS.mkFsErrorPath hfs fsPath + Copy hfs' -> FS.mkFsErrorPath hfs' fsPath + +{- | +Internal helper. + +Convert a 'SnapshotMode' to the internal 'FS.Mode'. +-} +fsMode :: + HasBlockIO m h + -> SnapshotMode m h' + -> FS.Mode m h +fsMode hbio = \case + HardLink fallback -> + FS.HardLink fallback hbio + Copy hfs -> + FS.Copy hfs + -- | A snapshot was intended to be imported, but the source directory does not -- exist. -data SnapshotImportDirDoesNotExistError - = SnapshotImportDirDoesNotExistError !FsPath +newtype SnapshotImportDirDoesNotExistError + = ErrSnapshotImportDirDoesNotExist FsErrorPath deriving stock (Show, Eq) deriving anyclass (Exception) {-# SPECIALISE importSnapshot :: Session IO h -> SnapshotName + -> SnapshotMode IO h' -> FsPath -> IO () #-} -- | See 'Database.LSMTree.importSnapshot'. importSnapshot :: + forall m h h'. (MonadMask m, MonadSTM m, PrimMonad m) => Session m h -> SnapshotName + -> SnapshotMode m h' -> FsPath -> m () -importSnapshot sesh snap sourcePath = do +importSnapshot sesh snap mode sourcePath = do traceWith sesh.sessionTracer $ TraceImportSnapshot snap sourcePath withKeepSessionOpen sesh $ \seshEnv -> withActionRegistry $ \reg -> do @@ -1947,7 +1992,7 @@ importSnapshot sesh snap sourcePath = do let destinationPath = Paths.getNamedSnapshotDir snapDir sourceExists <- FS.doesDirectoryExist hfs sourcePath - unless sourceExists $ throwIO (SnapshotImportDirDoesNotExistError sourcePath) + unless sourceExists $ throwIO $ ErrSnapshotImportDirDoesNotExist $ snapshotFsErrorPath hfs mode sourcePath -- we assume the snapshots directory already exists, so we just have -- to create the directory for this specific snapshot. @@ -1955,8 +2000,8 @@ importSnapshot sesh snap sourcePath = do (FS.createDirectory hfs destinationPath) (FS.removeDirectoryRecursive hfs destinationPath) - -- create hard links for all files in the destination directory - FS.hardLinkDirectoryRecursive hfs hbio reg sourcePath destinationPath + -- import the files for the snapshot, either by hard linking or copying + FS.hardLinkOrCopyDirectoryRecursive hfs (fsMode hbio mode) reg sourcePath destinationPath -- Make the destination directory and its contents durable FS.synchroniseDirectoryRecursive hfs hbio destinationPath @@ -1968,14 +2013,15 @@ importSnapshot sesh snap sourcePath = do -- | A snapshot was intended to be exported, but the destination directory -- already exists. -data SnapshotExportDirExistsError - = SnapshotExportDirExistsError !FsPath +newtype SnapshotExportDirExistsError + = ErrSnapshotExportDirExists FsErrorPath deriving stock (Show, Eq) deriving anyclass (Exception) {-# SPECIALISE exportSnapshot :: Session IO h -> SnapshotName + -> SnapshotMode IO h' -> FsPath -> IO () #-} -- | See 'Database.LSMTree.exportSnapshot'. @@ -1983,9 +2029,10 @@ exportSnapshot :: (MonadMask m, MonadSTM m, PrimMonad m) => Session m h -> SnapshotName + -> SnapshotMode m h' -> FsPath -> m () -exportSnapshot sesh snap destinationPath = do +exportSnapshot sesh snap mode destinationPath = do traceWith (sessionTracer sesh) $ TraceExportSnapshot snap destinationPath withKeepSessionOpen sesh $ \seshEnv -> withActionRegistry $ \reg -> do @@ -2000,14 +2047,14 @@ exportSnapshot sesh snap destinationPath = do let sourcePath = Paths.getNamedSnapshotDir snapDir destinationExists <- FS.doesDirectoryExist hfs destinationPath - when destinationExists $ throwIO (SnapshotExportDirExistsError sourcePath) + when destinationExists $ throwIO $ ErrSnapshotExportDirExists $ snapshotFsErrorPath hfs mode destinationPath withRollback_ reg (FS.createDirectoryIfMissing hfs True destinationPath) (FS.removeDirectoryRecursive hfs destinationPath) - -- Create hard links for all files in the destination directory - FS.hardLinkDirectoryRecursive hfs hbio reg sourcePath destinationPath + -- export the files for the snapshot, either by hard linking or copying + FS.hardLinkOrCopyDirectoryRecursive hfs (fsMode hbio mode) reg sourcePath destinationPath -- Make the directory and its contents durable. FS.synchroniseDirectoryRecursive hfs hbio destinationPath diff --git a/lsm-tree/src/Database/LSMTree.hs b/lsm-tree/src/Database/LSMTree.hs index fba7f1dc4..c37b79910 100644 --- a/lsm-tree/src/Database/LSMTree.hs +++ b/lsm-tree/src/Database/LSMTree.hs @@ -102,8 +102,11 @@ module Database.LSMTree ( doesSnapshotExist, deleteSnapshot, listSnapshots, + SnapshotMode (..), importSnapshot, + importSnapshotIO, exportSnapshot, + exportSnapshotIO, SnapshotName, isValidSnapshotName, toSnapshotName, @@ -202,6 +205,7 @@ import Control.Concurrent.Class.MonadMVar.Strict (MonadMVar) import Control.Concurrent.Class.MonadSTM (MonadSTM (STM)) import Control.DeepSeq (NFData (..)) import Control.Exception.Base (assert) +import Control.Monad (when) import Control.Monad.Class.MonadAsync (MonadAsync) import Control.Monad.Class.MonadST (MonadST) import Control.Monad.Class.MonadThrow (MonadCatch (..), MonadEvaluate, @@ -256,17 +260,20 @@ import Database.LSMTree.Internal.Unsafe (BlobRefInvalidError (..), SessionTrace (..), SnapshotCorruptedError (..), SnapshotDoesNotExistError (..), SnapshotExistsError (..), SnapshotExportDirExistsError (..), - SnapshotImportDirDoesNotExistError (..), + SnapshotImportDirDoesNotExistError (..), SnapshotMode (..), SnapshotNotCompatibleError (..), TableClosedError (..), TableCorruptedError (..), TableTooLargeError (..), TableTrace, TableUnionNotCompatibleError (..), UnionCredits (..), UnionDebt (..)) import qualified Database.LSMTree.Internal.Unsafe as Internal import Prelude hiding (lookup, take, takeWhile) -import System.FS.API (FsPath, HasFS (..), MountPoint (..), mkFsPath) +import qualified System.Directory as Dir +import qualified System.FilePath as FP +import System.FS.API (FsErrorPath (..), FsPath, HasFS (..), + MountPoint (..), mkFsPath) import System.FS.BlockIO.API (HasBlockIO (..)) import System.FS.BlockIO.IO (defaultIOCtxParams, withIOHasBlockIO) -import System.FS.IO (HandleIO) +import System.FS.IO (HandleIO, ioHasFS) import System.Random (randomIO) -------------------------------------------------------------------------------- @@ -423,17 +430,14 @@ For more information about the interfaces and their instantiations, see the Hadd documentation of the @fs-api@, @fs-sim@, @blockio@ packages. The session directory is a relative 'FsPath' path that is interpreted relative to the /root/ of -the given 'HasFS' and 'HasBlockio' interfaces. +the given 'HasFS' and 'HasBlockIO' interfaces. If the interaces are instantiated with the real file system, then the root is an (absolute or relative) file path. In this case, the root is also called the /mount point/ of the interface. If the interfaces are instantiated with a simulation, then the root is some abstract location. -Any 'FsPath' paths used with the session after the session is created are also interpreted -with respect to the root of these interfaces. -'importSnapshot' and 'exportSnapshot' are currently the only two functions that take -'FsPaths' as arguments. -'FsPath's are subject to a number of constraints, which are mentioned in its Haddock documentation. +If 'importSnapshot' or 'exportSnapshot' are passed the 'SnapshotMode' 'HardLink', +the 'FsPath' path is interpreted with respect to the interface root. If there are no open tables or cursors when the session terminates, then the disk I\/O complexity of this operation is \(O(1)\). Otherwise, 'closeTable' is called for each open table and 'closeCursor' is called for each open cursor. @@ -484,21 +488,13 @@ withOpenSession :: withOpenSession tracer hasFS hasBlockIO sessionSalt sessionDir action = do Internal.withOpenSession tracer hasFS hasBlockIO sessionSalt sessionDir (action . Session) -{-# DEPRECATED withOpenSessionIO "withOpenSessionIO is not compatible with importSnapshot and exportSnapshot. Use withOpenMountedSessionIO instead." #-} {- | Variant of 'withOpenSession' that is specialised to 'IO' using the real filesystem. -Any 'FsPath' paths used with the session after the session is created are interpreted -with respect to the session directory. -'importSnapshot' and 'exportSnapshot' are currently the only two functions that take -'FsPaths' as arguments. -'FsPath's are subject to a number of constraints, which are mentioned in its Haddock documentation. - -It is generally not advisable to use 'importSnapshot' and 'exportSnapshot' when the session is -created using 'withOpenSessionIO'. -Snapshots should only be exported to somewhere /outside/ the session directory, which is not possible -when the session is created using 'withOpenSessionIO'. -Use 'withOpenMountedSessionIO' or 'withOpenSession' instead. +__Warning:__ When using this function, the interface root becomes the session +directory itself. If 'importSnapshot' or 'exportSnapshot' are passed the +'SnapshotMode' 'HardLink', the 'FsPath' path is interpreted with relative to the +session directory, which may interfere with database operations. -} withOpenSessionIO :: Tracer IO LSMTreeTrace -> @@ -512,12 +508,8 @@ withOpenSessionIO tracer sessionDir action = {- | Variant of 'withOpenSession' that is specialised to 'IO' using the real filesystem. -The session directory is an 'FsPath' path that is interpreted relative to the given mount point. -Any 'FsPath' paths used with the session after the session is created are also interpreted -with respect to the mount point. -'importSnapshot' and 'exportSnapshot' are currently the only two functions that take -'FsPaths' as arguments. -'FsPath's are subject to a number of constraints, which are mentioned in its haddock documentation. +If 'importSnapshot' or 'exportSnapshot' are passed the 'SnapshotMode' 'HardLink', +the 'FsPath' path is interpreted with respect to the interface root. -} withOpenMountedSessionIO :: Tracer IO LSMTreeTrace -> @@ -2897,24 +2889,17 @@ listSnapshots (Session session) = {- | Import a snapshot from an external directory. -The source directory should exist. -Snapshots should only be imported from a directory on the same volume as the session directory. - -Importing does not not check whether the external directory is a snapshot, and -neither does importing verify the snapshot contents if it is a snapshot. -Open the snapshot to verify that it is a snapshot and that it is not corrupted. +The 'SnapshotMode' argument determines whether the snapshot is imported +by hard linking or copying. If the 'SnapshotMode' is @'HardLink' fallback@, +the 'FsPath' is interpreted relative to the interface root. The @fallback@ +flag determines whether the import should fall back to copying if hard linking +fails. If the 'SnapshotMode' is @'Copy' extFS@, the 'FsPath' is interpreted +relative to the root of the @extFS@ 'HasFS' interface. -The 'FsPath' path to the source directory is a relative path that is interpreted -relative to a /root/ (sometimes also called a mount point). -What the root is depends on which function was used to create the session. -See 'withOpenSession', 'withOpenSessionIO', and 'withOpenMountedSessionIO' for more -information about the root. +Importing does not that whether the external directory is a valid shnapshot. +Open the imported snapshot to verify that it is a valid and uncorrupted. -It is generally not advisable to use 'importSnapshot' and 'exportSnapshot' when the session is -created using 'withOpenSessionIO'. -Snapshots should only be exported to somewhere /outside/ the session directory, which is not possible -when the session is created using 'withOpenSessionIO'. -Use 'withOpenMountedSessionIO' or 'withOpenSession' instead. +The source directory should exist. >>> :{ runExample $ \session table -> do @@ -2924,8 +2909,8 @@ runExample $ \session table -> do LSMT.saveSnapshot "example" "Key Value Blob" table -- Export then import snapshot let exportDir = mkFsPath ["export"] - LSMT.exportSnapshot session "example" exportDir - LSMT.importSnapshot session "example_new" exportDir + LSMT.exportSnapshot session "example" (HardLink True) exportDir + LSMT.importSnapshot session "example_new" (HardLink True) exportDir -- Open the imported snapshot LSMT.withTableFromSnapshot @_ @_ @Value session "example_new" "Key Value Blob" $ \table' -> do @@ -2953,37 +2938,54 @@ Throws the following exceptions: importSnapshot :: Session IO -> SnapshotName -> + SnapshotMode IO h -> FsPath -> IO () #-} importSnapshot :: - forall m. + forall m h. (IOLike m) => Session m -> SnapshotName -> - -- | Source directory + SnapshotMode m h -> FsPath -> m () importSnapshot (Session session) = Internal.importSnapshot session {- | -Export a snapshot to an external directory. +Variant of 'importSnapshot' that is specialised to 'IO' using the real filesystem. -The destination directory should not exist already. -Snapshots should only be exported to a directory on the same volume as the session directory. +This always imports the snapshot by copying. +-} +importSnapshotIO :: + Session IO -> + SnapshotName -> + FilePath -> + IO () +importSnapshotIO session snapshotName importDir = do + -- Get the absolute path to the export directory. + importAbsDir <- Dir.makeAbsolute importDir -The 'FsPath' path to the destination directory is a relative path that is interpreted -relative to a /root/. -What the root is depends on which function was used to create the session. -See 'withOpenSession', 'withOpenSessionIO', and 'withOpenMountedSessionIO' for more -information about the root. + -- Split the path to the export directory to determine a suitable mount point. + let (mountPointPath, importRelDir) = FP.splitFileName importAbsDir + let mountPoint = MountPoint mountPointPath + let importDirFsPath = mkFsPath [importRelDir] -It is generally not advisable to use 'importSnapshot' and 'exportSnapshot' when the session is -created using 'withOpenSessionIO'. -Snapshots should only be exported to somewhere /outside/ the session directory, which is not possible -when the session is created using 'withOpenSessionIO'. -Use 'withOpenMountedSessionIO' or 'withOpenSession' instead. + -- Import the snapshot. + importSnapshot session snapshotName (Copy (ioHasFS @IO mountPoint)) importDirFsPath + +{- | +Export a snapshot to an external directory. + +The 'SnapshotMode' argument determines whether the snapshot is exported +by hard linking or copying. If the 'SnapshotMode' is @'HardLink' fallback@, +the 'FsPath' is interpreted relative to the interface root. The @fallback@ +flag determines whether the import should fall back to copying if hard linking +fails. If the 'SnapshotMode' is @'Copy' extFS@, the 'FsPath' is interpreted +relative to the root of the @extFS@ 'HasFS' interface. + +The destination directory should not already exist. >>> :{ runExample $ \session table -> do @@ -2993,8 +2995,8 @@ runExample $ \session table -> do LSMT.saveSnapshot "example" "Key Value Blob" table -- Export then import snapshot let exportDir = mkFsPath ["export"] - LSMT.exportSnapshot session "example" exportDir - LSMT.importSnapshot session "example_new" exportDir + LSMT.exportSnapshot session "example" (HardLink True) exportDir + LSMT.importSnapshot session "example_new" (HardLink True) exportDir -- Open the imported snapshot LSMT.withTableFromSnapshot @_ @_ @Value session "example_new" "Key Value Blob" $ \table' -> do @@ -3022,20 +3024,49 @@ Throws the following exceptions: exportSnapshot :: Session IO -> SnapshotName -> + SnapshotMode IO h -> FsPath -> IO () #-} exportSnapshot :: - forall m. + forall m h. (IOLike m) => Session m -> SnapshotName -> - -- | Destination directory + SnapshotMode m h -> FsPath -> m () exportSnapshot (Session session) = Internal.exportSnapshot session +{- | +Variant of 'exportSnapshot' that is specialised to 'IO' using the real filesystem. + +This always exports the snapshot by copying. +-} +exportSnapshotIO :: + Session IO -> + SnapshotName -> + FilePath -> + IO () +exportSnapshotIO session snapshotName exportDir = do + -- Get the absolute path to the export directory. + exportAbsDir <- Dir.makeAbsolute exportDir + + -- Split the path to the export directory to determine a suitable mount point. + let (mountPointPath, exportRelDir) = FP.splitFileName exportAbsDir + let mountPoint = MountPoint mountPointPath + let exportDirFsPath = mkFsPath [exportRelDir] + + -- NOTE: If exportRelDir is null, then exportAbsDir must be the root + -- directory, which, it is fair to assume, exists. + when (null exportRelDir) $ do + let exportFsErrorPath = FsErrorPath (Just mountPoint) exportDirFsPath + throwIO $ ErrSnapshotExportDirExists exportFsErrorPath + + -- Export the snapshot. + exportSnapshot session snapshotName (Copy (ioHasFS @IO mountPoint)) exportDirFsPath + -- | Internal helper. Get 'resolveSerialised' at type 'ResolveSerialisedValue'. _getResolveSerialisedValue :: forall v. diff --git a/lsm-tree/src/Database/LSMTree/Simple.hs b/lsm-tree/src/Database/LSMTree/Simple.hs index 6c3278025..ffec7a630 100644 --- a/lsm-tree/src/Database/LSMTree/Simple.hs +++ b/lsm-tree/src/Database/LSMTree/Simple.hs @@ -88,6 +88,8 @@ module Database.LSMTree.Simple ( doesSnapshotExist, deleteSnapshot, listSnapshots, + importSnapshot, + exportSnapshot, SnapshotName, isValidSnapshotName, toSnapshotName, @@ -150,6 +152,8 @@ module Database.LSMTree.Simple ( SnapshotDoesNotExistError (..), SnapshotCorruptedError (..), SnapshotNotCompatibleError (..), + SnapshotImportDirDoesNotExistError (..), + SnapshotExportDirExistsError (..), CursorClosedError (..), InvalidSnapshotNameError (..), ) where @@ -1560,6 +1564,57 @@ listSnapshots :: listSnapshots (Session session) = LSMT.listSnapshots session +{- | +Import a snapshot from an external directory by copying. + +The source directory should exist. + +The worst-case disk I\/O complexity of this operation is \(O(\frac{n}{P})\). + +Throws the following exceptions: + +['SessionClosedError']: + If the session is closed. +['SnapshotExistsError']: + If a snapshot with the same name already exists. +['SnapshotImportDirDoesNotExistError']: + If the source directory for the to-be-imported snapshot does not exist. +-} +importSnapshot :: + Session -> + SnapshotName -> + FilePath -> + IO () +importSnapshot (Session session) snapshotName importDir = + _convertSnapshotImportDirDoesNotExistError $ + LSMT.importSnapshotIO session snapshotName importDir + + +{- | +Export a snapshot to a directory by copying. + +The destination directory should not already exist. + +The worst-case disk I\/O complexity of this operation is \(O(\frac{n}{P})\). + +Throws the following exceptions: + +['SessionClosedError']: + If the session is closed. +['SnapshotDoesNotExistError']: + If no snapshot with the given name exists. +['SnapshotExportDirExistsError']: + If the destination directory for the to-be-exported snapshot already exists. +-} +exportSnapshot :: + Session -> + SnapshotName -> + FilePath -> + IO () +exportSnapshot (Session session) snapshotName exportDir = + _convertSnapshotExportDirExistsError $ + LSMT.exportSnapshotIO session snapshotName exportDir + -------------------------------------------------------------------------------- -- Errors -------------------------------------------------------------------------------- @@ -1640,3 +1695,47 @@ _convertTableUnionNotCompatibleError sessionDirFor = ErrTableUnionHandleTypeMismatch i1 typeRep1 i2 typeRep2 LSMT.ErrTableUnionSessionMismatch i1 _fsErrorPath1 i2 _fsErrorPath2 -> ErrTableUnionSessionMismatch i1 (sessionDirFor i1) i2 (sessionDirFor i2) + +{------------------------------------------------------------------------------- + Snapshot import/export +-------------------------------------------------------------------------------} + +-- | A snapshot was intended to be imported, but the source directory does not exist. +newtype SnapshotImportDirDoesNotExistError + = ErrSnapshotImportDirDoesNotExist FilePath + deriving stock (Show, Eq) + deriving anyclass (Exception) + +{- | Internal helper. Convert: + +* t'LSMT.SnapshotImportDirDoesNotExistError' to t'SnapshotImportDirDoesNotExistError'; +-} +_convertSnapshotImportDirDoesNotExistError :: + forall a. + IO a -> + IO a +_convertSnapshotImportDirDoesNotExistError = + mapExceptionWithActionRegistry $ \case + LSMT.ErrSnapshotImportDirDoesNotExist fsErrorPath -> + ErrSnapshotImportDirDoesNotExist (show fsErrorPath) + + +-- | A snapshot was intended to be exported, but the destination directory already exists. +newtype SnapshotExportDirExistsError + = SnapshotExportDirExistsError FilePath + deriving stock (Show, Eq) + deriving anyclass (Exception) + + +{- | Internal helper. Convert: + +* t'LSMT.SnapshotExportDirExistsError' to t'SnapshotExportDirExistsError'; +-} +_convertSnapshotExportDirExistsError :: + forall a. + IO a -> + IO a +_convertSnapshotExportDirExistsError = + mapExceptionWithActionRegistry $ \case + LSMT.ErrSnapshotImportDirDoesNotExist fsErrorPath -> + ErrSnapshotImportDirDoesNotExist (show fsErrorPath) diff --git a/lsm-tree/test/Test/Database/LSMTree/Snapshots.hs b/lsm-tree/test/Test/Database/LSMTree/Snapshots.hs index ac522625f..18255b0bf 100644 --- a/lsm-tree/test/Test/Database/LSMTree/Snapshots.hs +++ b/lsm-tree/test/Test/Database/LSMTree/Snapshots.hs @@ -8,7 +8,8 @@ import qualified Data.Vector as V import Data.Void (Void) import Data.Word (Word64) import Database.LSMTree (ResolveValue, Salt, SerialiseKey, - SerialiseValue, Table, TableConfig (confWriteBufferAlloc), + SerialiseValue, SnapshotMode (..), Table, + TableConfig (confWriteBufferAlloc), WriteBufferAlloc (AllocNumEntries), defaultTableConfig, exportSnapshot, getValue, importSnapshot, inserts, lookups, saveSnapshot, withOpenSession, withTableFromSnapshot, @@ -53,8 +54,9 @@ newtype Value = Value Word64 prop_exportImportSnapshot :: V.Vector (Key, Value) -> V.Vector Key + -> Bool -- ^ Should hard link? -> Property -prop_exportImportSnapshot ins los = +prop_exportImportSnapshot ins los shouldHardLink = checkCoverage $ ioProperty $ withTempIOHasBlockIO "prop_exportImportSnapshot" $ \hfs hbio -> do @@ -67,8 +69,9 @@ prop_exportImportSnapshot ins los = saveSnapshot "snap1" "KeyValueBlob" table1 -- Export then re-import the snapshot - exportSnapshot session "snap1" exportDir - importSnapshot session "snap2" exportDir + let mode = if shouldHardLink then HardLink False else Copy hfs + exportSnapshot session "snap1" mode exportDir + importSnapshot session "snap2" mode exportDir -- Open a table from the re-imported snapshot. Any corruption of the -- snapshot would be identified here.