fix empty tree import when directory does not exist

Fix behavior when importing a tree from a directory remote when the
directory does not exist. An empty tree was imported, rather than the
import failing. Merging that tree would delete every file in the
branch, if those files had been exported to the directory before.

The problem was that dirContentsRecursive returned [] when the directory
did not exist. Better for it to throw an exception. But in commit
74f0d67aa3 back in 2012, I made it never
theow exceptions, because exceptions throw inside unsafeInterleaveIO become
untrappable when the list is being traversed.

So, changed it to list the contents of the directory before entering
unsafeInterleaveIO. So exceptions are thrown for the directory. But still
not if it's unable to list the contents of a subdirectory. That's less of a
problem, because the subdirectory does exist (or if not, it got removed
after being listed, and it's ok to not include it in the list). A
subdirectory that has permissions that don't allow listing it will have its
contents omitted from the list still.

(Might be better to have it return a type that includes indications of
errors listing contents of subdirectories?)

The rest of the changes are making callers of dirContentsRecursive
use emptyWhenDoesNotExist when they relied on the behavior of it not
throwing an exception when the directory does not exist. Note that
it's possible some callers of dirContentsRecursive that used to ignore
permissions problems listing a directory will now start throwing exceptions
on them.

The fix to the directory special remote consisted of not making its
call in listImportableContentsM use emptyWhenDoesNotExist. So it will
throw an exception as desired.

Sponsored-by: Joshua Antonishen on Patreon

Annex/AdjustedBranch/Merge.hs

@@ -80,8 +80,9 @@ mergeToAdjustedBranch tomerge (origbranch, adj) mergeconfig canresolvemerge comm
 				-- Copy in refs and packed-refs, to work
 				-- around bug in git 2.13.0, which
 				-- causes it not to look in GIT_DIR for refs.
-				refs <- liftIO $ dirContentsRecursive $
-					git_dir' </> "refs"
+				refs <- liftIO $ emptyWhenDoesNotExist $ 
+					dirContentsRecursive $
+						git_dir' </> "refs"
 				let refs' = (git_dir' </> "packed-refs") : refs
 				liftIO $ forM_ refs' $ \src -> do
 					let src' = toRawFilePath src

Annex/Tmp.hs

@@ -61,7 +61,8 @@ cleanupOtherTmp = do
 		tmpdir <- fromRawFilePath <$> fromRepo gitAnnexTmpOtherDir
 		void $ liftIO $ tryIO $ removeDirectoryRecursive tmpdir
 		oldtmp <- fromRawFilePath <$> fromRepo gitAnnexTmpOtherDirOld
-		liftIO $ mapM_ cleanold =<< dirContentsRecursive oldtmp
+		liftIO $ mapM_ cleanold
+			=<< emptyWhenDoesNotExist (dirContentsRecursive oldtmp)
 		liftIO $ void $ tryIO $ removeDirectory oldtmp -- when empty
   where
 	cleanold f = do

Assistant/Repair.hs

@@ -127,7 +127,8 @@ runRepair u mrmt destructiverepair = do
  -}
 repairStaleGitLocks :: Git.Repo -> Assistant Bool
 repairStaleGitLocks r = do
-	lockfiles <- liftIO $ filter islock <$> findgitfiles r
+	lockfiles <- liftIO $ filter islock
+		<$> emptyWhenDoesNotExist (findgitfiles r)
 	repairStaleLocks lockfiles
 	return $ not $ null lockfiles
   where

Build/DistributionUpdate.hs

@@ -169,7 +169,7 @@ makeinfos updated changelogversion = do
 	
 	-- Check for out of date info files.
 	infos <- liftIO $ filter (".info" `isSuffixOf`)
-		<$> dirContentsRecursive "git-annex"
+		<$> emptyWhenDoesNotExist (dirContentsRecursive "git-annex")
 	ds <- liftIO $ forM infos (readish <$$> readFile)
 	let dis = zip infos ds
 	let ood = filter outofdate dis

CHANGELOG

@@ -4,6 +4,9 @@ git-annex (10.20230803) UNRELEASED; urgency=medium
   * info: Added --dead-repositories option. 
   * Significant startup speed increase by avoiding repeatedly checking
     if some remote git-annex branch refs need to be merged.
+  * Fix behavior when importing a tree from a directory remote when the
+    directory does not exist. An empty tree was imported, rather than the
+    import failing.
 
  -- Joey Hess <id@joeyh.name>  Mon, 07 Aug 2023 13:04:13 -0400
 

Command/Uninit.hs

@@ -141,7 +141,7 @@ prepareRemoveAnnexDir annexdir = do
 
 prepareRemoveAnnexDir' :: FilePath -> IO ()
 prepareRemoveAnnexDir' annexdir =
-	dirTreeRecursiveSkipping (const False) annexdir 
+	emptyWhenDoesNotExist (dirTreeRecursiveSkipping (const False) annexdir)
 		>>= mapM_ (void . tryIO . allowWrite . toRawFilePath)
 
 {- Keys that were moved out of the annex have a hard link still in the

Git/Objects.hs

@@ -32,7 +32,7 @@ listPackFiles r = filter (".pack" `isSuffixOf`)
 listLooseObjectShas :: Repo -> IO [Sha]
 listLooseObjectShas r = catchDefaultIO [] $
 	mapMaybe (extractSha . encodeBS . concat . reverse . take 2 . reverse . splitDirectories)
-		<$> dirContentsRecursiveSkipping (== "pack") True (fromRawFilePath (objectsDir r))
+		<$> emptyWhenDoesNotExist (dirContentsRecursiveSkipping (== "pack") True (fromRawFilePath (objectsDir r)))
 
 looseObjectFile :: Repo -> Sha -> RawFilePath
 looseObjectFile r sha = objectsDir r P.</> prefix P.</> rest

Git/Repair.hs

@@ -88,7 +88,7 @@ explodePacks r = go =<< listPackFiles r
 			void $ tryIO $
 				pipeWrite [Param "unpack-objects", Param "-r"] r' $ \h ->
 				L.hPut h =<< L.readFile packfile
-		objs <- dirContentsRecursive tmpdir
+		objs <- emptyWhenDoesNotExist (dirContentsRecursive tmpdir)
 		forM_ objs $ \objfile -> do
 			f <- relPathDirToFile
 				(toRawFilePath tmpdir)
@@ -255,7 +255,7 @@ getAllRefs' refdir = do
 	let topsegs = length (splitPath refdir) - 1
 	let toref = Ref . toInternalGitPath . encodeBS 
 		. joinPath . drop topsegs . splitPath
-	map toref <$> dirContentsRecursive refdir
+	map toref <$> emptyWhenDoesNotExist (dirContentsRecursive refdir)
 
 explodePackedRefsFile :: Repo -> IO ()
 explodePackedRefsFile r = do

Logs/Transfer.hs

@@ -152,7 +152,7 @@ getTransfers' dirs wanted = do
 	infos <- mapM checkTransfer transfers
 	return $ mapMaybe running $ zip transfers infos
   where
-	findfiles = liftIO . mapM (dirContentsRecursive . fromRawFilePath)
+	findfiles = liftIO . mapM (emptyWhenDoesNotExist . dirContentsRecursive . fromRawFilePath)
 		=<< mapM (fromRepo . transferDir) dirs
 	running (t, Just i) = Just (t, i)
 	running (_, Nothing) = Nothing
@@ -179,7 +179,7 @@ getFailedTransfers u = catMaybes <$> (liftIO . getpairs =<< concat <$> findfiles
 		return $ case (mt, mi) of
 			(Just t, Just i) -> Just (t, i)
 			_ -> Nothing
-	findfiles = liftIO . mapM (dirContentsRecursive . fromRawFilePath)
+	findfiles = liftIO . mapM (emptyWhenDoesNotExist . dirContentsRecursive . fromRawFilePath)
 		=<< mapM (fromRepo . failedTransferDir u) [Download, Upload]
 
 clearFailedTransfers :: UUID -> Annex [(Transfer, TransferInfo)]

Remote/Helper/Git.hs

@@ -40,7 +40,7 @@ gitRepoInfo :: Remote -> Annex [(String, String)]
 gitRepoInfo r = do
 	d <- fromRawFilePath <$> fromRepo Git.localGitDir
 	mtimes <- liftIO $ mapM (\p -> modificationTime <$> R.getFileStatus (toRawFilePath p))
-		=<< dirContentsRecursive (d </> "refs" </> "remotes" </> Remote.name r)
+		=<< emptyWhenDoesNotExist (dirContentsRecursive (d </> "refs" </> "remotes" </> Remote.name r))
 	let lastsynctime = case mtimes of
 		[] -> "never"
 		_ -> show $ posixSecondsToUTCTime $ realToFrac $ maximum mtimes

Utility/DirWatcher/FSEvents.hs

@@ -70,7 +70,7 @@ watchDir dir ignored scanevents hooks = do
 	scan d = unless (ignoredPath ignored d) $
 		-- Do not follow symlinks when scanning.
 		-- This mirrors the inotify startup scan behavior.
-		mapM_ go =<< dirContentsRecursiveSkipping (const False) False d
+		mapM_ go =<< emptyWhenDoesNotExist (dirContentsRecursiveSkipping (const False) False d)
 	  where		
 		go f
 			| ignoredPath ignored f = noop

Utility/DirWatcher/Win32Notify.hs

@@ -43,7 +43,7 @@ watchDir dir ignored scanevents hooks = do
 		runhook h s = maybe noop (\a -> a (filePath evt) s) (h hooks)
 
 	scan d = unless (ignoredPath ignored d) $
-		mapM_ go =<< dirContentsRecursiveSkipping (const False) False d
+		mapM_ go =<< emptyWhenDoesNotExist (dirContentsRecursiveSkipping (const False) False d)
 	  where		
 		go f
 			| ignoredPath ignored f = noop

Utility/Directory.hs

@@ -1,6 +1,6 @@
 {- directory traversal and manipulation
  -
- - Copyright 2011-2020 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2023 Joey Hess <id@joeyh.name>
  -
  - License: BSD-2-clause
  -}
@@ -43,14 +43,26 @@ dirContents d = map (d </>) . filter (not . dirCruft) <$> getDirectoryContents d
  -
  - Does not follow symlinks to other subdirectories.
  -
- - When the directory does not exist, no exception is thrown,
- - instead, [] is returned. -}
+ - Throws exception if the directory does not exist or otherwise cannot be
+ - accessed. However, does not throw exceptions when subdirectories cannot
+ - be accessed (the use of unsafeInterleaveIO would make it difficult to
+ - trap such exceptions).
+ -}
 dirContentsRecursive :: FilePath -> IO [FilePath]
 dirContentsRecursive = dirContentsRecursiveSkipping (const False) True
 
 {- Skips directories whose basenames match the skipdir. -}
 dirContentsRecursiveSkipping :: (FilePath -> Bool) -> Bool -> FilePath -> IO [FilePath]
-dirContentsRecursiveSkipping skipdir followsubdirsymlinks topdir = go [topdir]
+dirContentsRecursiveSkipping skipdir followsubdirsymlinks topdir
+	| skipdir (takeFileName topdir) = return []
+	| otherwise = do
+		-- Get the contents of the top directory outside of
+		-- unsafeInterleaveIO, which allows throwing exceptions if
+		-- it cannot be accessed.
+		(files, dirs) <- collect [] []
+			=<< dirContents topdir
+		files' <- go dirs
+		return (files ++ files')
   where
 	go [] = return []
 	go (dir:dirs)
@@ -79,9 +91,19 @@ dirContentsRecursiveSkipping skipdir followsubdirsymlinks topdir = go [topdir]
 
 {- Gets the directory tree from a point, recursively and lazily,
  - with leaf directories **first**, skipping any whose basenames
- - match the skipdir. Does not follow symlinks. -}
+ - match the skipdir. Does not follow symlinks.
+ -
+ - Throws exception if the directory does not exist or otherwise cannot be
+ - accessed. However, does not throw exceptions when subdirectories cannot
+ - be accessed (the use of unsafeInterleaveIO would make it difficult to
+ - trap such exceptions).
+ -}
 dirTreeRecursiveSkipping :: (FilePath -> Bool) -> FilePath -> IO [FilePath]
-dirTreeRecursiveSkipping skipdir topdir = go [] [topdir]
+dirTreeRecursiveSkipping skipdir topdir
+	| skipdir (takeFileName topdir) = return []
+	| otherwise = do
+		subdirs <- filterM isdir =<< dirContents topdir
+		go [] subdirs
   where
 	go c [] = return c
 	go c (dir:dirs)
@@ -93,6 +115,12 @@ dirTreeRecursiveSkipping skipdir topdir = go [] [topdir]
 			go (subdirs++dir:c) dirs
 	isdir p = isDirectory <$> R.getSymbolicLinkStatus (toRawFilePath p)
 
+{- When the action fails due to the directory not existing, returns []. -}
+emptyWhenDoesNotExist :: IO [a] -> IO [a]
+emptyWhenDoesNotExist a = tryWhenExists a >>= return . \case
+	Just v -> v
+	Nothing -> []
+
 {- Use with an action that removes something, which may or may not exist.
  -
  - If an exception is thrown due to it not existing, it is ignored.