mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

convert renameExport to throw exception

Browse source 
Finishes the transition to make remote methods throw exceptions, rather
than silently hide them.

A bit on the fence about this one, because when renameExport fails,
it falls back to deleting instead, and so does the user care why it failed?

However, it did let me clean up several places in the code.

This commit was sponsored by Ethan Aubin.
This commit is contained in:
Joey Hess 2020-05-15 15:05:52 -04:00
parent 00448349de
commit 6361074174
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
11 changed files with 64 additions and 89 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

12
Command/Export.hs
View file

@ -396,13 +396,13 @@ startMoveFromTempName r db ek f = do
performRename :: Remote -> ExportHandle -> ExportKey -> ExportLocation -> ExportLocation -> CommandPerform
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"
tryNonAsync (renameExport (exportActions r) (asKey ek) src dest) >>= \case
Right (Just ()) -> next $ cleanupRename r db ek src dest
Left err -> do
warning $ "rename failed (" ++ show err ++ "); deleting instead"
fallbackdelete
-- Remote does not support renaming, so don't warn about it.
Nothing -> fallbackdelete
-- remote does not support renaming
Right Nothing -> fallbackdelete
where
fallbackdelete = performUnexport r db [ek] src

7
Remote/Adb.hs
View file

@ -269,8 +269,11 @@ checkPresentExportM r serial adir _k loc = checkKey' r serial aloc
where
aloc = androidExportLocation adir loc
renameExportM :: AndroidSerial -> AndroidPath -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe Bool)
renameExportM serial adir _k old new = Just <$> adbShellBool serial ps
renameExportM :: AndroidSerial -> AndroidPath -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe ())
renameExportM serial adir _k old new = do
unlessM (adbShellBool serial ps) $
giveup "adb failed"
return (Just ())
where
oldloc = fromAndroidPath $ androidExportLocation adir old
newloc = fromAndroidPath $ androidExportLocation adir new

14
Remote/Directory.hs
View file

@ -290,15 +290,13 @@ checkPresentExportM :: FilePath -> Key -> ExportLocation -> Annex Bool
checkPresentExportM d _k loc =
checkPresentGeneric d [exportPath d loc]
renameExportM :: FilePath -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe Bool)
renameExportM d _k oldloc newloc = liftIO $ Just <$> go
renameExportM :: FilePath -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe ())
renameExportM d _k oldloc newloc = liftIO $ do
createDirectoryUnder d (takeDirectory dest)
renameFile src dest
removeExportLocation d oldloc
return (Just ())
where
go = catchBoolIO $ do
createDirectoryUnder d (takeDirectory dest)
renameFile src dest
removeExportLocation d oldloc
return True
src = exportPath d oldloc
dest = exportPath d newloc

22
Remote/External.hs
View file

@ -342,26 +342,18 @@ removeExportDirectoryM external dir = either giveup return =<< go
_ -> Nothing
req = REMOVEEXPORTDIRECTORY dir
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
renameExportM :: External -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe ())
renameExportM external k src dest = either giveup return =<< go
where
go = handleRequestExport external src req k Nothing $ \resp -> case resp of
RENAMEEXPORT_SUCCESS k'
| k' == k -> result (Just True)
| k' == k -> result $ Right (Just ())
RENAMEEXPORT_FAILURE k'
| k' == k -> result (Just False)
UNSUPPORTED_REQUEST -> result Nothing
| k' == k -> result $ Left "failed to rename exported file"
UNSUPPORTED_REQUEST -> result (Right Nothing)
_ -> Nothing
where
req sk = RENAMEEXPORT sk dest
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 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
- the action to run for it (or Nothing if there's a protocol error).

2
Remote/Helper/ReadOnly.hs
View file

@ -62,7 +62,7 @@ readonlyRemoveExport _ _ = readonlyFail
readonlyRemoveExportDirectory :: ExportDirectory -> Annex ()
readonlyRemoveExportDirectory _ = readonlyFail
readonlyRenameExport :: Key -> ExportLocation -> ExportLocation -> Annex (Maybe Bool)
readonlyRenameExport :: Key -> ExportLocation -> ExportLocation -> Annex (Maybe ())
readonlyRenameExport _ _ _ = return Nothing
readonlyStoreExportWithContentIdentifier :: FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex ContentIdentifier

2
Remote/Rsync.hs
View file

@ -327,7 +327,7 @@ removeExportDirectoryM o ed = removeGeneric o (allbelow d : includes d)
Nothing -> []
Just f' -> includes f'
renameExportM :: RsyncOpts -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe Bool)
renameExportM :: RsyncOpts -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe ())
renameExportM _ _ _ _ = return Nothing
{- Rsync params to enable resumes of sending files safely,

22
Remote/S3.hs
View file

@ -508,15 +508,14 @@ 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 -> RemoteStateHandle -> S3Info -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe Bool)
renameExportS3 :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe ())
renameExportS3 hv r rs info k src dest = Just <$> go
where
go = withS3Handle hv $ \case
Just h -> checkVersioning' info rs k $
catchNonAsync (go' h) (\_ -> return False)
Nothing -> do
warning $ needS3Creds (uuid r)
return False
Just h -> do
checkVersioning info rs k
go' h
Nothing -> giveup $ needS3Creds (uuid r)
go' h = liftIO $ runResourceT $ do
let co = S3.copyObject (bucket info) dstobject
@ -525,7 +524,6 @@ renameExportS3 hv r rs info k src dest = Just <$> go
-- ACL is not preserved by copy.
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
@ -1291,13 +1289,3 @@ checkVersioning info rs k
[] -> giveup "Remote is configured to use versioning, but no S3 version ID is recorded for this key, so it cannot safely be modified."
_ -> return ()
| otherwise = return ()
checkVersioning' :: S3Info -> RemoteStateHandle -> Key -> Annex Bool -> Annex Bool
checkVersioning' info rs k a
| versioning info = getS3VersionID rs k >>= \case
[] -> do
warning $ "Remote is configured to use versioning, but no S3 version ID is recorded for this key, so it cannot safely be modified."
return False
_ -> a
| otherwise = a

56
Remote/WebDAV.hs
View file

@ -176,12 +176,10 @@ retrieveHelper loc d p = do
withContentM $ httpBodyRetriever d p
remove :: DavHandleVar -> Remover
remove hv k = withDavHandle' hv $ \case
Right dav -> liftIO $ goDAV dav $
-- Delete the key's whole directory, including any
-- legacy chunked files, etc, in a single action.
removeHelper (keyDir k)
Left e -> giveup e
remove hv k = withDavHandle hv $ \dav -> liftIO $ goDAV dav $
-- Delete the key's whole directory, including any
-- legacy chunked files, etc, in a single action.
removeHelper (keyDir k)
removeHelper :: DavLocation -> DAVT IO ()
removeHelper d = do
@ -220,11 +218,9 @@ retrieveExportDav hdl _k loc d p = case exportLocation loc of
checkPresentExportDav :: DavHandleVar -> Remote -> Key -> ExportLocation -> Annex Bool
checkPresentExportDav hdl _ _k loc = case exportLocation loc of
Right p -> withDavHandle' hdl $ \case
Left e -> giveup e
Right h -> liftIO $ do
v <- goDAV h $ existsDAV p
either giveup return v
Right p -> withDavHandle hdl $ \h -> liftIO $ do
v <- goDAV h $ existsDAV p
either giveup return v
Left err -> giveup err
removeExportDav :: DavHandleVar-> Key -> ExportLocation -> Annex ()
@ -244,25 +240,19 @@ removeExportDirectoryDav hdl dir = withDavHandle hdl $ \h -> runExport h $ \_dav
debugDav $ "delContent " ++ d
inLocation d delContentM
renameExportDav :: DavHandleVar -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe Bool)
renameExportDav :: DavHandleVar -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe ())
renameExportDav hdl _k src dest = case (exportLocation src, exportLocation dest) of
(Right srcl, Right destl) -> withDavHandle' hdl $ \case
Right h
-- box.com's DAV endpoint has buggy handling of renames,
-- so avoid renaming when using it.
| boxComUrl `isPrefixOf` baseURL h -> return Nothing
| otherwise -> do
v <- runExport' (Right h) $ \dav -> do
maybe noop (void . mkColRecursive) (locationParent destl)
moveDAV (baseURL dav) srcl destl
return True
return (Just v)
Left _e -> return (Just False)
_ -> return (Just False)
runExport' :: Either String DavHandle -> (DavHandle -> DAVT IO Bool) -> Annex Bool
runExport' (Left _e) _ = return False
runExport' (Right h) a = fromMaybe False <$> liftIO (goDAV h $ safely (a h))
(Right srcl, Right destl) -> withDavHandle hdl $ \h ->
-- box.com's DAV endpoint has buggy handling of renames,
-- so avoid renaming when using it.
if boxComUrl `isPrefixOf` baseURL h
then return Nothing
else runExport h $ \dav -> do
maybe noop (void . mkColRecursive) (locationParent destl)
moveDAV (baseURL dav) srcl destl
return (Just ())
(Left err, _) -> giveup err
(_, Left err) -> giveup err
runExport :: DavHandle -> (DavHandle -> DAVT IO a) -> Annex a
runExport h a = liftIO (goDAV h (a h))
@ -426,14 +416,6 @@ withDavHandle hv a = liftIO (readTVarIO hv) >>= \case
liftIO $ atomically $ writeTVar hv (Right hdl)
either giveup a hdl
withDavHandle' :: DavHandleVar -> (Either String DavHandle -> Annex a) -> Annex a
withDavHandle' hv a = liftIO (readTVarIO hv) >>= \case
Right hdl -> a hdl
Left mkhdl -> do
hdl <- mkhdl
liftIO $ atomically $ writeTVar hv (Right hdl)
a hdl
goDAV :: DavHandle -> DAVT IO a -> IO a
goDAV (DavHandle ctx user pass _) a = choke $ run $ prettifyExceptions $ do
prepDAV user pass

7
Types/Remote.hs
View file

@ -258,9 +258,12 @@ 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 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)
--
-- 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 ())
}
data ImportActions a = ImportActions

2
doc/bugs/filenames_with_dots_and_spaces_can_not_be_exported.mdwn
View file

@ -16,3 +16,5 @@ git-annex version: 8.20200309-05df404212, Debian testing
[[!meta title="change exception handling of remotes to avoid ever failing
without telling the reason why"]]
> [[done]] comprehensively --[[Joey]]

7
doc/bugs/filenames_with_dots_and_spaces_can_not_be_exported/comment_4_6889c0a21026038431dbe874711f0fe5._comment Normal file
View file

@ -0,0 +1,7 @@
[[!comment format=mdwn
username="joey"
subject="""comment 4"""
date="2020-05-15T18:54:23Z"
content="""
Done with converting all the methods.
"""]]