diff --git a/Command/Export.hs b/Command/Export.hs index 54d7dad79e..dec123442a 100644 --- a/Command/Export.hs +++ b/Command/Export.hs @@ -379,15 +379,16 @@ startMoveFromTempName r db ek f = do f' = getTopFilePath f performRename :: Remote -> ExportHandle -> ExportKey -> ExportLocation -> ExportLocation -> CommandPerform -performRename r db ek src dest = do - ifM (renameExport (exportActions r) (asKey ek) src dest) - ( next $ cleanupRename r db ek src dest - -- In case the special remote does not support renaming, - -- unexport the src instead. - , do +performRename r db ek src dest = + renameExport (exportActions r) (asKey ek) src dest >>= \case + Just True -> next $ cleanupRename r db ek src dest + Just False -> do warning "rename failed; deleting instead" - performUnexport r db [ek] src - ) + fallbackdelete + -- Remote does not support renaming, so don't warn about it. + Nothing -> fallbackdelete + where + fallbackdelete = performUnexport r db [ek] src cleanupRename :: Remote -> ExportHandle -> ExportKey -> ExportLocation -> ExportLocation -> CommandCleanup cleanupRename r db ek src dest = do diff --git a/Remote/Adb.hs b/Remote/Adb.hs index e27a3b679a..c0bc89a14f 100644 --- a/Remote/Adb.hs +++ b/Remote/Adb.hs @@ -222,9 +222,9 @@ checkPresentExportM r serial adir _k loc = checkKey' r serial aloc where aloc = androidExportLocation adir loc -renameExportM :: AndroidSerial -> AndroidPath -> Key -> ExportLocation -> ExportLocation -> Annex Bool -renameExportM serial adir _k old new = liftIO $ adbShellBool serial - [Param "mv", Param "-f", File oldloc, File newloc] +renameExportM :: AndroidSerial -> AndroidPath -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe Bool) +renameExportM serial adir _k old new = liftIO $ Just <$> + adbShellBool serial [Param "mv", Param "-f", File oldloc, File newloc] where oldloc = fromAndroidPath $ androidExportLocation adir old newloc = fromAndroidPath $ androidExportLocation adir new diff --git a/Remote/Directory.hs b/Remote/Directory.hs index 6c9ecf6d16..1d58c1357e 100644 --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -279,13 +279,15 @@ checkPresentExportM :: FilePath -> Key -> ExportLocation -> Annex Bool checkPresentExportM d _k loc = checkPresentGeneric d [exportPath d loc] -renameExportM :: FilePath -> Key -> ExportLocation -> ExportLocation -> Annex Bool -renameExportM d _k oldloc newloc = liftIO $ catchBoolIO $ do - createDirectoryIfMissing True (takeDirectory dest) - renameFile src dest - removeExportLocation d oldloc - return True +renameExportM :: FilePath -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe Bool) +renameExportM d _k oldloc newloc = liftIO $ Just <$> go where + go = catchBoolIO $ do + createDirectoryIfMissing True (takeDirectory dest) + renameFile src dest + removeExportLocation d oldloc + return True + src = exportPath d oldloc dest = exportPath d newloc diff --git a/Remote/External.hs b/Remote/External.hs index 849c686f2d..c0ab167110 100644 --- a/Remote/External.hs +++ b/Remote/External.hs @@ -307,25 +307,28 @@ removeExportDirectoryM external dir = safely $ where req = REMOVEEXPORTDIRECTORY dir -renameExportM :: External -> Key -> ExportLocation -> ExportLocation -> Annex Bool -renameExportM external k src dest = safely $ +renameExportM :: External -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe Bool) +renameExportM external k src dest = safely' (Just False) $ handleRequestExport external src req k Nothing $ \resp -> case resp of RENAMEEXPORT_SUCCESS k' - | k' == k -> result True + | k' == k -> result (Just True) RENAMEEXPORT_FAILURE k' - | k' == k -> result False - UNSUPPORTED_REQUEST -> result False + | k' == k -> result (Just False) + UNSUPPORTED_REQUEST -> result Nothing _ -> Nothing where req sk = RENAMEEXPORT sk dest safely :: Annex Bool -> Annex Bool -safely a = go =<< tryNonAsync a +safely = safely' False + +safely' :: a -> Annex a -> Annex a +safely' onerr a = go =<< tryNonAsync a where go (Right r) = return r go (Left e) = do toplevelWarning False (show e) - return False + return onerr {- Sends a Request to the external remote, and waits for it to generate - a Response. That is fed into the responsehandler, which should return diff --git a/Remote/Helper/ExportImport.hs b/Remote/Helper/ExportImport.hs index 908d2d5c75..d6f1f76bbb 100644 --- a/Remote/Helper/ExportImport.hs +++ b/Remote/Helper/ExportImport.hs @@ -43,7 +43,7 @@ instance HasExportUnsupported (ExportActions Annex) where , checkPresentExport = \_ _ -> return False , removeExport = \_ _ -> return False , removeExportDirectory = Just $ \_ -> return False - , renameExport = \_ _ _ -> return False + , renameExport = \_ _ _ -> return Nothing } -- | Use for remotes that do not support imports. @@ -170,7 +170,7 @@ adjustExportImport r = case M.lookup "exporttree" (config r) of -- lose modifications to the file -- (by eg copying and then deleting) -- so don't use it - , renameExport = \_ _ _ -> return False + , renameExport = \_ _ _ -> return Nothing , checkPresentExport = checkpresent } , checkPresent = if appendonly r' diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs index b60a05556e..c07d411847 100644 --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -293,8 +293,8 @@ removeExportDirectoryM o ed = removeGeneric o (allbelow d : includes d) Nothing -> [] Just f' -> includes f' -renameExportM :: RsyncOpts -> Key -> ExportLocation -> ExportLocation -> Annex Bool -renameExportM _ _ _ _ = return False +renameExportM :: RsyncOpts -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe Bool) +renameExportM _ _ _ _ = return Nothing {- Rsync params to enable resumes of sending files safely, - ensure that files are only moved into place once complete diff --git a/Remote/S3.hs b/Remote/S3.hs index b137fec43a..994116bd95 100644 --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -398,15 +398,17 @@ checkPresentExportS3 hv r info k loc = withS3Handle hv $ \case giveup "No S3 credentials configured" -- S3 has no move primitive; copy and delete. -renameExportS3 :: S3HandleVar -> Remote -> S3Info -> Key -> ExportLocation -> ExportLocation -> Annex Bool -renameExportS3 hv r info k src dest = withS3Handle hv $ \case - Just h -> checkVersioning info (uuid r) k $ - catchNonAsync (go h) (\_ -> return False) - Nothing -> do - warning $ needS3Creds (uuid r) - return False +renameExportS3 :: S3HandleVar -> Remote -> S3Info -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe Bool) +renameExportS3 hv r info k src dest = Just <$> go where - go h = liftIO $ runResourceT $ do + go = withS3Handle hv $ \case + Just h -> checkVersioning info (uuid r) k $ + catchNonAsync (go' h) (\_ -> return False) + Nothing -> do + warning $ needS3Creds (uuid r) + return False + + go' h = liftIO $ runResourceT $ do let co = S3.copyObject (bucket info) dstobject (S3.ObjectId (bucket info) srcobject Nothing) S3.CopyMetadata @@ -414,6 +416,7 @@ renameExportS3 hv r info k src dest = withS3Handle hv $ \case void $ sendS3Handle h $ co { S3.coAcl = acl info } void $ sendS3Handle h $ S3.DeleteObject srcobject (bucket info) return True + srcobject = T.pack $ bucketExportLocation info src dstobject = T.pack $ bucketExportLocation info dest diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs index 72ce79b543..4b74f04b46 100644 --- a/Remote/WebDAV.hs +++ b/Remote/WebDAV.hs @@ -239,19 +239,21 @@ removeExportDirectoryDav r dir = withDAVHandle r $ \mh -> runExport mh $ \_dav - safely (inLocation d delContentM) >>= maybe (return False) (const $ return True) -renameExportDav :: Remote -> Key -> ExportLocation -> ExportLocation -> Annex Bool +renameExportDav :: Remote -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe Bool) renameExportDav r _k src dest = case (exportLocation src, exportLocation dest) of (Right srcl, Right destl) -> withDAVHandle r $ \case Just h -- box.com's DAV endpoint has buggy handling of renames, -- so avoid renaming when using it. - | boxComUrl `isPrefixOf` baseURL h -> return False - | otherwise -> runExport (Just h) $ \dav -> do - maybe noop (void . mkColRecursive) (locationParent destl) - moveDAV (baseURL dav) srcl destl - return True - Nothing -> return False - _ -> return False + | boxComUrl `isPrefixOf` baseURL h -> return Nothing + | otherwise -> do + v <- runExport (Just h) $ \dav -> do + maybe noop (void . mkColRecursive) (locationParent destl) + moveDAV (baseURL dav) srcl destl + return True + return (Just v) + Nothing -> return (Just False) + _ -> return (Just False) runExport :: Maybe DavHandle -> (DavHandle -> DAVT IO Bool) -> Annex Bool runExport Nothing _ = return False diff --git a/Types/Remote.hs b/Types/Remote.hs index e4c46a20a0..569eee48a3 100644 --- a/Types/Remote.hs +++ b/Types/Remote.hs @@ -242,9 +242,9 @@ data ExportActions a = ExportActions -- Throws an exception if the remote cannot be accessed. , checkPresentExport :: Key -> ExportLocation -> a Bool -- Renames an already exported file. - -- This may fail, if the file doesn't exist, or the remote does not - -- support renames. - , renameExport :: Key -> ExportLocation -> ExportLocation -> a Bool + -- This may fail with False, if the file doesn't exist. + -- If the remote does not support renames, it can return Nothing. + , renameExport :: Key -> ExportLocation -> ExportLocation -> a (Maybe Bool) } data ImportActions a = ImportActions diff --git a/doc/design/external_special_remote_protocol.mdwn b/doc/design/external_special_remote_protocol.mdwn index df45a1ab80..36bf5cb92f 100644 --- a/doc/design/external_special_remote_protocol.mdwn +++ b/doc/design/external_special_remote_protocol.mdwn @@ -211,7 +211,8 @@ replying with `UNSUPPORTED-REQUEST` is acceptable. Requests the remote rename a file stored on it from the previously provided Name to the NewName. The remote responds with `RENAMEEXPORT-SUCCESS` or - `RENAMEEXPORT-FAILURE`. + `RENAMEEXPORT-FAILURE` or with `UNSUPPORTED-REQUEST` if renaming is not + supported. To support old external special remote programs that have not been updated to support exports, git-annex will need to handle an `ERROR` response @@ -318,7 +319,8 @@ while it's handling a request. * `REMOVEEXPORTDIRECTORY-FAILURE` Indicates that a `REMOVEEXPORTDIRECTORY` failed for whatever reason. * `UNSUPPORTED-REQUEST` - Indicates that the special remote does not know how to handle a request. + Indicates that the special remote does not know how to handle a request, + or cannot handle the request. ## special remote messages diff --git a/doc/todo/import_tree.mdwn b/doc/todo/import_tree.mdwn index 2fb8d083a2..33e2d6c3b2 100644 --- a/doc/todo/import_tree.mdwn +++ b/doc/todo/import_tree.mdwn @@ -10,10 +10,6 @@ this. ## implementation notes -* renameExport is disabled in a way that makes export tree - complain unncessarily verbosely. Perhaps change renameExport - to a Maybe so it can know when it's not available. - * Does export of master:subdir update the remote tracking branch right? * Does sync --content with remote.name.annex-tracking-branch=master:subdir