change removeExport to throw exception

Part of ongoing transition to make remote methods
throw exceptions, rather than silently hide them.

This commit was sponsored by Graham Spencer on Patreon.

Command/Export.hs

@@ -337,10 +337,12 @@ startUnexport' r db f ek = starting ("unexport " ++ name r) (ActionItemOther (Ju
 -- not really remove the content, which must be accessible later on.
 performUnexport :: Remote -> ExportHandle -> [ExportKey] -> ExportLocation -> CommandPerform
 performUnexport r db eks loc = do
-	ifM (allM (\ek -> removeExport (exportActions r) (asKey ek) loc) eks)
+	ifM (allM rm eks)
 		( next $ cleanupUnexport r db eks loc
 		, stop
 		)
+  where
+	rm ek = Remote.action $ removeExport (exportActions r) (asKey ek) loc
 
 cleanupUnexport :: Remote -> ExportHandle -> [ExportKey] -> ExportLocation -> CommandCleanup
 cleanupUnexport r db eks loc = do

Command/TestRemote.hs

@@ -285,7 +285,7 @@ testExportTree runannex mkr mkk1 mkk2 =
 	[ check "check present export when not present" $ \ea k1 _k2 ->
 		not <$> checkpresentexport ea k1
 	, check "remove export when not present" $ \ea k1 _k2 -> 
-		removeexport ea k1
+		isRight <$> tryNonAsync (removeexport ea k1)
 	, check "store export" $ \ea k1 _k2 ->
 		isRight <$> tryNonAsync (storeexport ea k1)
 	, check "check present export after store" $ \ea k1 _k2 ->
@@ -301,7 +301,7 @@ testExportTree runannex mkr mkk1 mkk2 =
 	, check "retrieve export new content" $ \ea _k1 k2 ->
 		retrieveexport ea k2
 	, check "remove export" $ \ea _k1 k2 -> 
-		removeexport ea k2
+		isRight <$> tryNonAsync (removeexport ea k2)
 	, check "check present export after remove" $ \ea _k1 k2 ->
 		not <$> checkpresentexport ea k2
 	, check "retrieve export fails after removal" $ \ea _k1 k2 ->

Remote/Adb.hs

@@ -249,8 +249,10 @@ retrieveExportM serial adir _k loc dest _p = retrieve' serial src dest
   where
 	src = androidExportLocation adir loc
 
-removeExportM :: AndroidSerial -> AndroidPath -> Key -> ExportLocation -> Annex Bool
-removeExportM serial adir _k loc = remove' serial aloc
+removeExportM :: AndroidSerial -> AndroidPath -> Key -> ExportLocation -> Annex ()
+removeExportM serial adir _k loc =
+	unlessM (remove' serial aloc) $
+		giveup "adb failed"
   where
 	aloc = androidExportLocation adir loc
 
@@ -341,13 +343,15 @@ storeExportWithContentIdentifierM serial adir src _k loc overwritablecids _p =
 			Right Nothing -> True
 			_ -> False
 
-removeExportWithContentIdentifierM :: AndroidSerial -> AndroidPath -> Key -> ExportLocation -> [ContentIdentifier] -> Annex Bool
-removeExportWithContentIdentifierM serial adir k loc removeablecids = catchBoolIO $
+removeExportWithContentIdentifierM :: AndroidSerial -> AndroidPath -> Key -> ExportLocation -> [ContentIdentifier] -> Annex ()
+removeExportWithContentIdentifierM serial adir k loc removeablecids =
 	getExportContentIdentifier serial adir loc >>= \case
-		Right Nothing -> return True
-		Right (Just cid) | cid `elem` removeablecids ->
-			removeExportM serial adir k loc
-		_ -> return False
+		Right Nothing -> return ()
+		Right (Just cid)
+			| cid `elem` removeablecids ->
+				removeExportM serial adir k loc
+			| otherwise -> giveup "file on Android device is modified, cannot remove"
+		Left _ -> giveup "unable to access Android device"
 
 checkPresentExportWithContentIdentifierM :: AndroidSerial -> AndroidPath -> Key -> ExportLocation -> [ContentIdentifier] -> Annex Bool
 checkPresentExportWithContentIdentifierM serial adir _k loc knowncids = 

Remote/Directory.hs

@@ -279,11 +279,10 @@ retrieveExportM d _k loc dest p =
   where
 	src = exportPath d loc
 
-removeExportM :: FilePath -> Key -> ExportLocation -> Annex Bool
+removeExportM :: FilePath -> Key -> ExportLocation -> Annex ()
 removeExportM d _k loc = liftIO $ do
 	nukeFile src
 	removeExportLocation d loc
-	return True
   where
 	src = exportPath d loc
 
@@ -425,10 +424,10 @@ storeExportWithContentIdentifierM dir src _k loc overwritablecids p = do
 	(destdir, base) = splitFileName dest
 	template = relatedTemplate (base ++ ".tmp")
 
-removeExportWithContentIdentifierM :: FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> Annex Bool
+removeExportWithContentIdentifierM :: FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> Annex ()
 removeExportWithContentIdentifierM dir k loc removeablecids =
-	checkExportContent dir loc removeablecids (return False) $ \case
-		DoesNotExist -> return True
+	checkExportContent dir loc removeablecids (giveup "unsafe to remove modified file") $ \case
+		DoesNotExist -> return ()
 		KnownContentIdentifier -> removeExportM dir k loc
 
 checkPresentExportWithContentIdentifierM :: FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> Annex Bool

Remote/External.hs

@@ -319,18 +319,16 @@ checkPresentExportM external k loc = either giveup id <$> go
 			Left "CHECKPRESENTEXPORT not implemented by external special remote"
 		_ -> Nothing
 
-removeExportM :: External -> Key -> ExportLocation -> Annex Bool
-removeExportM external k loc = safely $
-	handleRequestExport external loc REMOVEEXPORT k Nothing $ \resp -> case resp of
+removeExportM :: External -> Key -> ExportLocation -> Annex ()
+removeExportM external k loc = either giveup return =<< go
+  where
+	go = handleRequestExport external loc REMOVEEXPORT 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)
-		UNSUPPORTED_REQUEST -> Just $ do
-			warning "REMOVEEXPORT not implemented by external special remote"
-			return (Result False)
+			| k == k' -> result $ Left $ respErrorMessage "REMOVE" errmsg
+		UNSUPPORTED_REQUEST -> result $
+			Left $ "REMOVEEXPORT not implemented by external special remote"
 		_ -> Nothing
 
 removeExportDirectoryM :: External -> ExportDirectory -> Annex Bool

Remote/Helper/ExportImport.hs

@@ -39,7 +39,7 @@ instance HasExportUnsupported (ExportActions Annex) where
 		{ storeExport = nope
 		, retrieveExport = nope
 		, checkPresentExport = \_ _ -> return False
-		, removeExport = \_ _ -> return False
+		, removeExport = nope
 		, removeExportDirectory = Just $ \_ -> return False
 		, renameExport = \_ _ _ -> return Nothing
 		}
@@ -58,7 +58,7 @@ instance HasImportUnsupported (ImportActions Annex) where
 		{ listImportableContents = return Nothing
 		, retrieveExportWithContentIdentifier = nope
 		, storeExportWithContentIdentifier = nope
-		, removeExportWithContentIdentifier = \_ _ _ -> return False
+		, removeExportWithContentIdentifier = nope
 		, removeExportDirectoryWhenEmpty = Just $ \_ -> return False
 		, checkPresentExportWithContentIdentifier = \_ _ _ -> return False
 		}

Remote/Helper/ReadOnly.hs

@@ -56,8 +56,8 @@ readonlyStorer _ _ _ = readonlyFail
 readonlyStoreExport :: FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex ()
 readonlyStoreExport _ _ _ _ = readonlyFail
 
-readonlyRemoveExport :: Key -> ExportLocation -> Annex Bool
-readonlyRemoveExport _ _ = readonlyFail'
+readonlyRemoveExport :: Key -> ExportLocation -> Annex ()
+readonlyRemoveExport _ _ = readonlyFail
 
 readonlyRemoveExportDirectory :: ExportDirectory -> Annex Bool
 readonlyRemoveExportDirectory _ = readonlyFail'
@@ -68,8 +68,8 @@ readonlyRenameExport _ _ _ = return Nothing
 readonlyStoreExportWithContentIdentifier :: FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex ContentIdentifier
 readonlyStoreExportWithContentIdentifier _ _ _ _ _ = readonlyFail
 
-readonlyRemoveExportWithContentIdentifier :: Key -> ExportLocation -> [ContentIdentifier] -> Annex Bool
-readonlyRemoveExportWithContentIdentifier _ _ _ = readonlyFail'
+readonlyRemoveExportWithContentIdentifier :: Key -> ExportLocation -> [ContentIdentifier] -> Annex ()
+readonlyRemoveExportWithContentIdentifier _ _ _ = readonlyFail
 
 readonlyFail :: Annex a
 readonlyFail = giveup readonlyWarning

Remote/Rsync.hs

@@ -325,9 +325,9 @@ checkPresentExportM o _k loc = checkPresentGeneric o [rsyncurl]
   where
 	rsyncurl = mkRsyncUrl o (fromRawFilePath (fromExportLocation loc))
 
-removeExportM :: RsyncOpts -> Key -> ExportLocation -> Annex Bool
+removeExportM :: RsyncOpts -> Key -> ExportLocation -> Annex ()
 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 -> []

Remote/S3.hs

@@ -486,18 +486,16 @@ retrieveExportS3 hv r info _k loc f p = do
   where
 	exportloc = bucketExportLocation info loc
 
-removeExportS3 :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> Key -> ExportLocation -> Annex Bool
+removeExportS3 :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> Key -> ExportLocation -> Annex ()
 removeExportS3 hv r rs info k loc = withS3Handle hv $ \case
-	Just h -> checkVersioning info rs k $
-		catchNonAsync (go h) (\e -> warning (show e) >> return False)
-	Nothing -> do
-		warning $ needS3Creds (uuid r)
-		return False	
+	Just h -> do
+		checkVersioning info rs k
+		liftIO $ runResourceT $ do
+			S3.DeleteObjectResponse <- sendS3Handle h $
+				S3.DeleteObject (T.pack $ bucketExportLocation info loc) (bucket info)
+			return ()
+	Nothing -> giveup $ needS3Creds (uuid r)
   where
-	go h = liftIO $ runResourceT $ do
-		res <- tryNonAsync $ sendS3Handle h $
-			S3.DeleteObject (T.pack $ bucketExportLocation info loc) (bucket info)
-		return $ either (const False) (const True) res
 
 checkPresentExportS3 :: S3HandleVar -> Remote -> S3Info -> Key -> ExportLocation -> Annex Bool
 checkPresentExportS3 hv r info k loc = withS3Handle hv $ \case
@@ -514,7 +512,7 @@ renameExportS3 :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> Key ->
 renameExportS3 hv r rs info k src dest = Just <$> go
   where
 	go = withS3Handle hv $ \case
-		Just h -> checkVersioning info rs k $ 
+		Just h -> checkVersioning' info rs k $ 
 			catchNonAsync (go' h) (\_ -> return False)
 		Nothing -> do 
 			warning $ needS3Creds (uuid r)
@@ -687,7 +685,7 @@ storeExportWithContentIdentifierS3 hv r rs info magic src k loc _overwritablecid
 -- 
 -- When the bucket is not versioned, data loss can result.
 -- This is why that configuration requires --force to enable.
-removeExportWithContentIdentifierS3 :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> Key -> ExportLocation -> [ContentIdentifier] -> Annex Bool
+removeExportWithContentIdentifierS3 :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> Key -> ExportLocation -> [ContentIdentifier] -> Annex ()
 removeExportWithContentIdentifierS3 hv r rs info k loc _removeablecids =
 	removeExportS3 hv r rs info k loc
 
@@ -1287,8 +1285,15 @@ enableBucketVersioning ss info _ _ _ = do
 -- were created without versioning, some unversioned files exported to
 -- them, and then versioning enabled, and this is to avoid data loss in
 -- those cases.
-checkVersioning :: S3Info -> RemoteStateHandle -> Key -> Annex Bool -> Annex Bool
-checkVersioning info rs k a
+checkVersioning :: S3Info -> RemoteStateHandle -> Key -> Annex ()
+checkVersioning info rs k
+	| versioning info = getS3VersionID rs k >>= \case
+		[] -> 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."

Remote/WebDAV.hs

@@ -180,21 +180,20 @@ 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.
-		unlessM (removeHelper (keyDir k)) $
-			giveup "failed to remove content from remote"
+		removeHelper (keyDir k)
 	Left e -> giveup e
 
-removeHelper :: DavLocation -> DAVT IO Bool
+removeHelper :: DavLocation -> DAVT IO ()
 removeHelper d = do
 	debugDav $ "delContent " ++ d
 	v <- safely $ inLocation d delContentM
 	case v of
-		Just _ -> return True
+		Just _ -> return ()
 		Nothing -> do
 			v' <- existsDAV d
 			case v' of
-				Right False -> return True
-				_ -> return False
+				Right False -> return ()
+				_ -> giveup "failed to remove content from remote"
 
 checkKey :: DavHandleVar -> Remote -> ChunkConfig -> CheckPresent
 checkKey hv r chunkconfig k = withDavHandle hv $ \dav -> do
@@ -228,16 +227,16 @@ checkPresentExportDav hdl _ _k loc = case exportLocation loc of
 			either giveup return v
 	Left err -> giveup err
 
-removeExportDav :: DavHandleVar-> Key -> ExportLocation -> Annex Bool
+removeExportDav :: DavHandleVar-> Key -> ExportLocation -> Annex ()
 removeExportDav hdl _k loc = case exportLocation loc of
-	Right p -> withDavHandle' hdl $ \mh -> runExport' mh $ \_dav ->
+	Right p -> withDavHandle hdl $ \h -> runExport h $ \_dav ->
 		removeHelper p
 	-- When the exportLocation is not legal for webdav,
 	-- the content is certianly not stored there, so it's ok for
 	-- removal to succeed. This allows recovery after failure to store
 	-- content there, as the user can rename the problem file and
 	-- this will be called to make sure it's gone.
-	Left _err -> return True
+	Left _err -> return ()
 
 removeExportDirectoryDav :: DavHandleVar -> ExportDirectory -> Annex Bool
 removeExportDirectoryDav hdl dir = withDavHandle' hdl $ \mh -> runExport' mh $ \_dav -> do

Types/Remote.hs

@@ -239,7 +239,9 @@ data ExportActions a = ExportActions
 	-- Throws exception on failure.
 	, retrieveExport :: Key -> ExportLocation -> FilePath -> MeterUpdate -> a ()
 	-- Removes an exported file (succeeds if the contents are not present)
-	, removeExport :: Key -> ExportLocation -> a Bool
+	-- Can throw exception if unable to access remote, or if remote
+	-- refuses to remove the content.
+	, removeExport :: Key -> ExportLocation -> a ()
 	-- Removes an exported directory. Typically the directory will be
 	-- empty, but it could possibly contain files or other directories,
 	-- and it's ok to delete those (but not required to). 
@@ -315,11 +317,13 @@ data ImportActions a = ImportActions
 	-- can recover an overwritten file.
 	--
 	-- It needs to handle races similar to storeExportWithContentIdentifier.
+	--
+	-- Throws an exception when unable to remove.
 	, removeExportWithContentIdentifier
 		:: Key
 		-> ExportLocation
 		-> [ContentIdentifier]
-		-> a Bool
+		-> a ()
 	-- Removes a directory from the export, but only when it's empty.
 	-- Used instead of removeExportDirectory when a special remote
 	-- supports imports.