directory: Remove empty hash directories when dropping content

Failure to remove is not treated as a problem, and no permissions
modifications are done, to avoid unexpected states.

Sponsored-by: Luke Shumaker on Patreon

CHANGELOG

@@ -22,6 +22,7 @@ git-annex (10.20230627) UNRELEASED; urgency=medium
   * S3: Allow setting publicurl=yes without public=yes, to support
     buckets that are configured with a Bucket Policy that allows public
     access.
+  * directory: Remove empty hash directories when dropping content.
   * dropunused: Support --jobs
 
  -- Joey Hess <id@joeyh.name>  Mon, 26 Jun 2023 13:10:40 -0400

Remote/Directory.hs

@@ -232,7 +232,7 @@ checkDiskSpaceDirectory d k = do
  - down. -}
 finalizeStoreGeneric :: RawFilePath -> RawFilePath -> RawFilePath -> IO ()
 finalizeStoreGeneric d tmp dest = do
-	removeDirGeneric (fromRawFilePath d) dest'
+	removeDirGeneric False (fromRawFilePath d) dest'
 	createDirectoryUnder [d] (parentDir dest)
 	renameDirectory (fromRawFilePath tmp) dest'
 	-- may fail on some filesystems
@@ -266,7 +266,7 @@ retrieveKeyFileCheapM _ _ = Nothing
 #endif
 
 removeKeyM :: RawFilePath -> Remover
-removeKeyM d k = liftIO $ removeDirGeneric
+removeKeyM d k = liftIO $ removeDirGeneric True
 	(fromRawFilePath d)
 	(fromRawFilePath (storeDir d k))
 
@@ -279,9 +279,13 @@ removeKeyM d k = liftIO $ removeDirGeneric
  - 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.
+ -
+ - Empty parent directories (up to but not including the topdir)
+ - can also be removed. Failure to remove such a directory is not treated
+ - as an error.
  -}
-removeDirGeneric :: FilePath -> FilePath -> IO ()
-removeDirGeneric topdir dir = do
+removeDirGeneric :: Bool -> FilePath -> FilePath -> IO ()
+removeDirGeneric removeemptyparents topdir dir = do
 	void $ tryIO $ allowWrite (toRawFilePath dir)
 #ifdef mingw32_HOST_OS
 	{- Windows needs the files inside the directory to be writable
@@ -293,6 +297,15 @@ removeDirGeneric topdir dir = do
 		Left e ->
 			unlessM (doesDirectoryExist topdir <&&> (not <$> doesDirectoryExist dir)) $
 				throwM e
+	when removeemptyparents $ do
+		subdir <- relPathDirToFile (toRawFilePath topdir) (P.takeDirectory (toRawFilePath dir))
+		goparents (Just (P.takeDirectory subdir)) (Right ())
+  where
+	goparents _ (Left _e) = return ()
+	goparents Nothing _ = return ()
+	goparents (Just subdir) _ = do
+		let d = topdir </> fromRawFilePath subdir
+		goparents (upFrom subdir) =<< tryIO (removeDirectory d)
 
 checkPresentM :: RawFilePath -> ChunkConfig -> CheckPresent
 checkPresentM d (LegacyChunks _) k = Legacy.checkKey d locations k

Remote/GCrypt.hs

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

doc/bugs/__34__directory__34___special_remote_leaves_empty_dirs.mdwn

@@ -112,3 +112,5 @@ drop sp_rsync a ok
 
 I'm tinkering with annex for about 1 week, "doing research" in preparation to
 use it as storage for backups.
+
+> [[fixed|done]] --[[Joey]]

doc/bugs/__34__directory__34___special_remote_leaves_empty_dirs/comment_1_8cef8650103d118fbbe56d20a4f59f96._comment

@@ -0,0 +1,16 @@
+[[!comment format=mdwn
+ username="joey"
+ subject="""comment 1"""
+ date="2023-07-21T18:08:52Z"
+ content="""
+Hmm, I guess this wasn't implemented because a generally small number of
+hash directories are not a bother. And because implementing it was a bit
+annoying.
+
+Testremote cannot test for this, because remotes do not need to have the
+concept of a "directory". For example, a S3 bucket does not contain
+directories, only filenames that may contain a "/" in them. Also, I don't
+think it's necessarily a bug for a special remote to leave hash directories
+in place when removing files. There could be good reasons to do that in
+some cases.
+"""]]