Fix importSnapshot/exportSnapshot

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

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

lsm-tree/src-core/Database/LSMTree/Internal/FS.hs

@@ -4,13 +4,15 @@ module Database.LSMTree.Internal.FS (
   , hardLinkDirectoryRecursive
     -- * Copy file
   , copyFile
+  , hardLinkOrCopyDirectoryRecursive
   ) where
 
 import           Control.ActionRegistry
 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 +111,113 @@ 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
+
+{-------------------------------------------------------------------------------
+  Copy file
+-------------------------------------------------------------------------------}
+
+{-# SPECIALISE
+  hardLinkOrCopy ::
+       HasFS IO h
+    -> Either (HasBlockIO IO h) (HasFS 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
+     Either (HasBlockIO m h) (HasFS m h')
+  -> ActionRegistry m
+  -> FS.FsPath         -- ^ The source path
+  -> FS.FsPath         -- ^ The destination path
+  -> m ()
+hardLinkOrCopy sourceFS (Left 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
+
+  -- Try to create a hard link from @sourcePath@ to @destinationPath@, but
+  -- if a cross-device link error is encountered, fall back to copying.
+  catchJust
+    (\e -> if isEXDEV e then Just e else Nothing)
+    (hardLink sourceFS sourceBIO reg sourcePath destinationPath)
+    (\_e_EXDEV -> copyFile sourceFS reg sourcePath destinationPath)
+
+hardLinkOrCopy sourceFS (Right destinationFS) reg sourcePath destinationPath =
+  copyFile' sourceFS destinationFS reg sourcePath destinationPath
+
+{-# SPECIALISE
+  hardLinkOrCopyDirectoryRecursive ::
+       HasFS IO h
+    -> Either (HasBlockIO IO h) (HasFS 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
+     Either (HasBlockIO m h) (HasFS m h')
+  -> ActionRegistry m
+     -- | Source path
+  -> FS.FsPath
+     -- | Destination path
+  -> FS.FsPath
+  -> m ()
+hardLinkOrCopyDirectoryRecursive sourceFS hbioOrDestinationFS 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 hbioOrDestinationFS reg sourcePath' destinationPath'
+    else do
+      isDirectory <- FS.doesDirectoryExist sourceFS sourcePath'
+      if isDirectory then do
+        hardLinkOrCopyDirectoryRecursive sourceFS hbioOrDestinationFS reg sourcePath' destinationPath'
+      else
+        error $ printf
+          "hardLinkOrCopyDirectoryRecursive: %s is not a file or directory"
+          (show sourcePath')

lsm-tree/src-core/Database/LSMTree/Internal/Unsafe.hs

@@ -1915,24 +1915,25 @@ listSnapshots sesh = do
 
 -- | 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
-  -> FsPath
+  -> (Maybe (HasFS IO h), FsPath)
   -> IO () #-}
 -- |  See 'Database.LSMTree.importSnapshot'.
 importSnapshot ::
+  forall m h h'.
      (MonadMask m, MonadSTM m, PrimMonad m)
   => Session m h
   -> SnapshotName
-  -> FsPath
+  -> (Maybe (HasFS m h'), FsPath)
   -> m ()
-importSnapshot sesh snap sourcePath = do
+importSnapshot sesh snap (maybeSourceFS, sourcePath) = do
     traceWith sesh.sessionTracer $ TraceImportSnapshot snap sourcePath
     withKeepSessionOpen sesh $ \seshEnv ->
       withActionRegistry $ \reg -> do
@@ -1947,16 +1948,22 @@ importSnapshot sesh snap sourcePath = do
         let destinationPath = Paths.getNamedSnapshotDir snapDir
 
         sourceExists <- FS.doesDirectoryExist hfs sourcePath
-        unless sourceExists $ throwIO (SnapshotImportDirDoesNotExistError sourcePath)
+        unless sourceExists $ do
+          let sourceErrorPath = maybe (FS.mkFsErrorPath hfs) FS.mkFsErrorPath maybeSourceFS $ sourcePath
+          throwIO (ErrSnapshotImportDirDoesNotExist sourceErrorPath)
 
         -- we assume the snapshots directory already exists, so we just have
         -- to create the directory for this specific snapshot.
         withRollback_ reg
           (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
+        case maybeSourceFS of
+          Nothing ->
+            FS.hardLinkOrCopyDirectoryRecursive hfs (Left hbio) reg sourcePath destinationPath
+          Just sourceFS ->
+            FS.hardLinkOrCopyDirectoryRecursive sourceFS (Right hfs) reg sourcePath destinationPath
 
         -- Make the destination directory and its contents durable
         FS.synchroniseDirectoryRecursive hfs hbio destinationPath
@@ -1968,24 +1975,24 @@ 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
-  -> FsPath
+  -> (Maybe (HasFS IO h'), FsPath)
   -> IO () #-}
 -- |  See 'Database.LSMTree.exportSnapshot'.
 exportSnapshot ::
      (MonadMask m, MonadSTM m, PrimMonad m)
   => Session m h
   -> SnapshotName
-  -> FsPath
+  -> (Maybe (HasFS m h'), FsPath)
   -> m ()
-exportSnapshot sesh snap destinationPath = do
+exportSnapshot sesh snap (maybeDestinationFS, destinationPath) = do
     traceWith (sessionTracer sesh) $ TraceExportSnapshot snap destinationPath
     withKeepSessionOpen sesh $ \seshEnv ->
       withActionRegistry $ \reg -> do
@@ -2000,14 +2007,20 @@ exportSnapshot sesh snap destinationPath = do
         let sourcePath = Paths.getNamedSnapshotDir snapDir
 
         destinationExists <- FS.doesDirectoryExist hfs destinationPath
-        when destinationExists $ throwIO (SnapshotExportDirExistsError sourcePath)
+        when destinationExists $ do
+          let destinationErrorPath = maybe (FS.mkFsErrorPath hfs) FS.mkFsErrorPath maybeDestinationFS $ destinationPath
+          throwIO (ErrSnapshotExportDirExists destinationErrorPath)
 
         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
+        case maybeDestinationFS of
+          Nothing ->
+            FS.hardLinkOrCopyDirectoryRecursive hfs (Left hbio) reg sourcePath destinationPath
+          Just destinationFS ->
+            FS.hardLinkOrCopyDirectoryRecursive hfs (Right destinationFS) reg sourcePath destinationPath
 
         -- Make the directory and its contents durable.
         FS.synchroniseDirectoryRecursive hfs hbio destinationPath