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,17 @@ module Database.LSMTree.Internal.FS (
   , hardLinkDirectoryRecursive
     -- * Copy file
   , copyFile
+    -- * Hard links with fallback
+  , Mode (..)
+  , 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 +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')