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

diff --git a/CHANGELOG b/CHANGELOG
index bb001943cc0cf91a619b41f4ba2daaf572fc4854..8eafb7bd6f9cc2e6bd7ac0e15677306d20c642b8 100644 (file)
--- a/CHANGELOG
+++ b/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

diff --git a/Remote/Directory.hs b/Remote/Directory.hs
index 4d91b2551e0c9dac48ac6e588620305fcdd938df..b5f756716c7e1dadf4bdf6b263b81c5ab8cc8283 100644 (file)
--- a/Remote/Directory.hs
+++ b/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

diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs
index 3429c1a037ebb2585721123d5cefe58142ee660e..fec30195c9a44f5c1a9bcd5c3ee076cad1d00174 100644 (file)
--- a/Remote/GCrypt.hs
+++ b/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

diff --git a/doc/bugs/__34__directory__34___special_remote_leaves_empty_dirs.mdwn b/doc/bugs/__34__directory__34___special_remote_leaves_empty_dirs.mdwn
index a7a95567e88e980d5d344878b98444be47e0ee6a..148f57ebedcb9775bedd8ae21b58684fe216e073 100644 (file)
--- a/doc/bugs/__34__directory__34___special_remote_leaves_empty_dirs.mdwn
+++ b/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]]

diff --git a/doc/bugs/__34__directory__34___special_remote_leaves_empty_dirs/comment_1_8cef8650103d118fbbe56d20a4f59f96._comment b/doc/bugs/__34__directory__34___special_remote_leaves_empty_dirs/comment_1_8cef8650103d118fbbe56d20a4f59f96._comment
new file mode 100644 (file)
index 0000000..2d75add
--- /dev/null
+++ b/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.
+"""]]