make removeKey throw exceptions

Command/Drop.hs

@@ -131,7 +131,11 @@ performRemote key afile numcopies remote = do
 				, "proof:"
 				, show proof
 				]
-			ok <- Remote.removeKey remote key
+			ok <- tryNonAsync (Remote.removeKey remote key) >>= \case
+				Right () -> return True
+				Left e -> do
+					warning (show e)
+					return False
 			next $ cleanupRemote key remote ok
 		, stop
 		)

Command/Fsck.hs

@@ -539,14 +539,14 @@ badContentRemote remote localcopy key = do
 					)
 		)
 
-	dropped <- Remote.removeKey remote key
-	when dropped $
+	dropped <- tryNonAsync (Remote.removeKey remote key)
+	when (isRight dropped) $
 		Remote.logStatus remote key InfoMissing
 	return $ case (movedbad, dropped) of
-		(True, True) -> "moved from " ++ Remote.name remote ++
+		(True, Right ()) -> "moved from " ++ Remote.name remote ++
 			" to " ++ destbad
-		(False, True) -> "dropped from " ++ Remote.name remote
-		(_, False) -> "failed to drop from" ++ Remote.name remote
+		(False, Right ()) -> "dropped from " ++ Remote.name remote
+		(_, Left e) -> "failed to drop from" ++ Remote.name remote ++ ": " ++ show e
 
 runFsck :: Incremental -> ActionItem -> Key -> Annex Bool -> CommandStart
 runFsck inc ai key a = stopUnless (needFsck inc key) $

Command/Move.hs

@@ -232,7 +232,11 @@ fromPerform src removewhen key afile = do
 			, show src
 			, "(" ++ reason ++ ")"
 			]
-		ok <- Remote.removeKey src key
+		ok <- tryNonAsync (Remote.removeKey src key) >>= \case
+			Right () -> return True
+			Left e -> do
+				warning (show e)
+				return False
 		next $ Command.Drop.cleanupRemote key src ok
 	faileddropremote = do
 		showLongNote "(Use --force to override this check, or adjust numcopies.)"

Command/TestRemote.hs

@@ -214,7 +214,7 @@ mkTestTrees runannex mkrs mkunavailr mkexportr mkks = concat $
 test :: RunAnnex -> Annex (Maybe Remote) -> Annex Key -> [TestTree]
 test runannex mkr mkk =
 	[ check "removeKey when not present" $ \r k ->
-		whenwritable r $ remove r k
+		whenwritable r $ isRight <$> tryNonAsync (remove r k)
 	, check ("present " ++ show False) $ \r k ->
 		whenwritable r $ present r k False
 	, check "storeKey" $ \r k ->
@@ -252,7 +252,7 @@ test runannex mkr mkk =
 		get r k
 	, check "fsck downloaded object" fsck
 	, check "removeKey when present" $ \r k -> 
-		whenwritable r $ remove r k
+		whenwritable r $ isRight <$> tryNonAsync (remove r k)
 	, check ("present " ++ show False) $ \r k -> 
 		whenwritable r $ present r k False
 	]
@@ -341,7 +341,7 @@ testExportTree runannex mkr mkk1 mkk2 =
 
 testUnavailable :: RunAnnex -> Annex (Maybe Remote) -> Annex Key -> [TestTree]
 testUnavailable runannex mkr mkk =
-	[ check (== Right False) "removeKey" $ \r k ->
+	[ check isLeft "removeKey" $ \r k ->
 		Remote.removeKey r k
 	, check isLeft "storeKey" $ \r k -> 
 		Remote.storeKey r k (AssociatedFile Nothing) nullMeterUpdate

Remote/Adb.hs

@@ -199,7 +199,9 @@ retrieve' serial src dest = checkAdbInPath False $ do
 		]
 
 remove :: AndroidSerial -> AndroidPath -> Remover
-remove serial adir k = remove' serial (androidLocation adir k)
+remove serial adir k =
+	unlessM (remove' serial (androidLocation adir k)) $
+		giveup "adb failed"
 
 remove' :: AndroidSerial -> AndroidPath -> Annex Bool
 remove' serial aloc = adbShellBool serial

Remote/BitTorrent.hs

@@ -112,10 +112,8 @@ downloadKey key _file dest p = do
 uploadKey :: Key -> AssociatedFile -> MeterUpdate -> Annex ()
 uploadKey _ _ _ = giveup "upload to bittorrent not supported"
 
-dropKey :: Key -> Annex Bool
-dropKey k = do
-	mapM_ (setUrlMissing k) =<< getBitTorrentUrls k
-	return True
+dropKey :: Key -> Annex ()
+dropKey k = mapM_ (setUrlMissing k) =<< getBitTorrentUrls k
 
 {- We punt and don't try to check if a torrent has enough seeders
  - with all the pieces etc. That would be quite hard.. and even if

Remote/Bup.hs

@@ -177,8 +177,7 @@ retrieve buprepo = byteRetriever $ \k sink -> do
 remove :: BupRepo -> Remover
 remove buprepo k = do
 	go =<< liftIO (bup2GitRemote buprepo)
-	warning "content cannot be completely removed from bup remote"
-	return True
+	giveup "content cannot be completely removed from bup remote"
   where
 	go r
 		| Git.repoIsUrl r = void $ onBupRemote r boolSystem "git" params

Remote/Ddar.hs

@@ -166,7 +166,8 @@ remove :: DdarRepo -> Remover
 remove ddarrepo key = do
 	(cmd, params) <- ddarRemoteCall NoConsumeStdin ddarrepo 'd'
 		[Param $ serializeKey key]
-	liftIO $ boolSystem cmd params
+	unlessM (liftIO $ boolSystem cmd params) $
+		giveup "ddar failed to remove"
 
 ddarDirectoryExists :: DdarRepo -> Annex (Either String Bool)
 ddarDirectoryExists ddarrepo

Remote/Directory.hs

@@ -226,14 +226,14 @@ removeKeyM d k = liftIO $ removeDirGeneric d (storeDir d k)
 {- Removes the directory, which must be located under the topdir.
  -
  - Succeeds even on directories and contents that do not have write
- - permission.
+ - permission, if it's possible to turn the write bit on.
  -
  - If the directory does not exist, succeeds as long as the topdir does
  - exist. If the topdir does not exist, fails, because in this case the
  - remote is not currently accessible and probably still has the content
  - we were supposed to remove from it.
  -}
-removeDirGeneric :: FilePath -> FilePath -> IO Bool
+removeDirGeneric :: FilePath -> FilePath -> IO ()
 removeDirGeneric topdir dir = do
 	void $ tryIO $ allowWrite dir
 #ifdef mingw32_HOST_OS
@@ -241,12 +241,11 @@ removeDirGeneric topdir dir = do
 	 - before it can delete them. -}
 	void $ tryIO $ mapM_ allowWrite =<< dirContents dir
 #endif
-	ok <- catchBoolIO $ do
-		removeDirectoryRecursive dir
-		return True
-	if ok
-		then return ok
-		else doesDirectoryExist topdir <&&> (not <$> doesDirectoryExist dir)
+	tryNonAsync (removeDirectoryRecursive dir) >>= \case
+		Right () -> return ()
+		Left e ->
+			unlessM (doesDirectoryExist topdir <&&> (not <$> doesDirectoryExist dir)) $
+				throwM e
 
 checkPresentM :: FilePath -> ChunkConfig -> CheckPresent
 checkPresentM d (LegacyChunks _) k = Legacy.checkKey d locations k

Remote/External.hs

@@ -222,7 +222,8 @@ checkExportSupported' external = go `catchNonAsync` (const (return False))
 		_ -> Nothing
 
 storeKeyM :: External -> Storer
-storeKeyM external = fileStorer $ \k f p -> either giveup return =<< go k f p
+storeKeyM external = fileStorer $ \k f p ->
+	either giveup return =<< go k f p
   where
 	go k f p = handleRequestKey external (\sk -> TRANSFER Upload sk f) k (Just p) $ \resp ->
 		case resp of
@@ -233,26 +234,28 @@ storeKeyM external = fileStorer $ \k f p -> either giveup return =<< go k f p
 			_ -> Nothing
 
 retrieveKeyFileM :: External -> Retriever
-retrieveKeyFileM external = fileRetriever $ \d k p -> 
-	handleRequestKey external (\sk -> TRANSFER Download sk d) k (Just p) $ \resp ->
+retrieveKeyFileM external = fileRetriever $ \d k p ->
+	either giveup return =<< go d k p
+  where
+	go d k p = handleRequestKey external (\sk -> TRANSFER Download sk d) k (Just p) $ \resp ->
 		case resp of
 			TRANSFER_SUCCESS Download k'
-				| k == k' -> result ()
+				| k == k' -> result $ Right ()
 			TRANSFER_FAILURE Download k' errmsg
-				| k == k' -> Just $ giveup $
+				| k == k' -> result $ Left $
 					respErrorMessage "TRANSFER" errmsg
 			_ -> Nothing
 
 removeKeyM :: External -> Remover
-removeKeyM external k = safely $ 
-	handleRequestKey external REMOVE k Nothing $ \resp ->
+removeKeyM external k = either giveup return =<< go
+  where
+	go = handleRequestKey external REMOVE k Nothing $ \resp ->
 		case resp of
 			REMOVE_SUCCESS k'
-				| k == k' -> result True
+				| k == k' -> result $ Right ()
 			REMOVE_FAILURE k' errmsg
-				| k == k' -> Just $ do
-					warning $ respErrorMessage "REMOVE" errmsg
-					return (Result False)
+				| k == k' -> result $ Left $
+					respErrorMessage "REMOVE" errmsg
 			_ -> Nothing
 
 checkPresentM :: External -> CheckPresent

Remote/GCrypt.hs

@@ -413,7 +413,7 @@ remove r rsyncopts k = do
 
 remove' :: Git.Repo -> Remote -> Remote.Rsync.RsyncOpts -> Remover
 remove' repo r rsyncopts k
-	| not $ Git.repoIsUrl repo = guardUsable repo (return False) $
+	| not $ Git.repoIsUrl repo = guardUsable repo (giveup "cannot access remote") $
 		liftIO $ Remote.Directory.removeDirGeneric (Git.repoLocation repo) (parentDir (gCryptLocation repo k))
 	| Git.repoIsSsh repo = shellOrRsync r removeshell removersync
 	| otherwise = unsupportedUrl

Remote/Git.hs

@@ -423,31 +423,26 @@ keyUrls gc repo r key = map tourl locs'
 #endif
 	remoteconfig = gitconfig r
 
-dropKey :: Remote -> State -> Key -> Annex Bool
+dropKey :: Remote -> State -> Key -> Annex ()
 dropKey r st key = do
 	repo <- getRepo r
-	catchNonAsync
-		(dropKey' repo r st key)
-		(\e -> warning (show e) >> return False)
+	dropKey' repo r st key
 
-dropKey' :: Git.Repo -> Remote -> State -> Key -> Annex Bool
+dropKey' :: Git.Repo -> Remote -> State -> Key -> Annex ()
 dropKey' repo r st@(State connpool duc _ _ _) key
 	| not $ Git.repoIsUrl repo = ifM duc
-		( guardUsable repo (return False) $
+		( guardUsable repo (giveup "cannot access remote") $
 			commitOnCleanup repo r st $ onLocalFast st $ do
 				whenM (Annex.Content.inAnnex key) $ do
 					Annex.Content.lockContentForRemoval key $ \lock -> do
 						Annex.Content.removeAnnex lock
 						logStatus key InfoMissing
 					Annex.Content.saveState True
-				return True
-		, return False
+		, giveup "remote does not have expected annex.uuid value"
 		)
-	| Git.repoIsHttp repo = do
-		warning "dropping from http remote not supported"
-		return False
+	| Git.repoIsHttp repo = giveup "dropping from http remote not supported"
 	| otherwise = commitOnCleanup repo r st $ do
-		let fallback = Ssh.dropKey repo key
+		let fallback = Ssh.dropKey' repo key
 		P2PHelper.remove (Ssh.runProto r connpool (return False) fallback) key
 
 lockKey :: Remote -> State -> Key -> (VerifiedCopy -> Annex r) -> Annex r

Remote/GitLFS.hs

@@ -526,6 +526,4 @@ checkKey rs h key = getLFSEndpoint LFS.RequestDownload h >>= \case
 				| otherwise -> return True
 
 remove :: TVar LFSHandle -> Remover
-remove _h _key = do
-	warning "git-lfs does not support removing content"
-	return False
+remove _h _key = giveup "git-lfs does not support removing content"

Remote/Glacier.hs

@@ -201,13 +201,15 @@ retrieve' r k sink = go =<< glacierEnv c gc u
 			sink =<< liftIO (L.hGetContents h)
 
 remove :: Remote -> Remover
-remove r k = glacierAction r
-	[ Param "archive"
-	
-	, Param "delete"
-	, Param $ getVault $ config r
-	, Param $ archive r k
-	]
+remove r k = unlessM go $
+	giveup "removal from glacier failed"
+  where
+	go = glacierAction r
+		[ Param "archive"
+		, Param "delete"
+		, Param $ getVault $ config r
+		, Param $ archive r k
+		]
 
 checkKey :: Remote -> CheckPresent
 checkKey r k = do

Remote/Helper/Chunked.hs

@@ -199,19 +199,14 @@ seekResume h encryptor chunkkeys checker = do
 {- Removes all chunks of a key from a remote, by calling a remover
  - action on each.
  -
- - The remover action should succeed even if asked to
- - remove a key that is not present on the remote.
- -
  - This action may be called on a chunked key. It will simply remove it.
  -}
-removeChunks :: (Key -> Annex Bool) -> UUID -> ChunkConfig -> EncKey -> Key -> Annex Bool
+removeChunks :: Remover -> UUID -> ChunkConfig -> EncKey -> Key -> Annex ()
 removeChunks remover u chunkconfig encryptor k = do
 	ls <- chunkKeys u chunkconfig k
-	ok <- allM (remover . encryptor) (concat ls)
-	when ok $ do
-		let chunksizes = catMaybes $ map (fromKey keyChunkSize <=< headMaybe) ls
-		forM_ chunksizes $ chunksRemoved u k . FixedSizeChunks . fromIntegral
-	return ok
+	mapM_ (remover . encryptor) (concat ls)
+	let chunksizes = catMaybes $ map (fromKey keyChunkSize <=< headMaybe) ls
+	forM_ chunksizes $ chunksRemoved u k . FixedSizeChunks . fromIntegral
 
 {- Retrieves a key from a remote, using a retriever action.
  -

Remote/Helper/ExportImport.hs

@@ -214,9 +214,7 @@ adjustExportImport r rs = case getRemoteConfigValue exportTreeField (config r) o
 		-- files would not be dealt with correctly.
 		-- There does not seem to be a good use case for
 		-- removing a key from an export in any case.
-		, removeKey = \_k -> do
-			warning "dropping content from an export is not supported; use `git annex export` to export a tree that lacks the files you want to remove"
-			return False
+		, removeKey = \_k -> giveup "dropping content from an export is not supported; use `git annex export` to export a tree that lacks the files you want to remove"
 		-- Can't lock content on exports, since they're
 		-- not key/value stores, and someone else could
 		-- change what's exported to a file at any time.

Remote/Helper/P2P.hs

@@ -1,6 +1,6 @@
 {- Helpers for remotes using the git-annex P2P protocol.
  -
- - Copyright 2016-2018 Joey Hess <id@joeyh.name>
+ - Copyright 2016-2020 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
@@ -37,7 +37,7 @@ store runner k af p = do
 		runner p' (P2P.put k af p') >>= \case
 			Just True -> return ()
 			Just False -> giveup "transfer failed"
-			Nothing -> giveup "can't connect to remote"
+			Nothing -> remoteUnavail
 
 retrieve :: (MeterUpdate -> ProtoRunner (Bool, Verification)) -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Verification
 retrieve runner k af dest p =
@@ -45,15 +45,16 @@ retrieve runner k af dest p =
 		runner p' (P2P.get dest k af m p') >>= \case
 			Just (True, v) -> return v
 			Just (False, _) -> giveup "transfer failed"
-			Nothing -> giveup "can't connec to remote"
+			Nothing -> remoteUnavail
 
-remove :: ProtoRunner Bool -> Key -> Annex Bool
-remove runner k = fromMaybe False <$> runner (P2P.remove k)
+remove :: ProtoRunner Bool -> Key -> Annex ()
+remove runner k = runner (P2P.remove k) >>= \case
+	Just True -> return ()
+	Just False -> giveup "removing content from remote failed"
+	Nothing -> remoteUnavail
 
 checkpresent :: ProtoRunner Bool -> Key -> Annex Bool
-checkpresent runner k = maybe unavail return =<< runner (P2P.checkPresent k)
-  where
-	unavail = giveup "can't connect to remote"
+checkpresent runner k = maybe remoteUnavail return =<< runner (P2P.checkPresent k)
 
 lock :: WithConn a c -> ProtoConnRunner c -> UUID -> Key -> (VerifiedCopy -> Annex a) -> Annex a
 lock withconn connrunner u k callback = withconn $ \conn -> do
@@ -69,3 +70,6 @@ lock withconn connrunner u k callback = withconn $ \conn -> do
   where
 	go False = giveup "can't lock content"
 	go True = withVerifiedCopy LockedCopy u (return True) callback
+
+remoteUnavail :: a
+remoteUnavail = giveup "can't connect to remote"

Remote/Helper/ReadOnly.hs

@@ -47,8 +47,8 @@ adjustReadOnly r
 readonlyStoreKey :: Key -> AssociatedFile -> MeterUpdate -> Annex ()
 readonlyStoreKey _ _ _ = readonlyFail
 
-readonlyRemoveKey :: Key -> Annex Bool
-readonlyRemoveKey _ = readonlyFail'
+readonlyRemoveKey :: Key -> Annex ()
+readonlyRemoveKey _ = readonlyFail
 
 readonlyStorer :: Storer
 readonlyStorer _ _ _ = readonlyFail

Remote/Helper/Special.hs

@@ -124,8 +124,8 @@ storeKeyDummy :: Key -> AssociatedFile -> MeterUpdate -> Annex ()
 storeKeyDummy _ _ _ = error "missing storeKey implementation"
 retrieveKeyFileDummy :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Verification
 retrieveKeyFileDummy _ _ _ _ = error "missing retrieveKeyFile implementation"
-removeKeyDummy :: Key -> Annex Bool
-removeKeyDummy _ = return False
+removeKeyDummy :: Key -> Annex ()
+removeKeyDummy _ = error "missing removeKey implementation"
 checkPresentDummy :: Key -> Annex Bool
 checkPresentDummy _ = error "missing checkPresent implementation"
 
@@ -207,8 +207,6 @@ specialRemote' cfg c storer retriever remover checkpresent baser = encr
 	cip = cipherKey c (gitconfig baser)
 	isencrypted = isEncrypted c
 
-	safely a = catchNonAsync a (\e -> warning (show e) >> return False)
-
 	-- chunk, then encrypt, then feed to the storer
 	storeKeyGen k p enc = sendAnnex k rollback $ \src ->
 		displayprogress p k (Just src) $ \p' ->
@@ -236,7 +234,7 @@ specialRemote' cfg c storer retriever remover checkpresent baser = encr
 	  where
 		enck = maybe id snd enc
 
-	removeKeyGen k enc = safely $
+	removeKeyGen k enc = 
 		removeChunks remover (uuid baser) chunkconfig enck k
 	  where
 		enck = maybe id snd enc

Remote/Helper/Ssh.hs

@@ -106,8 +106,12 @@ inAnnex r k = do
 	dispatch _ = cantCheck r
 
 {- Removes a key from a remote. -}
-dropKey :: Git.Repo -> Key -> Annex Bool
-dropKey r key = onRemote NoConsumeStdin r (\f p -> liftIO (boolSystem f p), return False) "dropkey"
+dropKey :: Git.Repo -> Key -> Annex ()
+dropKey r key = unlessM (dropKey' r key) $
+	giveup "unable to remove key from remote"
+
+dropKey' :: Git.Repo -> Key -> Annex Bool
+dropKey' r key = onRemote NoConsumeStdin r (\f p -> liftIO (boolSystem f p), return False) "dropkey"
 	[ Param "--quiet", Param "--force"
 	, Param $ serializeKey key
 	]

Remote/Hook.hs

@@ -163,7 +163,9 @@ retrieve h = fileRetriever $ \d k _p ->
 		giveup "failed to retrieve content"
 
 remove :: HookName -> Remover
-remove h k = runHook' h "remove" k Nothing $ return True
+remove h k = 
+	unlessM (runHook' h "remove" k Nothing $ return True) $
+		giveup "failed to remove content"
 
 checkKey :: Git.Repo -> HookName -> CheckPresent
 checkKey r h k = do

Remote/Rsync.hs

@@ -260,8 +260,25 @@ remove o k = removeGeneric o includes
  - except for the specified includes. Due to the way rsync traverses
  - directories, the includes must match both the file to be deleted, and
  - its parent directories, but not their other contents. -}
-removeGeneric :: RsyncOpts -> [String] -> Annex Bool
+removeGeneric :: RsyncOpts -> [String] -> Annex ()
 removeGeneric o includes = do
+	ps <- sendParams
+	opts <- rsyncOptions o
+	ok <- 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
+			]
+	unless ok $
+		giveup "rsync failed"
+
+removeGeneric' :: RsyncOpts -> [String] -> Annex Bool
+removeGeneric' o includes = do
 	ps <- sendParams
 	opts <- rsyncOptions o
 	withRsyncScratchDir $ \tmp -> liftIO $ do
@@ -310,14 +327,14 @@ checkPresentExportM o _k loc = checkPresentGeneric o [rsyncurl]
 
 removeExportM :: RsyncOpts -> Key -> ExportLocation -> Annex Bool
 removeExportM o _k loc =
-	removeGeneric o $ includes $ fromRawFilePath $ fromExportLocation loc
+	removeGeneric' o $ includes $ fromRawFilePath $ fromExportLocation loc
   where
 	includes f = f : case upFrom f of
 		Nothing -> []
 		Just f' -> includes f'
 
 removeExportDirectoryM :: RsyncOpts -> ExportDirectory -> Annex Bool
-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/S3.hs

@@ -419,10 +419,10 @@ retrieveHelper' h f p req = liftIO $ runResourceT $ do
 	Url.sinkResponseFile p zeroBytesProcessed f WriteMode rsp
 
 remove :: S3HandleVar -> Remote -> S3Info -> Remover
-remove hv r info k = withS3HandleOrFail (uuid r) hv $ \h -> liftIO $ runResourceT $ do
-	res <- tryNonAsync $ sendS3Handle h $
+remove hv r info k = withS3HandleOrFail (uuid r) hv $ \h -> do
+	S3.DeleteObjectResponse <- liftIO $ runResourceT $ sendS3Handle h $
 		S3.DeleteObject (T.pack $ bucketObject info k) (bucket info)
-	return $ either (const False) (const True) res
+	return ()
 
 checkKey :: S3HandleVar -> Remote -> RemoteStateHandle -> ParsedRemoteConfig -> S3Info -> CheckPresent
 checkKey hv r rs c info k = withS3Handle hv $ \case

Remote/Tahoe.hs

@@ -150,10 +150,8 @@ retrieve rs hdl k _f d _p = do
 	go (Just cap) = unlessM (liftIO $ requestTahoe hdl "get" [Param cap, File d]) $
 		giveup "tahoe failed to reteieve content"
 
-remove :: Key -> Annex Bool
-remove _k = do
-	warning "content cannot be removed from tahoe remote"
-	return False
+remove :: Key -> Annex ()
+remove _k = giveup "content cannot be removed from tahoe remote"
 
 checkKey :: RemoteStateHandle -> TahoeHandle -> Key -> Annex Bool
 checkKey rs hdl k = go =<< getCapability rs k

Remote/Web.hs

@@ -100,10 +100,8 @@ downloadKey key _af dest p = do
 uploadKey :: Key -> AssociatedFile -> MeterUpdate -> Annex ()
 uploadKey _ _ _ = giveup "upload to web not supported"
 
-dropKey :: Key -> Annex Bool
-dropKey k = do
-	mapM_ (setUrlMissing k) =<< getWebUrls k
-	return True
+dropKey :: Key -> Annex ()
+dropKey k = mapM_ (setUrlMissing k) =<< getWebUrls k
 
 checkKey :: Key -> Annex Bool
 checkKey key = do

Remote/WebDAV.hs

@@ -177,11 +177,12 @@ retrieveHelper loc d p = do
 
 remove :: DavHandleVar -> Remover
 remove hv k = withDavHandle' hv $ \case
-	Left _e -> return False
 	Right dav -> liftIO $ goDAV dav $
 		-- Delete the key's whole directory, including any
 		-- legacy chunked files, etc, in a single action.
-		removeHelper (keyDir k)
+		unlessM (removeHelper (keyDir k)) $
+			giveup "failed to remove content from remote"
+	Left e -> giveup e
 
 removeHelper :: DavLocation -> DAVT IO Bool
 removeHelper d = do

Types/Remote.hs

@@ -97,12 +97,14 @@ data RemoteA a = Remote
 	, retrieveKeyFileCheap :: Maybe (Key -> AssociatedFile -> FilePath -> a ())
 	-- Security policy for reteiving keys from this remote.
 	, retrievalSecurityPolicy :: RetrievalSecurityPolicy
-	-- Removes a key's contents (succeeds if the contents are not present)
-	, removeKey :: Key -> a Bool
+	-- Removes a key's contents (succeeds even the contents are not present)
+	-- Can throw exception if unable to access remote, or if remote
+	-- refuses to remove the content.
+	, removeKey :: Key -> a ()
 	-- Uses locking to prevent removal of a key's contents,
 	-- thus producing a VerifiedCopy, which is passed to the callback.
 	-- If unable to lock, does not run the callback, and throws an
-	-- error.
+	-- exception.
 	-- This is optional; remotes do not have to support locking.
 	, lockContent :: forall r. Maybe (Key -> (VerifiedCopy -> a r) -> a r)
 	-- Checks if a key is present in the remote.

Types/StoreRetrieve.hs

@@ -31,8 +31,9 @@ type Storer = Key -> ContentSource -> MeterUpdate -> Annex ()
 type Retriever = Key -> MeterUpdate -> (ContentSource -> Annex ()) -> Annex ()
 
 -- Action that removes a Key's content from a remote.
--- Succeeds if key is already not present; never throws exceptions.
-type Remover = Key -> Annex Bool
+-- Succeeds if key is already not present.
+-- Throws an exception if the remote is not accessible.
+type Remover = Key -> Annex ()
 
 -- Checks if a Key's content is present on a remote.
 -- Throws an exception if the remote is not accessible.