Direct mode .git/annex/objects directories are no longer left writable

Because that allowed writing to symlinks of files that are not present,
which followed the link and put bad content in an object location.

fsck: Fix up .git/annex/object directory permissions.

This commit was sponsored by an anonymous bitcoin donor.

1 files changed, 9 insertions, 19 deletions

diff --git a/Annex/Content.hs b/Annex/Content.hs
index 66ca7be18..5ce0f2689 100644
--- a/Annex/Content.hs
+++ b/Annex/Content.hs
@@ -29,7 +29,6 @@ module Annex.Content (
 	preseedTmp,
 	freezeContent,
 	thawContent,
-	cleanObjectLoc,
 	dirKeys,
 ) where
 
@@ -255,11 +254,9 @@ moveAnnex key src = withObjectLoc key storeobject storedirect
   where
 	storeobject dest = ifM (liftIO $ doesFileExist dest)
 		( alreadyhave
-		, do
-			createContentDir dest
+		, modifyContent dest $ do
 			liftIO $ moveFile src dest
 			freezeContent dest
-			freezeContentDir dest
 		)
 	storeindirect = storeobject =<< calcRepo (gitAnnexLocation key)
 
@@ -273,7 +270,6 @@ moveAnnex key src = withObjectLoc key storeobject storedirect
 	storedirect = storedirect' storeindirect
 	storedirect' fallback [] = fallback
 	storedirect' fallback (f:fs) = do
-		thawContentDir =<< calcRepo (gitAnnexLocation key)
 		thawContent src
 		v <- isAnnexLink f
 		if Just key == v
@@ -349,11 +345,11 @@ withObjectLoc key indirect direct = ifM isDirect
   where
 	goindirect = indirect =<< calcRepo (gitAnnexLocation key)
 
-cleanObjectLoc :: Key -> Annex ()
-cleanObjectLoc key = do
+cleanObjectLoc :: Key -> Annex () -> Annex ()
+cleanObjectLoc key cleaner = do
 	file <- calcRepo $ gitAnnexLocation key
-	unlessM crippledFileSystem $
-		void $ liftIO $ catchMaybeIO $ allowWrite $ parentDir file
+	void $ tryAnnexIO $ thawContentDir file
+	cleaner
 	liftIO $ removeparents file (3 :: Int)
   where
 	removeparents _ 0 = noop
@@ -369,13 +365,10 @@ cleanObjectLoc key = do
 removeAnnex :: Key -> Annex ()
 removeAnnex key = withObjectLoc key remove removedirect
   where
-	remove file = do
-		thawContentDir file
+	remove file = cleanObjectLoc key $ do
 		liftIO $ nukeFile file
 		removeInodeCache key
-		cleanObjectLoc key
 	removedirect fs = do
-		thawContentDir =<< calcRepo (gitAnnexLocation key)
 		cache <- recordedInodeCache key
 		removeInodeCache key
 		mapM_ (resetfile cache) fs
@@ -389,12 +382,10 @@ removeAnnex key = withObjectLoc key remove removedirect
 
 {- Moves a key's file out of .git/annex/objects/ -}
 fromAnnex :: Key -> FilePath -> Annex ()
-fromAnnex key dest = do
+fromAnnex key dest = cleanObjectLoc key $ do
 	file <- calcRepo $ gitAnnexLocation key
-	thawContentDir file
 	thawContent file
 	liftIO $ moveFile file dest
-	cleanObjectLoc key
 
 {- Moves a key out of .git/annex/objects/ into .git/annex/bad, and
  - returns the file it was moved to. -}
@@ -404,9 +395,8 @@ moveBad key = do
 	bad <- fromRepo gitAnnexBadDir
 	let dest = bad </> takeFileName src
 	createAnnexDirectory (parentDir dest)
-	thawContentDir src
-	liftIO $ moveFile src dest
-	cleanObjectLoc key
+	cleanObjectLoc key $
+		liftIO $ moveFile src dest
 	logStatus key InfoMissing
 	return dest