Preserve execute bits of unlocked files in v6 mode.

When annex.thin is set, adding an object will add the execute bits to the
work tree file, and this does mean that the annex object file ends up
executable.

This doesn't add any complexity that wasn't already present, because git
annex add of an executable file has always ingested it so that the annex
object ends up executable.

But, since an annex object file can be executable or not, when populating
an unlocked file from one, the executable bit is always added or removed
to match the mode of the pointer file.

4 files changed, 101 insertions, 49 deletions

diff --git a/Annex/AutoMerge.hs b/Annex/AutoMerge.hs
index 074e955d7..e6f2be552 100644
--- a/Annex/AutoMerge.hs
+++ b/Annex/AutoMerge.hs
@@ -23,7 +23,7 @@ import qualified Git.Merge
 import qualified Git.Ref
 import qualified Git
 import qualified Git.Branch
-import Git.Types (BlobType(..))
+import Git.Types (BlobType(..), fromBlobType)
 import Git.FilePath
 import Config
 import Annex.ReplaceFile
@@ -31,6 +31,7 @@ import Annex.VariantFile
 import qualified Database.Keys
 import Annex.InodeSentinal
 import Utility.InodeCache
+import Utility.FileMode
 
 import qualified Data.Set as S
 import qualified Data.Map as M
@@ -152,12 +153,12 @@ resolveMerge' unstagedmap (Just us) them inoverlay u = do
 				-- In either case, keep original filename.
 				if islocked LsFiles.valUs && islocked LsFiles.valThem
 					then makesymlink keyUs file
-					else makepointer keyUs file
+					else makepointer keyUs file (combinedmodes)
 				return ([keyUs, keyThem], Just file)
 		-- Our side is annexed file, other side is not.
 		(Just keyUs, Nothing) -> resolveby [keyUs] $ do
 			graftin them file LsFiles.valThem LsFiles.valThem LsFiles.valUs
-			makeannexlink keyUs LsFiles.valUs
+			makeannexlink keyUs LsFiles.valUs 
 		-- Our side is not annexed file, other side is.
 		(Nothing, Just keyThem) -> resolveby [keyThem] $ do
 			graftin us file LsFiles.valUs LsFiles.valUs LsFiles.valThem
@@ -174,11 +175,19 @@ resolveMerge' unstagedmap (Just us) them inoverlay u = do
 	
 	islocked select = select (LsFiles.unmergedBlobType u) == Just SymlinkBlob
 
+	combinedmodes = case catMaybes [ourmode, theirmode] of
+		[] -> Nothing
+		l -> Just (combineModes l)
+	  where
+		ourmode = fromBlobType <$> LsFiles.valUs (LsFiles.unmergedBlobType u)
+		theirmode = fromBlobType <$> LsFiles.valThem (LsFiles.unmergedBlobType u)
+
 	makeannexlink key select
 		| islocked select = makesymlink key dest
-		| otherwise = makepointer key dest
+		| otherwise = makepointer key dest destmode
 	  where
 		dest = variantFile file key
+		destmode = fromBlobType <$> select (LsFiles.unmergedBlobType u)
 
 	stagefile :: FilePath -> Annex FilePath
 	stagefile f
@@ -194,16 +203,16 @@ resolveMerge' unstagedmap (Just us) them inoverlay u = do
 	replacewithsymlink dest link = withworktree dest $ \f ->
 		replaceFile f $ makeGitLink link
 
-	makepointer key dest = do
+	makepointer key dest destmode = do
 		unless inoverlay $ 
 			unlessM (reuseOldFile unstagedmap key file dest) $ do
-				r <- linkFromAnnex key dest
+				r <- linkFromAnnex key dest destmode
 				case r of
 					LinkAnnexFailed -> liftIO $
-						writeFile dest (formatPointer key)
+						writePointerFile dest key destmode
 					_ -> noop
 		dest' <- stagefile dest
-		stagePointerFile dest' =<< hashPointerFile key
+		stagePointerFile dest' destmode =<< hashPointerFile key
 		unless inoverlay $
 			Database.Keys.addAssociatedFile key
 				=<< inRepo (toTopFilePath dest)
diff --git a/Annex/Content.hs b/Annex/Content.hs
index a17098ad7..c1d6031a7 100644
--- a/Annex/Content.hs
+++ b/Annex/Content.hs
@@ -509,10 +509,11 @@ populatePointerFile :: Key -> FilePath -> FilePath -> Annex ()
 populatePointerFile k obj f = go =<< liftIO (isPointerFile f)
   where
 	go (Just k') | k == k' = do
+		destmode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus f
 		liftIO $ nukeFile f
-		ifM (linkOrCopy k obj f)
+		ifM (linkOrCopy k obj f destmode)
 			( thawContent f
-			, liftIO $ writeFile f (formatPointer k)
+			, liftIO $ writePointerFile f k destmode
 			)
 	go _ = return ()
 
@@ -523,14 +524,14 @@ data LinkAnnexResult = LinkAnnexOk | LinkAnnexFailed | LinkAnnexNoop
 linkToAnnex :: Key -> FilePath -> Maybe InodeCache -> Annex LinkAnnexResult
 linkToAnnex key src srcic = do
 	dest <- calcRepo (gitAnnexLocation key)
-	modifyContent dest $ linkAnnex To key src srcic dest
+	modifyContent dest $ linkAnnex To key src srcic dest Nothing
 
 {- Makes a destination file be a link or copy from the annex object. -}
-linkFromAnnex :: Key -> FilePath -> Annex LinkAnnexResult
-linkFromAnnex key dest = do
+linkFromAnnex :: Key -> FilePath -> Maybe FileMode -> Annex LinkAnnexResult
+linkFromAnnex key dest destmode = do
 	src <- calcRepo (gitAnnexLocation key)
 	srcic <- withTSDelta (liftIO . genInodeCache src)
-	linkAnnex From key src srcic dest
+	linkAnnex From key src srcic dest destmode
 
 data FromTo = From | To
 
@@ -542,10 +543,12 @@ data FromTo = From | To
  - the annex object too. So, adding an object to the annex this
  - way can prevent losing the content if the source file
  - is deleted, but does not guard against modifications.
+ -
+ - Nothing is done if the destination file already exists.
  -}
-linkAnnex :: FromTo -> Key -> FilePath -> Maybe InodeCache -> FilePath -> Annex LinkAnnexResult
-linkAnnex _ _ _ Nothing _ = return LinkAnnexFailed
-linkAnnex fromto key src (Just srcic) dest = do
+linkAnnex :: FromTo -> Key -> FilePath -> Maybe InodeCache -> FilePath -> Maybe FileMode -> Annex LinkAnnexResult
+linkAnnex _ _ _ Nothing _ _ = return LinkAnnexFailed
+linkAnnex fromto key src (Just srcic) dest destmode = do
 	mdestic <- withTSDelta (liftIO . genInodeCache dest)
 	case mdestic of
 		Just destic -> do
@@ -554,7 +557,7 @@ linkAnnex fromto key src (Just srcic) dest = do
 				then Database.Keys.addInodeCaches key [srcic, destic]
 				else Database.Keys.addInodeCaches key [srcic]
 			return LinkAnnexNoop
-		Nothing -> ifM (linkOrCopy key src dest)
+		Nothing -> ifM (linkOrCopy key src dest destmode)
 			( do
 				thawContent $ case fromto of
 					From -> dest
@@ -578,27 +581,38 @@ linkAnnex fromto key src (Just srcic) dest = do
 				liftIO $ nukeFile dest
 				failed
 
-{- Hard links or copies src to dest. Only uses a hard link when annex.thin
- - is enabled and when src is not already hardlinked to elsewhere.
+{- Hard links or copies src to dest, which must not already exists.
+ -
+ - Only uses a hard link when annex.thin is enabled and when src is
+ - not already hardlinked to elsewhere.
+ -
  - Checks disk reserve before copying against the size of the key,
- - and will fail if not enough space, or if the dest file already exists. -}
-linkOrCopy :: Key -> FilePath -> FilePath -> Annex Bool
+ - and will fail if not enough space, or if the dest file already exists.
+ -
+ - The FileMode, if provided, influences the mode of the dest file.
+ - In particular, if it has an execute bit set, the dest file's
+ - execute bit will be set. The mode is not fully copied over because
+ - git doesn't support file modes beyond execute.
+ -}
+linkOrCopy :: Key -> FilePath -> FilePath -> Maybe FileMode -> Annex Bool
 linkOrCopy = linkOrCopy' (annexThin <$> Annex.getGitConfig)
 
-linkOrCopy' :: Annex Bool -> Key -> FilePath -> FilePath -> Annex Bool
-linkOrCopy' canhardlink key src dest = catchBoolIO $
-	ifM canhardlink
-		( hardlink
-		, copy =<< getstat
-		)
+linkOrCopy' :: Annex Bool -> Key -> FilePath -> FilePath -> Maybe FileMode -> Annex Bool
+linkOrCopy' canhardlink key src dest destmode
+	| maybe False isExecutable destmode = copy =<< getstat
+	| otherwise = catchBoolIO $
+		ifM canhardlink
+			( hardlink
+			, copy =<< getstat
+			)
   where
 	hardlink = do
 		s <- getstat
 		if linkCount s > 1
 			then copy s
-			else liftIO (createLink src dest >> return True)
+			else liftIO (createLink src dest >> preserveGitMode dest destmode >> return True)
 				`catchIO` const (copy s)
-	copy = checkedCopyFile' key src dest
+	copy = checkedCopyFile' key src dest destmode
 	getstat = liftIO $ getFileStatus src
 
 {- Removes the annex object file for a key. Lowlevel. -}
@@ -610,18 +624,30 @@ unlinkAnnex key = do
 		liftIO $ nukeFile obj
 
 {- Checks disk space before copying. -}
-checkedCopyFile :: Key -> FilePath -> FilePath -> Annex Bool
-checkedCopyFile key src dest = catchBoolIO $
-	checkedCopyFile' key src dest
+checkedCopyFile :: Key -> FilePath -> FilePath -> Maybe FileMode -> Annex Bool
+checkedCopyFile key src dest destmode = catchBoolIO $
+	checkedCopyFile' key src dest destmode
 		=<< liftIO (getFileStatus src)
 
-checkedCopyFile' :: Key -> FilePath -> FilePath -> FileStatus -> Annex Bool
-checkedCopyFile' key src dest s = catchBoolIO $
+checkedCopyFile' :: Key -> FilePath -> FilePath -> Maybe FileMode -> FileStatus -> Annex Bool
+checkedCopyFile' key src dest destmode s = catchBoolIO $
 	ifM (checkDiskSpace' (fromIntegral $ fileSize s) (Just $ takeDirectory dest) key 0 True)
-		( liftIO $ copyFileExternal CopyAllMetaData src dest
+		( liftIO $
+			copyFileExternal CopyAllMetaData src dest
+				<&&> preserveGitMode dest destmode
 		, return False
 		)
 
+preserveGitMode :: FilePath -> Maybe FileMode -> IO Bool
+preserveGitMode f (Just mode)
+	| isExecutable mode = catchBoolIO $ do
+		modifyFileMode f $ addModes executeModes
+		return True
+	| otherwise = catchBoolIO $ do
+		modifyFileMode f $ removeModes executeModes
+		return True
+preserveGitMode _ _ = return True
+
 {- Runs an action to transfer an object's content.
  -
  - In some cases, it's possible for the file to change as it's being sent.
@@ -729,9 +755,10 @@ removeAnnex (ContentRemovalLock key) = withObjectLoc key remove removedirect
 		Direct.removeInodeCache key
 	resetpointer file = ifM (isUnmodified key file)
 		( do
+			mode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus file
 			secureErase file
 			liftIO $ nukeFile file
-			liftIO $ writeFile file (formatPointer key)	
+			liftIO $ writePointerFile file key mode
 		-- Can't delete the pointer file.
 		-- If it was a hard link to the annex object,
 		-- that object might have been frozen as part of the
diff --git a/Annex/Ingest.hs b/Annex/Ingest.hs
index 1bf1db146..95bbff496 100644
--- a/Annex/Ingest.hs
+++ b/Annex/Ingest.hs
@@ -130,7 +130,9 @@ ingestAdd ld@(Just (LockedDown cfg source)) = do
 					( do
 						l <- calcRepo $ gitAnnexLink f k
 						stageSymlink f =<< hashSymlink l
-					, stagePointerFile f =<< hashPointerFile k
+					, do
+						mode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus (contentLocation source)
+						stagePointerFile f mode =<< hashPointerFile k
 					)
 			return (Just k)
 
@@ -344,15 +346,19 @@ cachedCurrentBranch = maybe cache (return . Just)
 addAnnexedFile :: FilePath -> Key -> Maybe FilePath -> Annex ()
 addAnnexedFile file key mtmp = ifM (addUnlocked <&&> not <$> isDirect)
 	( do
-		stagePointerFile file =<< hashPointerFile key
+		mode <- maybe
+			(pure Nothing)
+			(\tmp -> liftIO $ catchMaybeIO $ fileMode <$> getFileStatus tmp)
+			mtmp
+		stagePointerFile file mode =<< hashPointerFile key
 		Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath file)
 		case mtmp of
 			Just tmp -> do
 				moveAnnex key tmp
-				linkunlocked
+				linkunlocked mode
 			Nothing -> ifM (inAnnex key)
-				( linkunlocked
-				, writepointer
+				( linkunlocked mode
+				, liftIO $ writePointerFile file key mode
 				)
 	, do
 		addLink file key Nothing
@@ -368,9 +374,9 @@ addAnnexedFile file key mtmp = ifM (addUnlocked <&&> not <$> isDirect)
 			Nothing -> return ()
 	)
   where
-	writepointer = liftIO $ writeFile file (formatPointer key)
-	linkunlocked = do
-		r <- linkFromAnnex key file
+	linkunlocked mode = do
+		r <- linkFromAnnex key file mode
 		case r of
-			LinkAnnexFailed -> writepointer
+			LinkAnnexFailed -> liftIO $
+				writePointerFile file key mode
 			_ -> return ()
diff --git a/Annex/Link.hs b/Annex/Link.hs
index 44c567837..af20ae30d 100644
--- a/Annex/Link.hs
+++ b/Annex/Link.hs
@@ -23,6 +23,7 @@ import qualified Annex.Queue
 import Git.Types
 import Git.FilePath
 import Annex.HashObject
+import Utility.FileMode
 
 import qualified Data.ByteString.Lazy as L
 import Data.Int
@@ -118,10 +119,19 @@ hashPointerFile :: Key -> Annex Sha
 hashPointerFile key = hashBlob (formatPointer key)
 
 {- Stages a pointer file, using a Sha of its content -}
-stagePointerFile :: FilePath -> Sha -> Annex ()
-stagePointerFile file sha =
+stagePointerFile :: FilePath -> Maybe FileMode -> Sha -> Annex ()
+stagePointerFile file mode sha =
 	Annex.Queue.addUpdateIndex =<<
-		inRepo (Git.UpdateIndex.stageFile sha FileBlob file)
+		inRepo (Git.UpdateIndex.stageFile sha blobtype file)
+  where
+	blobtype
+		| maybe False isExecutable mode = ExecutableBlob
+		| otherwise = FileBlob
+
+writePointerFile :: FilePath -> Key -> Maybe FileMode -> IO ()
+writePointerFile file k mode = do
+	writeFile file (formatPointer k)
+	maybe noop (setFileMode file) mode
 
 {- Parses a symlink target or a pointer file to a Key.
  - Only looks at the first line, as pointer files can have subsequent