export tree: avoid confusing output about renaming files

When a file in the export is renamed, and the remote's renameExport
returned Nothing, renaming to the temp file would first say it was
renaming, and appear to succeed, but actually what it did was delete the
file. Then renaming from the temp file would not do anything, since the
temp file is not present on the remote. This appeared as if a file got
renamed to a temp file and left there.

Note that exporttree=yes importree=yes remotes have their usual
renameExport replaced with one that returns Nothing. (For reasons
explained in Remote.Helper.ExportImport.) So this happened
even with remotes that support renameExport.

Fix by letting renameExport = Nothing when it's not supported at all.
This avoids displaying the rename.

Sponsored-by: Graham Spencer on Patreon

diff --git a/Command/Export.hs b/Command/Export.hs
index bca9c9ffed4eb3bb86dae35226b4cb0f1fd3ee0f..d0604aa8e1a12500c6241e9209847e170c39dfa4 100644 (file)
--- a/Command/Export.hs
+++ b/Command/Export.hs
@@ -406,9 +406,10 @@ startRecoverIncomplete r db sha oldf
        oldloc = mkExportLocation $ getTopFilePath oldf
 
 startMoveToTempName :: Remote -> ExportHandle -> TopFilePath -> Key -> CommandStart
-startMoveToTempName r db f ek = 
-       starting ("rename " ++ name r) ai si $
+startMoveToTempName r db f ek = case renameExport (exportActions r) of
+       Just _ -> starting ("rename " ++ name r) ai si $
                performRename r db ek loc tmploc
+       Nothing -> stop
   where
        loc = mkExportLocation f'
        f' = getTopFilePath f
@@ -418,27 +419,29 @@ startMoveToTempName r db f ek =
        si = SeekInput []
 
 startMoveFromTempName :: Remote -> ExportHandle -> Key -> TopFilePath -> CommandStart
-startMoveFromTempName r db ek f = do
-       let tmploc = exportTempName ek
-       let ai = ActionItemOther $ Just $
-               QuotedPath (fromExportLocation tmploc) <> " -> " <> QuotedPath f'
-       stopUnless (liftIO $ elem tmploc <$> getExportedLocation db ek) $
+startMoveFromTempName r db ek f = case renameExport (exportActions r) of
+       Just _ -> stopUnless (liftIO $ elem tmploc <$> getExportedLocation db ek) $
                starting ("rename " ++ name r) ai si $
                        performRename r db ek tmploc loc
+       Nothing -> stop
   where
        loc = mkExportLocation f'
        f' = getTopFilePath f
+       tmploc = exportTempName ek
+       ai = ActionItemOther $ Just $
+               QuotedPath (fromExportLocation tmploc) <> " -> " <> QuotedPath f'
        si = SeekInput []
 
 performRename :: Remote -> ExportHandle -> Key -> ExportLocation -> ExportLocation -> CommandPerform
-performRename r db ek src dest =
-       tryNonAsync (renameExport (exportActions r) ek src dest) >>= \case
+performRename r db ek src dest = case renameExport (exportActions r) of
+       Just renameaction -> tryNonAsync (renameaction ek src dest) >>= \case
                Right (Just ()) -> next $ cleanupRename r db ek src dest
                Left err -> do
                        warning $ UnquotedString $ "rename failed (" ++ show err ++ "); deleting instead"
                        fallbackdelete
-               -- remote does not support renaming
                Right Nothing -> fallbackdelete
+       -- remote does not support renaming
+       Nothing -> fallbackdelete
   where
        fallbackdelete = performUnexport r db [ek] src
 

diff --git a/Remote/Adb.hs b/Remote/Adb.hs
index 214733080cc51a530bfed2642ad1576815a27ebf..9848833147302c50c0554bbee440117156412891 100644 (file)
--- a/Remote/Adb.hs
+++ b/Remote/Adb.hs
@@ -94,7 +94,7 @@ gen r u rc gc rs = do
                        , versionedExport = False
                        , checkPresentExport = checkPresentExportM serial adir
                        , removeExportDirectory = Just $ removeExportDirectoryM serial adir
-                       , renameExport = renameExportM serial adir
+                       , renameExport = Just $ renameExportM serial adir
                        }
                , importActions = ImportActions
                        { listImportableContents = listImportableContentsM serial adir c

diff --git a/Remote/Directory.hs b/Remote/Directory.hs
index c83064ad7849cd62c0dbc3551b8b5aeac252da8d..82b7f114f04d58039abe3e6f64efea7f32f65990 100644 (file)
--- a/Remote/Directory.hs
+++ b/Remote/Directory.hs
@@ -112,7 +112,7 @@ gen r u rc gc rs = do
                                -- Not needed because removeExportLocation
                                -- auto-removes empty directories.
                                , removeExportDirectory = Nothing
-                               , renameExport = renameExportM dir
+                               , renameExport = Just $ renameExportM dir
                                }
                        , importActions = ImportActions
                                { listImportableContents = listImportableContentsM ii dir

diff --git a/Remote/External.hs b/Remote/External.hs
index d75c3ebb4558b5e5682c468d7a1bf4018d34cf2d..9b9961c7d1d5c27f10b846b27d8c7483ba914bd8 100644 (file)
--- a/Remote/External.hs
+++ b/Remote/External.hs
@@ -98,7 +98,7 @@ gen r u rc gc rs
                                , versionedExport = False
                                , checkPresentExport = checkPresentExportM external
                                , removeExportDirectory = Just $ removeExportDirectoryM external
-                               , renameExport = renameExportM external
+                               , renameExport = Just $ renameExportM external
                                }
                        else exportUnsupported
                -- Cheap exportSupported that replaces the expensive

diff --git a/Remote/Helper/ExportImport.hs b/Remote/Helper/ExportImport.hs
index 377c4a7274a103ea442e58e0238ca4fcdc08baae..6d95ad1cf2b9f92ba0534d38f25163d96ec476ec 100644 (file)
--- a/Remote/Helper/ExportImport.hs
+++ b/Remote/Helper/ExportImport.hs
@@ -41,7 +41,7 @@ instance HasExportUnsupported (ExportActions Annex) where
                , removeExport = nope
                , versionedExport = False
                , removeExportDirectory = nope
-               , renameExport = \_ _ _ -> return Nothing
+               , renameExport = Nothing
                }
         where
                nope = giveup "export not supported"
@@ -257,7 +257,7 @@ adjustExportImport' isexport isimport r rs = do
                -- renameExport is optional, and the remote's
                -- implementation may lose modifications to the file
                -- (by eg copying and then deleting) so don't use it
-               , renameExport = \_ _ _ -> return Nothing
+               , renameExport = Nothing
                , checkPresentExport = checkPresentImport ciddbv
                }
        

diff --git a/Remote/Helper/ReadOnly.hs b/Remote/Helper/ReadOnly.hs
index 71e31fdd0b015b98b8c18d52d4117da3535adbff..abce2fe2f4117bfe8ea4ade4fd00c1f299faa787 100644 (file)
--- a/Remote/Helper/ReadOnly.hs
+++ b/Remote/Helper/ReadOnly.hs
@@ -34,7 +34,7 @@ adjustReadOnly r
                        { storeExport = readonlyStoreExport
                        , removeExport = readonlyRemoveExport
                        , removeExportDirectory = Just readonlyRemoveExportDirectory
-                       , renameExport = readonlyRenameExport
+                       , renameExport = Nothing
                        }
                , importActions = (importActions r)
                        { storeExportWithContentIdentifier = readonlyStoreExportWithContentIdentifier
@@ -62,9 +62,6 @@ readonlyRemoveExport _ _ = readonlyFail
 readonlyRemoveExportDirectory :: ExportDirectory -> Annex ()
 readonlyRemoveExportDirectory _ = readonlyFail
 
-readonlyRenameExport :: Key -> ExportLocation -> ExportLocation -> Annex (Maybe ())
-readonlyRenameExport _ _ _ = return Nothing
-
 readonlyStoreExportWithContentIdentifier :: FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex ContentIdentifier
 readonlyStoreExportWithContentIdentifier _ _ _ _ _ = readonlyFail
 

diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs
index aaf0848b868ecba966076ae3c7ab8fdd2c4e802e..b225f8db14575a6963e4a882c507c3d10150446c 100644 (file)
--- a/Remote/Rsync.hs
+++ b/Remote/Rsync.hs
@@ -106,7 +106,7 @@ gen r u rc gc rs = do
                                , versionedExport = False
                                , checkPresentExport = checkPresentExportM o
                                , removeExportDirectory = Just (removeExportDirectoryM o)
-                               , renameExport = renameExportM o
+                               , renameExport = Just $ renameExportM o
                                }
                        , importActions = importUnsupported
                        , whereisKey = Nothing

diff --git a/Remote/S3.hs b/Remote/S3.hs
index a2ab5a61ffc52e0f354a0747676df27f174bc0ae..d2db401fe91917091ca71492beb8093b74e629dd 100644 (file)
--- a/Remote/S3.hs
+++ b/Remote/S3.hs
@@ -228,7 +228,7 @@ gen r u rc gc rs = do
                                , checkPresentExport = checkPresentExportS3 hdl this info
                                -- S3 does not have directories.
                                , removeExportDirectory = Nothing
-                               , renameExport = renameExportS3 hdl this rs info
+                               , renameExport = Just $ renameExportS3 hdl this rs info
                                }
                        , importActions = ImportActions
                                 { listImportableContents = listImportableContentsS3 hdl this info c

diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs
index 08594dfba4759cad7563862f4ab1e9179b4eb541..ab781c390ef5803054e1406bdd3c9e2b7a887c83 100644 (file)
--- a/Remote/WebDAV.hs
+++ b/Remote/WebDAV.hs
@@ -104,7 +104,7 @@ gen r u rc gc rs = do
                                , versionedExport = False
                                , removeExportDirectory = Just $
                                        removeExportDirectoryDav hdl
-                               , renameExport = renameExportDav hdl
+                               , renameExport = Just $ renameExportDav hdl
                                }
                        , importActions = importUnsupported
                        , whereisKey = Nothing

diff --git a/Types/Remote.hs b/Types/Remote.hs
index 971c4a87c6a22e7c03c697dabe143b9182d699fa..e4575eb3cd17391f6555fae8e221d5bd0922566f 100644 (file)
--- a/Types/Remote.hs
+++ b/Types/Remote.hs
@@ -302,7 +302,7 @@ data ExportActions a = ExportActions
        --
        -- Throws an exception if the remote cannot be accessed, or
        -- the file doesn't exist or cannot be renamed.
-       , renameExport :: Key -> ExportLocation -> ExportLocation -> a (Maybe ())
+       , renameExport :: Maybe (Key -> ExportLocation -> ExportLocation -> a (Maybe ()))
        }
 
 data ImportActions a = ImportActions