gcrypt: fix removal of key that does not exist

Generalized code from Remote.Directory and reused it.

Test suite now passes for local gcrypt repos.

2 files changed, 19 insertions, 16 deletions

diff --git a/Remote/Directory.hs b/Remote/Directory.hs
index db141e01a..3b54ad200 100644
--- a/Remote/Directory.hs
+++ b/Remote/Directory.hs
@@ -7,7 +7,7 @@
 
 {-# LANGUAGE CPP #-}
 
-module Remote.Directory (remote) where
+module Remote.Directory (remote, removeDirGeneric) where
 
 import qualified Data.ByteString.Lazy as L
 import qualified Data.Map as M
@@ -152,7 +152,20 @@ retrieveCheap _ _ _ _ = return False
 #endif
 
 remove :: FilePath -> Key -> Annex Bool
-remove d k = liftIO $ do
+remove d k = liftIO $ removeDirGeneric d (storeDir d k)
+
+{- Removes the directory, which must be located under the topdir.
+ -
+ - Succeeds even on directories and contents that do not have write
+ - permission.
+ -
+ - If the directory does not exist, succeeds as long as the topdir does
+ - 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.
+ -}
+removeDirGeneric :: FilePath -> FilePath -> IO Bool
+removeDirGeneric topdir dir = do
 	void $ tryIO $ allowWrite dir
 #ifdef mingw32_HOST_OS
 	{- Windows needs the files inside the directory to be writable
@@ -162,14 +175,9 @@ remove d k = liftIO $ do
 	ok <- catchBoolIO $ do
 		removeDirectoryRecursive dir
 		return True
-	{- Removing the subdirectory will fail if it doesn't exist.
-	 - But, we want to succeed in that case, as long as the directory
-	 - remote's top-level directory does exist. -}
 	if ok
 		then return ok
-		else doesDirectoryExist d <&&> (not <$> doesDirectoryExist dir)
-  where
-	dir = storeDir d k
+		else doesDirectoryExist topdir <&&> (not <$> doesDirectoryExist dir)
 
 checkPresent :: FilePath -> ChunkConfig -> Key -> Annex (Either String Bool)
 checkPresent d (LegacyChunks _) k = Legacy.checkPresent d locations k
diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs
index 02c31f38d..a0292a954 100644
--- a/Remote/GCrypt.hs
+++ b/Remote/GCrypt.hs
@@ -40,6 +40,7 @@ import Utility.Metered
 import Annex.UUID
 import Annex.Ssh
 import qualified Remote.Rsync
+import qualified Remote.Directory
 import Utility.Rsync
 import Utility.Tmp
 import Logs.Remote
@@ -335,14 +336,8 @@ retrieve r rsyncopts
 
 remove :: Remote -> Remote.Rsync.RsyncOpts -> Key -> Annex Bool
 remove r rsyncopts k
-	| not $ Git.repoIsUrl (repo r) = guardUsable (repo r) False $ do
-		let f = gCryptLocation r k
-		let d = parentDir f
-		liftIO $ do
-			allowWrite d
-			allowWrite f
-			removeDirectoryRecursive d
-		return True
+	| not $ Git.repoIsUrl (repo r) = guardUsable (repo r) False $
+		liftIO $ Remote.Directory.removeDirGeneric (Git.repoLocation (repo r)) (parentDir (gCryptLocation r k))
 	| Git.repoIsSsh (repo r) = shellOrRsync r removeshell removersync
 	| otherwise = unsupportedUrl
   where