implement removeExportDirectory

Not yet called by Command.Export.

WebDAV needs this to clean up empty collections. Also, example.sh turned
out to not be cleaning up directories when removing content
from them, so it made sense for it to use this.

Remote.Directory did not need it, and since its cleanup method for empty
directories is more efficient than what Command.Export will need to do
to find empty directories, it uses Nothing so that extra work can be
avoided.

This commit was sponsored by Thom May on Patreon.

6 files changed, 119 insertions, 85 deletions

diff --git a/Remote/Directory.hs b/Remote/Directory.hs
index c3ebeb899..24f35868b 100644
--- a/Remote/Directory.hs
+++ b/Remote/Directory.hs
@@ -47,26 +47,29 @@ gen r u c gc = do
 	let chunkconfig = getChunkConfig c
 	return $ Just $ specialRemote c
 		(prepareStore dir chunkconfig)
-		(retrieve dir chunkconfig)
-		(simplyPrepare $ remove dir)
-		(simplyPrepare $ checkKey dir chunkconfig)
+		(retrieveKeyFileM dir chunkconfig)
+		(simplyPrepare $ removeKeyM dir)
+		(simplyPrepare $ checkPresentM dir chunkconfig)
 		Remote
 			{ uuid = u
 			, cost = cst
 			, name = Git.repoDescribe r
 			, storeKey = storeKeyDummy
 			, retrieveKeyFile = retreiveKeyFileDummy
-			, retrieveKeyFileCheap = retrieveCheap dir chunkconfig
+			, retrieveKeyFileCheap = retrieveKeyFileCheapM dir chunkconfig
 			, removeKey = removeKeyDummy
 			, lockContent = Nothing
 			, checkPresent = checkPresentDummy
 			, checkPresentCheap = True
 			, exportActions = return $ ExportActions
-				{ storeExport = storeExportDirectory dir
-				, retrieveExport = retrieveExportDirectory dir
-				, removeExport = removeExportDirectory dir
-				, checkPresentExport = checkPresentExportDirectory dir
-				, renameExport = renameExportDirectory dir
+				{ storeExport = storeExportM dir
+				, retrieveExport = retrieveExportM dir
+				, removeExport = removeExportM dir
+				, checkPresentExport = checkPresentExportM dir
+				-- Not needed because removeExportLocation
+				-- auto-removes empty directories.
+				, removeExportDirectory = Nothing
+				, renameExport = renameExportM dir
 				}
 			, whereisKey = Nothing
 			, remoteFsck = Nothing
@@ -166,17 +169,17 @@ finalizeStoreGeneric tmp dest = do
 		mapM_ preventWrite =<< dirContents dest
 		preventWrite dest
 
-retrieve :: FilePath -> ChunkConfig -> Preparer Retriever
-retrieve d (LegacyChunks _) = Legacy.retrieve locations d
-retrieve d _ = simplyPrepare $ byteRetriever $ \k sink ->
+retrieveKeyFileM :: FilePath -> ChunkConfig -> Preparer Retriever
+retrieveKeyFileM d (LegacyChunks _) = Legacy.retrieve locations d
+retrieveKeyFileM d _ = simplyPrepare $ byteRetriever $ \k sink ->
 	sink =<< liftIO (L.readFile =<< getLocation d k)
 
-retrieveCheap :: FilePath -> ChunkConfig -> Key -> AssociatedFile -> FilePath -> Annex Bool
+retrieveKeyFileCheapM :: FilePath -> ChunkConfig -> Key -> AssociatedFile -> FilePath -> Annex Bool
 -- no cheap retrieval possible for chunks
-retrieveCheap _ (UnpaddedChunks _) _ _ _ = return False
-retrieveCheap _ (LegacyChunks _) _ _ _ = return False
+retrieveKeyFileCheapM _ (UnpaddedChunks _) _ _ _ = return False
+retrieveKeyFileCheapM _ (LegacyChunks _) _ _ _ = return False
 #ifndef mingw32_HOST_OS
-retrieveCheap d NoChunks k _af f = liftIO $ catchBoolIO $ do
+retrieveKeyFileCheapM d NoChunks k _af f = liftIO $ catchBoolIO $ do
 	file <- absPath =<< getLocation d k
 	ifM (doesFileExist file)
 		( do
@@ -185,11 +188,11 @@ retrieveCheap d NoChunks k _af f = liftIO $ catchBoolIO $ do
 		, return False
 		)
 #else
-retrieveCheap _ _ _ _ _ = return False
+retrieveKeyFileCheapM _ _ _ _ _ = return False
 #endif
 
-remove :: FilePath -> Remover
-remove d k = liftIO $ removeDirGeneric d (storeDir d k)
+removeKeyM :: FilePath -> Remover
+removeKeyM d k = liftIO $ removeDirGeneric d (storeDir d k)
 
 {- Removes the directory, which must be located under the topdir.
  -
@@ -216,9 +219,9 @@ removeDirGeneric topdir dir = do
 		then return ok
 		else doesDirectoryExist topdir <&&> (not <$> doesDirectoryExist dir)
 
-checkKey :: FilePath -> ChunkConfig -> CheckPresent
-checkKey d (LegacyChunks _) k = Legacy.checkKey d locations k
-checkKey d _ k = checkPresentGeneric d (locations d k)
+checkPresentM :: FilePath -> ChunkConfig -> CheckPresent
+checkPresentM d (LegacyChunks _) k = Legacy.checkKey d locations k
+checkPresentM d _ k = checkPresentGeneric d (locations d k)
 
 checkPresentGeneric :: FilePath -> [FilePath] -> Annex Bool
 checkPresentGeneric d ps = liftIO $
@@ -230,8 +233,8 @@ checkPresentGeneric d ps = liftIO $
 			)
 		)
 
-storeExportDirectory :: FilePath -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool
-storeExportDirectory d src _k loc p = liftIO $ catchBoolIO $ do
+storeExportM :: FilePath -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool
+storeExportM d src _k loc p = liftIO $ catchBoolIO $ do
 	createDirectoryIfMissing True (takeDirectory dest)
 	-- Write via temp file so that checkPresentGeneric will not
 	-- see it until it's fully stored.
@@ -240,27 +243,27 @@ storeExportDirectory d src _k loc p = liftIO $ catchBoolIO $ do
   where
 	dest = exportPath d loc
 
-retrieveExportDirectory :: FilePath -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool
-retrieveExportDirectory d _k loc dest p = liftIO $ catchBoolIO $ do
+retrieveExportM :: FilePath -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool
+retrieveExportM d _k loc dest p = liftIO $ catchBoolIO $ do
 	withMeteredFile src p (L.writeFile dest)
 	return True
   where
 	src = exportPath d loc
 
-removeExportDirectory :: FilePath -> Key -> ExportLocation -> Annex Bool
-removeExportDirectory d _k loc = liftIO $ do
+removeExportM :: FilePath -> Key -> ExportLocation -> Annex Bool
+removeExportM d _k loc = liftIO $ do
 	nukeFile src
 	removeExportLocation d loc
 	return True
   where
 	src = exportPath d loc
 
-checkPresentExportDirectory :: FilePath -> Key -> ExportLocation -> Annex Bool
-checkPresentExportDirectory d _k loc =
+checkPresentExportM :: FilePath -> Key -> ExportLocation -> Annex Bool
+checkPresentExportM d _k loc =
 	checkPresentGeneric d [exportPath d loc]
 
-renameExportDirectory :: FilePath -> Key -> ExportLocation -> ExportLocation -> Annex Bool
-renameExportDirectory d _k oldloc newloc = liftIO $ catchBoolIO $ do
+renameExportM :: FilePath -> Key -> ExportLocation -> ExportLocation -> Annex Bool
+renameExportM d _k oldloc newloc = liftIO $ catchBoolIO $ do
 	createDirectoryIfMissing True (takeDirectory dest)
 	renameFile src dest
 	removeExportLocation d oldloc
diff --git a/Remote/External.hs b/Remote/External.hs
index fd4fd0649..b1204f776 100644
--- a/Remote/External.hs
+++ b/Remote/External.hs
@@ -71,11 +71,12 @@ gen r u c gc
 		exportsupported <- checkExportSupported' external
 		let exportactions = if exportsupported
 			then return $ ExportActions
-				{ storeExport = storeExportExternal external
-				, retrieveExport = retrieveExportExternal external
-				, removeExport = removeExportExternal external
-				, checkPresentExport = checkPresentExportExternal external
-				, renameExport = renameExportExternal external
+				{ storeExport = storeExportM external
+				, retrieveExport = retrieveExportM external
+				, removeExport = removeExportM external
+				, checkPresentExport = checkPresentExportM external
+				, removeExportDirectory = Just $ removeExportDirectoryM external
+				, renameExport = renameExportM external
 				}
 			else exportUnsupported
 		-- Cheap exportSupported that replaces the expensive
@@ -84,13 +85,13 @@ gen r u c gc
 			then exportIsSupported
 			else exportUnsupported
 		mk cst avail
-			(store external)
-			(retrieve external)
-			(remove external)
-			(checkKey external)
-			(Just (whereis external))
-			(Just (claimurl external))
-			(Just (checkurl external))
+			(storeKeyM external)
+			(retrieveKeyFileM external)
+			(removeKeyM external)
+			(checkPresentM external)
+			(Just (whereisKeyM external))
+			(Just (claimUrlM external))
+			(Just (checkUrlM external))
 			exportactions
 			cheapexportsupported
   where
@@ -170,8 +171,8 @@ checkExportSupported' external = safely $
 		UNSUPPORTED_REQUEST -> Just $ return False
 		_ -> Nothing
 
-store :: External -> Storer
-store external = fileStorer $ \k f p ->
+storeKeyM :: External -> Storer
+storeKeyM external = fileStorer $ \k f p ->
 	handleRequestKey external (\sk -> TRANSFER Upload sk f) k (Just p) $ \resp ->
 		case resp of
 			TRANSFER_SUCCESS Upload k' | k == k' ->
@@ -182,8 +183,8 @@ store external = fileStorer $ \k f p ->
 					return False
 			_ -> Nothing
 
-retrieve :: External -> Retriever
-retrieve external = fileRetriever $ \d k p -> 
+retrieveKeyFileM :: External -> Retriever
+retrieveKeyFileM external = fileRetriever $ \d k p -> 
 	handleRequestKey external (\sk -> TRANSFER Download sk d) k (Just p) $ \resp ->
 		case resp of
 			TRANSFER_SUCCESS Download k'
@@ -192,8 +193,8 @@ retrieve external = fileRetriever $ \d k p ->
 				| k == k' -> Just $ giveup errmsg
 			_ -> Nothing
 
-remove :: External -> Remover
-remove external k = safely $ 
+removeKeyM :: External -> Remover
+removeKeyM external k = safely $ 
 	handleRequestKey external REMOVE k Nothing $ \resp ->
 		case resp of
 			REMOVE_SUCCESS k'
@@ -204,8 +205,8 @@ remove external k = safely $
 					return False
 			_ -> Nothing
 
-checkKey :: External -> CheckPresent
-checkKey external k = either giveup id <$> go
+checkPresentM :: External -> CheckPresent
+checkPresentM external k = either giveup id <$> go
   where
 	go = handleRequestKey external CHECKPRESENT k Nothing $ \resp ->
 		case resp of
@@ -217,15 +218,15 @@ checkKey external k = either giveup id <$> go
 				| k' == k -> Just $ return $ Left errmsg
 			_ -> Nothing
 
-whereis :: External -> Key -> Annex [String]
-whereis external k = handleRequestKey external WHEREIS k Nothing $ \resp -> case resp of
+whereisKeyM :: External -> Key -> Annex [String]
+whereisKeyM external k = handleRequestKey external WHEREIS k Nothing $ \resp -> case resp of
 	WHEREIS_SUCCESS s -> Just $ return [s]
 	WHEREIS_FAILURE -> Just $ return []
 	UNSUPPORTED_REQUEST -> Just $ return []
 	_ -> Nothing
 
-storeExportExternal :: External -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool
-storeExportExternal external f k loc p = safely $
+storeExportM :: External -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool
+storeExportM external f k loc p = safely $
 	handleRequestExport external loc req k (Just p) $ \resp -> case resp of
 		TRANSFER_SUCCESS Upload k' | k == k' ->
 			Just $ return True
@@ -240,8 +241,8 @@ storeExportExternal external f k loc p = safely $
   where
 	req sk = TRANSFEREXPORT Upload sk f
 
-retrieveExportExternal :: External -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool
-retrieveExportExternal external k loc d p = safely $
+retrieveExportM :: External -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool
+retrieveExportM external k loc d p = safely $
 	handleRequestExport external loc req k (Just p) $ \resp -> case resp of
 		TRANSFER_SUCCESS Download k'
 			| k == k' -> Just $ return True
@@ -256,8 +257,22 @@ retrieveExportExternal external k loc d p = safely $
   where
 	req sk = TRANSFEREXPORT Download sk d
 
-removeExportExternal :: External -> Key -> ExportLocation -> Annex Bool
-removeExportExternal external k loc = safely $
+checkPresentExportM :: External -> Key -> ExportLocation -> Annex Bool
+checkPresentExportM external k loc = either giveup id <$> go
+  where
+	go = handleRequestExport external loc CHECKPRESENTEXPORT k Nothing $ \resp -> case resp of
+		CHECKPRESENT_SUCCESS k'
+			| k' == k -> Just $ return $ Right True
+		CHECKPRESENT_FAILURE k'
+			| k' == k -> Just $ return $ Right False
+		CHECKPRESENT_UNKNOWN k' errmsg
+			| k' == k -> Just $ return $ Left errmsg
+		UNSUPPORTED_REQUEST -> Just $ return $
+			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
 		REMOVE_SUCCESS k'
 			| k == k' -> Just $ return True
@@ -270,22 +285,17 @@ removeExportExternal external k loc = safely $
 			return False
 		_ -> Nothing
 
-checkPresentExportExternal :: External -> Key -> ExportLocation -> Annex Bool
-checkPresentExportExternal external k loc = either giveup id <$> go
+removeExportDirectoryM :: External -> ExportDirectory -> Annex Bool
+removeExportDirectoryM external dir = safely $
+	handleRequest external req Nothing $ \resp -> case resp of
+		REMOVEEXPORTDIRECTORY_SUCCESS -> Just $ return True
+		REMOVEEXPORTDIRECTORY_FAILURE -> Just $ return False
+		UNSUPPORTED_REQUEST -> Just $ return True
   where
-	go = handleRequestExport external loc CHECKPRESENTEXPORT k Nothing $ \resp -> case resp of
-		CHECKPRESENT_SUCCESS k'
-			| k' == k -> Just $ return $ Right True
-		CHECKPRESENT_FAILURE k'
-			| k' == k -> Just $ return $ Right False
-		CHECKPRESENT_UNKNOWN k' errmsg
-			| k' == k -> Just $ return $ Left errmsg
-		UNSUPPORTED_REQUEST -> Just $ return $
-			Left "CHECKPRESENTEXPORT not implemented by external special remote"
-		_ -> Nothing
+	req = REMOVEEXPORTDIRECTORY dir
 
-renameExportExternal :: External -> Key -> ExportLocation -> ExportLocation -> Annex Bool
-renameExportExternal external k src dest = safely $
+renameExportM :: External -> Key -> ExportLocation -> ExportLocation -> Annex Bool
+renameExportM external k src dest = safely $
 	handleRequestExport external src req k Nothing $ \resp -> case resp of
 		RENAMEEXPORT_SUCCESS k'
 			| k' == k -> Just $ return True
@@ -619,16 +629,16 @@ getAvailability external r gc =
 		return avail
 	defavail = return GloballyAvailable
 
-claimurl :: External -> URLString -> Annex Bool
-claimurl external url =
+claimUrlM :: External -> URLString -> Annex Bool
+claimUrlM external url =
 	handleRequest external (CLAIMURL url) Nothing $ \req -> case req of
 		CLAIMURL_SUCCESS -> Just $ return True
 		CLAIMURL_FAILURE -> Just $ return False
 		UNSUPPORTED_REQUEST -> Just $ return False
 		_ -> Nothing
 
-checkurl :: External -> URLString -> Annex UrlContents
-checkurl external url = 
+checkUrlM :: External -> URLString -> Annex UrlContents
+checkUrlM external url = 
 	handleRequest external (CHECKURL url) Nothing $ \req -> case req of
 		CHECKURL_CONTENTS sz f -> Just $ return $ UrlContents sz
 			(if null f then Nothing else Just $ mkSafeFilePath f)
diff --git a/Remote/External/Types.hs b/Remote/External/Types.hs
index 343004a85..01e44b3a7 100644
--- a/Remote/External/Types.hs
+++ b/Remote/External/Types.hs
@@ -36,7 +36,7 @@ import Types.StandardGroups (PreferredContentExpression)
 import Utility.Metered (BytesProcessed(..))
 import Types.Transfer (Direction(..))
 import Config.Cost (Cost)
-import Types.Remote (RemoteConfig, ExportLocation(..))
+import Types.Remote (RemoteConfig, ExportLocation(..), ExportDirectory(..))
 import Types.Availability (Availability(..))
 import Types.Key
 import Utility.Url (URLString)
@@ -121,6 +121,7 @@ data Request
 	| TRANSFEREXPORT Direction SafeKey FilePath
 	| CHECKPRESENTEXPORT SafeKey
 	| REMOVEEXPORT SafeKey
+	| REMOVEEXPORTDIRECTORY ExportDirectory
 	| RENAMEEXPORT SafeKey ExportLocation
 	deriving (Show)
 
@@ -160,6 +161,8 @@ instance Proto.Sendable Request where
 		[ "CHECKPRESENTEXPORT", Proto.serialize key ]
 	formatMessage (REMOVEEXPORT key) =
 		[ "REMOVEEXPORT", Proto.serialize key ]
+	formatMessage (REMOVEEXPORTDIRECTORY dir) =
+		[ "REMOVEEXPORTDIRECTORY", Proto.serialize dir ]
 	formatMessage (RENAMEEXPORT key newloc) =
 		[ "RENAMEEXPORT"
 		, Proto.serialize key
@@ -190,6 +193,8 @@ data Response
 	| WHEREIS_FAILURE
 	| EXPORTSUPPORTED_SUCCESS
 	| EXPORTSUPPORTED_FAILURE
+	| REMOVEEXPORTDIRECTORY_SUCCESS
+	| REMOVEEXPORTDIRECTORY_FAILURE
 	| RENAMEEXPORT_SUCCESS Key
 	| RENAMEEXPORT_FAILURE Key
 	| UNSUPPORTED_REQUEST
@@ -218,6 +223,8 @@ instance Proto.Receivable Response where
 	parseCommand "WHEREIS-FAILURE" = Proto.parse0 WHEREIS_FAILURE
 	parseCommand "EXPORTSUPPORTED-SUCCESS" = Proto.parse0 EXPORTSUPPORTED_SUCCESS
 	parseCommand "EXPORTSUPPORTED-FAILURE" = Proto.parse0 EXPORTSUPPORTED_FAILURE
+	parseCommand "REMOVEEXPORTDIRECTORY-SUCCESS" = Proto.parse0 REMOVEEXPORTDIRECTORY_SUCCESS
+	parseCommand "REMOVEEXPORTDIRECTORY-FAILURE" = Proto.parse0 REMOVEEXPORTDIRECTORY_FAILURE
 	parseCommand "RENAMEEXPORT-SUCCESS" = Proto.parse1 RENAMEEXPORT_SUCCESS
 	parseCommand "RENAMEEXPORT-FAILURE" = Proto.parse1 RENAMEEXPORT_FAILURE
 	parseCommand "UNSUPPORTED-REQUEST" = Proto.parse0 UNSUPPORTED_REQUEST
@@ -352,3 +359,7 @@ instance Proto.Serializable URI where
 instance Proto.Serializable ExportLocation where
 	serialize (ExportLocation loc) = loc
 	deserialize = Just . ExportLocation
+
+instance Proto.Serializable ExportDirectory where
+	serialize (ExportDirectory loc) = loc
+	deserialize = Just . ExportDirectory
diff --git a/Remote/Helper/Export.hs b/Remote/Helper/Export.hs
index f7cfb6da3..44fa47ca5 100644
--- a/Remote/Helper/Export.hs
+++ b/Remote/Helper/Export.hs
@@ -32,8 +32,9 @@ instance HasExportUnsupported (Annex (ExportActions Annex)) where
 			warning "store export is unsupported"
 			return False
 		, retrieveExport = \_ _ _ _ -> return False
-		, removeExport = \_ _ -> return False
 		, checkPresentExport = \_ _ -> return False
+		, removeExport = \_ _ -> return False
+		, removeExportDirectory = Just $ \_ -> return False
 		, renameExport = \_ _ _ -> return False
 		}
 
diff --git a/Remote/S3.hs b/Remote/S3.hs
index 8b6fe6103..228a8047e 100644
--- a/Remote/S3.hs
+++ b/Remote/S3.hs
@@ -92,6 +92,8 @@ gen r u c gc = do
 					, retrieveExport = retrieveExportS3 info h
 					, removeExport = removeExportS3 info h
 					, checkPresentExport = checkPresentExportS3 info h
+					-- S3 does not have directories.
+					, removeExportDirectory = Nothing
 					, renameExport = renameExportS3 info h
 					}
 			, whereisKey = Just (getWebUrls info c)
diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs
index 8c72365e6..61fc70324 100644
--- a/Remote/WebDAV.hs
+++ b/Remote/WebDAV.hs
@@ -73,8 +73,10 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
 			, exportActions = withDAVHandle this $ \mh -> return $ ExportActions
 				{ storeExport = storeExportDav mh
 				, retrieveExport = retrieveExportDav mh
-				, removeExport = removeExportDav mh
 				, checkPresentExport = checkPresentExportDav this mh
+				, removeExport = removeExportDav mh
+				, removeExportDirectory = Just $
+					removeExportDirectoryDav mh
 				, renameExport = renameExportDav mh
 				}
 			, whereisKey = Nothing
@@ -189,10 +191,6 @@ retrieveExportDav mh  _k loc d p = runExport mh $ \_dav -> do
 	retrieveHelper (exportLocation loc) d p
 	return True
 
-removeExportDav :: Maybe DavHandle -> Key -> ExportLocation -> Annex Bool
-removeExportDav mh _k loc = runExport mh $ \_dav ->
-	removeHelper (exportLocation loc)
-
 checkPresentExportDav :: Remote -> Maybe DavHandle -> Key -> ExportLocation -> Annex Bool
 checkPresentExportDav r mh _k loc = case mh of
 	Nothing -> giveup $ name r ++ " not configured"
@@ -200,6 +198,15 @@ checkPresentExportDav r mh _k loc = case mh of
 		v <- goDAV h $ existsDAV (exportLocation loc)
 		either giveup return v
 
+removeExportDav :: Maybe DavHandle -> Key -> ExportLocation -> Annex Bool
+removeExportDav mh _k loc = runExport mh $ \_dav ->
+	removeHelper (exportLocation loc)
+
+removeExportDirectoryDav :: Maybe DavHandle -> ExportDirectory -> Annex Bool
+removeExportDirectoryDav mh (ExportDirectory dir) = runExport mh $ \_dav ->
+	safely (inLocation dir delContentM)
+		>>= maybe (return False) (const $ return True)
+
 renameExportDav :: Maybe DavHandle -> Key -> ExportLocation -> ExportLocation -> Annex Bool
 renameExportDav Nothing _ _ _ = return False
 renameExportDav (Just h) _k src dest