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.

8 files changed, 56 insertions, 41 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
 
diff --git a/Annex/Content/Direct.hs b/Annex/Content/Direct.hs
index b0b8621e9..a5d71288b 100644
--- a/Annex/Content/Direct.hs
+++ b/Annex/Content/Direct.hs
@@ -10,6 +10,7 @@ module Annex.Content.Direct (
 	associatedFilesRelative,
 	removeAssociatedFile,
 	removeAssociatedFileUnchecked,
+	removeAssociatedFiles,
 	addAssociatedFile,
 	goodContent,
 	recordedInodeCache,
@@ -64,8 +65,8 @@ changeAssociatedFiles key transform = do
 	files <- associatedFilesRelative key
 	let files' = transform files
 	when (files /= files') $ do
-		createContentDir mapping
-		liftIO $ viaTmp write mapping $ unlines files'
+		modifyContent mapping $
+			liftIO $ viaTmp write mapping $ unlines files'
 	top <- fromRepo Git.repoPath
 	return $ map (top </>) files'
   where
@@ -75,6 +76,13 @@ changeAssociatedFiles key transform = do
  		hPutStr h content
 		hClose h
 
+{- Removes the list of associated files. -}
+removeAssociatedFiles :: Key -> Annex ()
+removeAssociatedFiles key = do
+	mapping <- calcRepo $ gitAnnexMapping key
+	modifyContent mapping $
+		liftIO $ nukeFile mapping
+
 {- Removes an associated file. Returns new associatedFiles value.
  - Checks if this was the last copy of the object, and updates location
  - log. -}
@@ -142,16 +150,16 @@ addInodeCache key cache = do
 
 {- Writes inode cache for a key. -}
 writeInodeCache :: Key -> [InodeCache] -> Annex ()
-writeInodeCache key caches = withInodeCacheFile key $ \f -> do
-	createContentDir f
-	liftIO $ writeFile f $
-		unlines $ map showInodeCache caches
+writeInodeCache key caches = withInodeCacheFile key $ \f -> 
+	modifyContent f $
+		liftIO $ writeFile f $
+			unlines $ map showInodeCache caches
 
 {- Removes an inode cache. -}
 removeInodeCache :: Key -> Annex ()
-removeInodeCache key = withInodeCacheFile key $ \f -> do
-	createContentDir f -- also thaws directory
-	liftIO $ nukeFile f
+removeInodeCache key = withInodeCacheFile key $ \f ->
+	modifyContent f $
+		liftIO $ nukeFile f
 
 withInodeCacheFile :: Key -> (FilePath -> Annex a) -> Annex a
 withInodeCacheFile key a = a =<< calcRepo (gitAnnexInodeCache key)
diff --git a/Annex/Direct.hs b/Annex/Direct.hs
index 366966fc2..3fa5f9362 100644
--- a/Annex/Direct.hs
+++ b/Annex/Direct.hs
@@ -210,11 +210,11 @@ toDirectGen k f = do
   where
   	fromindirect loc = do
 		{- Move content from annex to direct file. -}
-		thawContentDir loc
 		updateInodeCache k loc
 		void $ addAssociatedFile k f
-		thawContent loc
-		replaceFile f $ liftIO . moveFile loc
+		modifyContent loc $ do
+			thawContent loc
+			replaceFile f $ liftIO . moveFile loc
 	fromdirect loc = do
 		replaceFile f $
 			liftIO . void . copyFileExternal loc
diff --git a/Annex/Perms.hs b/Annex/Perms.hs
index f5925b741..9ce0fe2a6 100644
--- a/Annex/Perms.hs
+++ b/Annex/Perms.hs
@@ -13,12 +13,14 @@ module Annex.Perms (
 	createContentDir,
 	freezeContentDir,
 	thawContentDir,
+	modifyContent,
 ) where
 
 import Common.Annex
 import Utility.FileMode
 import Git.SharedRepository
 import qualified Annex
+import Annex.Exception
 import Config
 
 import System.Posix.Types
@@ -103,3 +105,13 @@ createContentDir dest = do
 		liftIO $ allowWrite dir
   where
 	dir = parentDir dest
+
+{- Creates the content directory for a file if it doesn't already exist,
+ - or thaws it if it does, then runs an action to modify the file, and
+ - finally, freezes the content directory. -}
+modifyContent :: FilePath -> Annex a -> Annex a
+modifyContent f a = do
+	createContentDir f -- also thaws it
+	v <- tryAnnex a
+	freezeContentDir f
+	either throwAnnex return v
diff --git a/Command/Fsck.hs b/Command/Fsck.hs
index 3b89c550c..a8e52af98 100644
--- a/Command/Fsck.hs
+++ b/Command/Fsck.hs
@@ -218,9 +218,10 @@ verifyLocationLog key desc = do
 	
 	{- Since we're checking that a key's file is present, throw
 	 - in a permission fixup here too. -}
-	when (present && not direct) $ do
-		file <- calcRepo $ gitAnnexLocation key
+	file <- calcRepo $ gitAnnexLocation key
+	when (present && not direct) $
 		freezeContent file
+	whenM (liftIO $ doesDirectoryExist $ parentDir file) $
 		freezeContentDir file
 
 	{- In direct mode, modified files will show up as not present,
diff --git a/Command/Indirect.hs b/Command/Indirect.hs
index a2512ea96..8b857e2f6 100644
--- a/Command/Indirect.hs
+++ b/Command/Indirect.hs
@@ -20,9 +20,9 @@ import Config
 import qualified Annex
 import Annex.Direct
 import Annex.Content
+import Annex.Content.Direct
 import Annex.CatFile
 import Annex.Version
-import Annex.Perms
 import Annex.Exception
 import Init
 import qualified Command.Add
@@ -77,7 +77,8 @@ perform = do
 			Just s
 				| isSymbolicLink s -> void $ flip whenAnnexed f $
 					\_ (k, _) -> do
-						cleandirect k
+						removeInodeCache k
+						removeAssociatedFiles k
 						return Nothing
 				| otherwise -> 
 					maybe noop (fromdirect f)
@@ -87,8 +88,8 @@ perform = do
 
 	fromdirect f k = do
 		showStart "indirect" f
-		thawContentDir =<< calcRepo (gitAnnexLocation k)
-		cleandirect k -- clean before content directory gets frozen
+		removeInodeCache k
+		removeAssociatedFiles k
 		whenM (liftIO $ not . isSymbolicLink <$> getSymbolicLinkStatus f) $ do
 			v <-tryAnnexIO (moveAnnex k f)
 			case v of
@@ -103,10 +104,6 @@ perform = do
 	warnlocked e = do
 		warning $ show e
 		warning "leaving this file as-is; correct this problem and run git annex add on it"
-
-	cleandirect k = do
-		liftIO . nukeFile =<< calcRepo (gitAnnexInodeCache k)
-		liftIO . nukeFile =<< calcRepo (gitAnnexMapping k)
 	
 cleanup :: CommandCleanup
 cleanup = do
diff --git a/debian/changelog b/debian/changelog
index 86e833eab..4f1e766ab 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -31,6 +31,10 @@ git-annex (5.20131102) UNRELEASED; urgency=low
     with a directory. An ordering problem caused the directory to not get
     created in this case.
     Thanks to Tim for the test cases.
+  * 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.
 
  -- Joey Hess <joeyh@debian.org>  Wed, 06 Nov 2013 16:14:14 -0400
 
diff --git a/doc/bugs/Incorrect_merge___40__a_special_case__41__.mdwn b/doc/bugs/Incorrect_merge___40__a_special_case__41__.mdwn
index 5b817e214..8e25ed6cb 100644
--- a/doc/bugs/Incorrect_merge___40__a_special_case__41__.mdwn
+++ b/doc/bugs/Incorrect_merge___40__a_special_case__41__.mdwn
@@ -43,3 +43,6 @@ remote types: git gcrypt S3 bup directory rsync web webdav glacier hook
 
 Linux ceilingcat 3.11.6-1-ARCH #1 SMP PREEMPT Fri Oct 18 23:22:36 CEST 2013 x86_64 GNU/Linux
 """]]
+
+> [[fixed|done]]; direct mode now freezes the content directory as indirect
+> mode already did. fsck will fix up the permissions too. --[[Joey]]