From 037440ef3680120eec9ecdaca7728d5dcdc5e9c4 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 15 May 2020 14:32:45 -0400 Subject: [PATCH] convert removeExportDirectory to throw exception Part of ongoing transition to make remote methods throw exceptions, rather than silently hide them. This commit was sponsored by Ilya Shlyakhter on Patreon. --- Command/Export.hs | 2 +- Command/TestRemote.hs | 6 +++--- Remote/Adb.hs | 8 +++++--- Remote/External.hs | 24 +++++++++++------------- Remote/Helper/ExportImport.hs | 4 ++-- Remote/Helper/ReadOnly.hs | 9 ++------- Remote/Rsync.hs | 19 ++----------------- Remote/WebDAV.hs | 7 +++---- Types/Remote.hs | 11 +++++++++-- 9 files changed, 38 insertions(+), 52 deletions(-) diff --git a/Command/Export.hs b/Command/Export.hs index d2c44ee627..7754f1bfa2 100644 --- a/Command/Export.hs +++ b/Command/Export.hs @@ -437,7 +437,7 @@ removeEmptyDirectories r db loc ks where go removeexportdirectory d = ifM (liftIO $ isExportDirectoryEmpty db d) - ( removeexportdirectory d + ( Remote.action $ removeexportdirectory d , return True ) diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs index bf09fb4102..dbef373c8b 100644 --- a/Command/TestRemote.hs +++ b/Command/TestRemote.hs @@ -307,9 +307,9 @@ testExportTree runannex mkr mkk1 mkk2 = , check "retrieve export fails after removal" $ \ea _k1 k2 -> not <$> retrieveexport ea k2 , check "remove export directory" $ \ea _k1 _k2 -> - removeexportdirectory ea + isRight <$> tryNonAsync (removeexportdirectory ea) , check "remove export directory that is already removed" $ \ea _k1 _k2 -> - removeexportdirectory ea + isRight <$> tryNonAsync (removeexportdirectory ea) -- renames are not tested because remotes do not need to support them ] where @@ -335,8 +335,8 @@ testExportTree runannex mkr mkk1 mkk2 = checkpresentexport ea k = Remote.checkPresentExport ea k testexportlocation removeexport ea k = Remote.removeExport ea k testexportlocation removeexportdirectory ea = case Remote.removeExportDirectory ea of - Nothing -> return True Just a -> a (mkExportDirectory (toRawFilePath testexportdirectory)) + Nothing -> noop testUnavailable :: RunAnnex -> Annex (Maybe Remote) -> Annex Key -> [TestTree] testUnavailable runannex mkr mkk = diff --git a/Remote/Adb.hs b/Remote/Adb.hs index bf6c1c0d16..39fbc2fdb0 100644 --- a/Remote/Adb.hs +++ b/Remote/Adb.hs @@ -256,10 +256,12 @@ removeExportM serial adir _k loc = where aloc = androidExportLocation adir loc -removeExportDirectoryM :: AndroidSerial -> AndroidPath -> ExportDirectory -> Annex Bool -removeExportDirectoryM serial abase dir = adbShellBool serial - [Param "rm", Param "-rf", File (fromAndroidPath adir)] +removeExportDirectoryM :: AndroidSerial -> AndroidPath -> ExportDirectory -> Annex () +removeExportDirectoryM serial abase dir = + unlessM go $ + giveup "adb failed" where + go = adbShellBool serial [Param "rm", Param "-rf", File (fromAndroidPath adir)] adir = androidExportLocation abase (mkExportLocation (fromExportDirectory dir)) checkPresentExportM :: Remote -> AndroidSerial -> AndroidPath -> Key -> ExportLocation -> Annex Bool diff --git a/Remote/External.hs b/Remote/External.hs index 1fe7cea63d..1a819ce876 100644 --- a/Remote/External.hs +++ b/Remote/External.hs @@ -331,18 +331,19 @@ removeExportM external k loc = either giveup return =<< go Left $ "REMOVEEXPORT not implemented by external special remote" _ -> Nothing -removeExportDirectoryM :: External -> ExportDirectory -> Annex Bool -removeExportDirectoryM external dir = safely $ - handleRequest external req Nothing $ \resp -> case resp of - REMOVEEXPORTDIRECTORY_SUCCESS -> result True - REMOVEEXPORTDIRECTORY_FAILURE -> result False - UNSUPPORTED_REQUEST -> result True - _ -> Nothing +removeExportDirectoryM :: External -> ExportDirectory -> Annex () +removeExportDirectoryM external dir = either giveup return =<< go where + go = handleRequest external req Nothing $ \resp -> case resp of + REMOVEEXPORTDIRECTORY_SUCCESS -> result $ Right () + REMOVEEXPORTDIRECTORY_FAILURE -> result $ + Left "failed to remove directory" + UNSUPPORTED_REQUEST -> result $ Right () + _ -> Nothing req = REMOVEEXPORTDIRECTORY dir renameExportM :: External -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe Bool) -renameExportM external k src dest = safely' (Just False) $ +renameExportM external k src dest = safely (Just False) $ handleRequestExport external src req k Nothing $ \resp -> case resp of RENAMEEXPORT_SUCCESS k' | k' == k -> result (Just True) @@ -353,11 +354,8 @@ renameExportM external k src dest = safely' (Just False) $ where req sk = RENAMEEXPORT sk dest -safely :: Annex Bool -> Annex Bool -safely = safely' False - -safely' :: a -> Annex a -> Annex a -safely' onerr a = go =<< tryNonAsync a +safely :: a -> Annex a -> Annex a +safely onerr a = go =<< tryNonAsync a where go (Right r) = return r go (Left e) = do diff --git a/Remote/Helper/ExportImport.hs b/Remote/Helper/ExportImport.hs index ae26784cb0..fdc3d2e2c3 100644 --- a/Remote/Helper/ExportImport.hs +++ b/Remote/Helper/ExportImport.hs @@ -40,7 +40,7 @@ instance HasExportUnsupported (ExportActions Annex) where , retrieveExport = nope , checkPresentExport = \_ _ -> return False , removeExport = nope - , removeExportDirectory = Just $ \_ -> return False + , removeExportDirectory = nope , renameExport = \_ _ _ -> return Nothing } where @@ -59,7 +59,7 @@ instance HasImportUnsupported (ImportActions Annex) where , retrieveExportWithContentIdentifier = nope , storeExportWithContentIdentifier = nope , removeExportWithContentIdentifier = nope - , removeExportDirectoryWhenEmpty = Just $ \_ -> return False + , removeExportDirectoryWhenEmpty = nope , checkPresentExportWithContentIdentifier = \_ _ _ -> return False } where diff --git a/Remote/Helper/ReadOnly.hs b/Remote/Helper/ReadOnly.hs index fa5f3335bb..93bbb7519b 100644 --- a/Remote/Helper/ReadOnly.hs +++ b/Remote/Helper/ReadOnly.hs @@ -59,8 +59,8 @@ readonlyStoreExport _ _ _ _ = readonlyFail readonlyRemoveExport :: Key -> ExportLocation -> Annex () readonlyRemoveExport _ _ = readonlyFail -readonlyRemoveExportDirectory :: ExportDirectory -> Annex Bool -readonlyRemoveExportDirectory _ = readonlyFail' +readonlyRemoveExportDirectory :: ExportDirectory -> Annex () +readonlyRemoveExportDirectory _ = readonlyFail readonlyRenameExport :: Key -> ExportLocation -> ExportLocation -> Annex (Maybe Bool) readonlyRenameExport _ _ _ = return Nothing @@ -74,10 +74,5 @@ readonlyRemoveExportWithContentIdentifier _ _ _ = readonlyFail readonlyFail :: Annex a readonlyFail = giveup readonlyWarning -readonlyFail' :: Annex Bool -readonlyFail' = do - warning readonlyWarning - return False - readonlyWarning :: String readonlyWarning = "this remote is readonly" diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs index 0d28aef401..bf4ddc2aee 100644 --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -277,21 +277,6 @@ removeGeneric o includes = do unless ok $ giveup "rsync failed" -removeGeneric' :: RsyncOpts -> [String] -> Annex Bool -removeGeneric' o includes = do - ps <- sendParams - opts <- rsyncOptions o - withRsyncScratchDir $ \tmp -> liftIO $ do - {- Send an empty directory to rysnc to make it delete. -} - rsync $ opts ++ ps ++ - map (\s -> Param $ "--include=" ++ s) includes ++ - [ Param "--exclude=*" -- exclude everything else - , Param "--quiet", Param "--delete", Param "--recursive" - ] ++ partialParams ++ - [ Param $ addTrailingPathSeparator tmp - , Param $ rsyncUrl o - ] - checkKey :: Git.Repo -> RsyncOpts -> CheckPresent checkKey r o k = do showChecking r @@ -333,8 +318,8 @@ removeExportM o _k loc = Nothing -> [] Just f' -> includes f' -removeExportDirectoryM :: RsyncOpts -> ExportDirectory -> Annex Bool -removeExportDirectoryM o ed = removeGeneric' o (allbelow d : includes d) +removeExportDirectoryM :: RsyncOpts -> ExportDirectory -> Annex () +removeExportDirectoryM o ed = removeGeneric o (allbelow d : includes d) where d = fromRawFilePath $ fromExportDirectory ed allbelow f = f "***" diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs index c0cbb33b38..748a8ae7f0 100644 --- a/Remote/WebDAV.hs +++ b/Remote/WebDAV.hs @@ -238,12 +238,11 @@ removeExportDav hdl _k loc = case exportLocation loc of -- this will be called to make sure it's gone. Left _err -> return () -removeExportDirectoryDav :: DavHandleVar -> ExportDirectory -> Annex Bool -removeExportDirectoryDav hdl dir = withDavHandle' hdl $ \mh -> runExport' mh $ \_dav -> do +removeExportDirectoryDav :: DavHandleVar -> ExportDirectory -> Annex () +removeExportDirectoryDav hdl dir = withDavHandle hdl $ \h -> runExport h $ \_dav -> do let d = fromRawFilePath $ fromExportDirectory dir debugDav $ "delContent " ++ d - safely (inLocation d delContentM) - >>= maybe (return False) (const $ return True) + inLocation d delContentM renameExportDav :: DavHandleVar -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe Bool) renameExportDav hdl _k src dest = case (exportLocation src, exportLocation dest) of diff --git a/Types/Remote.hs b/Types/Remote.hs index d3b46dacf3..68044dfd0c 100644 --- a/Types/Remote.hs +++ b/Types/Remote.hs @@ -247,8 +247,12 @@ data ExportActions a = ExportActions -- and it's ok to delete those (but not required to). -- If the remote does not use directories, or automatically cleans -- up empty directories, this can be Nothing. + -- -- Should not fail if the directory was already removed. - , removeExportDirectory :: Maybe (ExportDirectory -> a Bool) + -- + -- Throws exception if unable to contact the remote, or perhaps if + -- the remote refuses to let the directory be removed. + , removeExportDirectory :: Maybe (ExportDirectory -> a ()) -- Checks if anything is exported to the remote at the specified -- ExportLocation. -- Throws an exception if the remote cannot be accessed. @@ -329,7 +333,10 @@ data ImportActions a = ImportActions -- supports imports. -- -- If the directory is not empty, it should succeed. - , removeExportDirectoryWhenEmpty :: Maybe (ExportDirectory -> a Bool) + -- + -- Throws exception if unable to contact the remote, or perhaps if + -- the remote refuses to let the directory be removed. + , removeExportDirectoryWhenEmpty :: Maybe (ExportDirectory -> a ()) -- Checks if the specified ContentIdentifier is exported to the -- remote at the specified ExportLocation. -- Throws an exception if the remote cannot be accessed.