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
This commit is contained in:
Joey Hess 2023-07-21 14:57:29 -04:00
parent 7f38355860
commit b15366494a
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
5 changed files with 37 additions and 5 deletions

View file

@ -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

View file

@ -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