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

@@ -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
 			)
 

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 =

Remote/Adb.hs

@@ -256,10 +256,12 @@ removeExportM serial adir _k loc =
   where
 	aloc = androidExportLocation adir loc
 
-removeExportDirectoryM :: AndroidSerial -> AndroidPath -> ExportDirectory -> Annex Bool
+removeExportDirectoryM :: AndroidSerial -> AndroidPath -> ExportDirectory -> Annex ()
-removeExportDirectoryM serial abase dir = adbShellBool serial
+removeExportDirectoryM serial abase dir =
-	[Param "rm", Param "-rf", File (fromAndroidPath adir)]
+	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

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 -> ExportDirectory -> Annex ()
-removeExportDirectoryM external dir = safely $
+removeExportDirectoryM external dir = either giveup return =<< go
-	handleRequest external req Nothing $ \resp -> case resp of
-		REMOVEEXPORTDIRECTORY_SUCCESS -> result True
-		REMOVEEXPORTDIRECTORY_FAILURE -> result False
-		UNSUPPORTED_REQUEST -> result True
-		_ -> Nothing
   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 :: a -> Annex a -> Annex a
-safely = safely' False
+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

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

Remote/Helper/ReadOnly.hs

@@ -59,8 +59,8 @@ readonlyStoreExport _ _ _ _ = readonlyFail
 readonlyRemoveExport :: Key -> ExportLocation -> Annex ()
 readonlyRemoveExport _ _ = readonlyFail
 
-readonlyRemoveExportDirectory :: ExportDirectory -> Annex Bool
+readonlyRemoveExportDirectory :: ExportDirectory -> Annex ()
-readonlyRemoveExportDirectory _ = readonlyFail'
+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"

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 :: RsyncOpts -> ExportDirectory -> Annex ()
-removeExportDirectoryM o ed = removeGeneric' o (allbelow d : includes d)
+removeExportDirectoryM o ed = removeGeneric o (allbelow d : includes d)
   where
 	d = fromRawFilePath $ fromExportDirectory ed
 	allbelow f = f </> "***"

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 :: DavHandleVar -> ExportDirectory -> Annex ()
-removeExportDirectoryDav hdl dir = withDavHandle' hdl $ \mh -> runExport' mh $ \_dav -> do
+removeExportDirectoryDav hdl dir = withDavHandle hdl $ \h -> runExport h $ \_dav -> do
 	let d = fromRawFilePath $ fromExportDirectory dir
 	debugDav $ "delContent " ++ d
-	safely (inLocation d delContentM)
+	inLocation d delContentM
-		>>= maybe (return False) (const $ return True)
 
 renameExportDav :: DavHandleVar -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe Bool)
 renameExportDav hdl _k src dest = case (exportLocation src, exportLocation dest) of

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.