Merge branch 'master' into v8

Command/Add.hs

@@ -1,6 +1,6 @@
 {- git-annex command
  -
- - Copyright 2010-2019 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2020 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
@@ -17,9 +17,13 @@ import qualified Database.Keys
 import Annex.FileMatcher
 import Annex.Link
 import Annex.Tmp
+import Annex.HashObject
 import Messages.Progress
+import Git.Types
 import Git.FilePath
 import Config.GitConfig
+import qualified Git.UpdateIndex
+import Utility.FileMode
 import qualified Utility.RawFilePath as R
 
 cmd :: Command
@@ -32,6 +36,7 @@ data AddOptions = AddOptions
 	{ addThese :: CmdParams
 	, batchOption :: BatchMode
 	, updateOnly :: Bool
+	, largeFilesOverride :: Maybe Bool
 	}
 
 optParser :: CmdParamsDesc -> Parser AddOptions
@@ -43,21 +48,34 @@ optParser desc = AddOptions
 		<> short 'u'
 		<> help "only update tracked files"
 		)
+	<*> (parseforcelarge <|> parseforcesmall)
+  where
+	parseforcelarge = flag Nothing (Just True)
+		( long "force-large"
+		<> help "add all files to annex, ignoring other configuration"
+		)
+	parseforcesmall = flag Nothing (Just False)
+		( long "force-small"
+		<> help "add all files to git, ignoring other configuration"
+		)
 
 seek :: AddOptions -> CommandSeek
 seek o = startConcurrency commandStages $ do
 	largematcher <- largeFilesMatcher
 	addunlockedmatcher <- addUnlockedMatcher
 	annexdotfiles <- getGitConfigVal annexDotFiles 
-	let gofile file =
-		let file' = fromRawFilePath file
-		in ifM (pure (annexdotfiles || not (dotfile file')) <&&> (checkFileMatcher largematcher file' <||> Annex.getState Annex.force))
-			( start file addunlockedmatcher
-			, ifM (annexAddSmallFiles <$> Annex.getGitConfig)
-				( startSmall file
-				, stop
+	let gofile file = case largeFilesOverride o of
+		Nothing -> 
+			let file' = fromRawFilePath file
+			in ifM (pure (annexdotfiles || not (dotfile file')) <&&> (checkFileMatcher largematcher file' <||> Annex.getState Annex.force))
+				( start file addunlockedmatcher
+				, ifM (annexAddSmallFiles <$> Annex.getGitConfig)
+					( startSmall file
+					, stop
+					)
 				)
-			)
+		Just True -> start file addunlockedmatcher
+		Just False -> startSmallOverridden file
 	case batchOption o of
 		Batch fmt
 			| updateOnly o ->
@@ -81,6 +99,29 @@ addSmall file = do
 	showNote "non-large file; adding content to git repository"
 	addFile file
 
+startSmallOverridden :: RawFilePath -> CommandStart
+startSmallOverridden file = starting "add" (ActionItemWorkTreeFile file) $
+	next $ addSmallOverridden file
+
+addSmallOverridden :: RawFilePath -> Annex Bool
+addSmallOverridden file = do
+	showNote "adding content to git repository"
+	let file' = fromRawFilePath file
+	s <- liftIO $ getFileStatus file'
+	if isSymbolicLink s
+		then addFile file 
+		else do
+			-- Can't use addFile because the clean filter will
+			-- honor annex.largefiles and it has been overridden.
+			-- Instead, hash the file and add to the index.
+			sha <- hashFile file'
+			let ty = if isExecutable (fileMode s)
+				then TreeExecutable
+				else TreeFile
+			Annex.Queue.addUpdateIndex =<<
+				inRepo (Git.UpdateIndex.stageFile sha ty file')
+			return True
+
 addFile :: RawFilePath -> Annex Bool
 addFile file = do
 	ps <- forceParams

Command/Smudge.hs

@@ -18,7 +18,10 @@ import Logs.Location
 import qualified Database.Keys
 import qualified Git.BuildVersion
 import Git.FilePath
+import Git.Types
+import Git.HashObject
 import qualified Git
+import qualified Git.Ref
 import qualified Annex
 import Backend
 import Utility.Metered
@@ -89,11 +92,14 @@ clean file = do
 			Just k -> do
 				getMoveRaceRecovery k (toRawFilePath file)
 				liftIO $ L.hPut stdout b
-			Nothing -> go b =<< catKeyFile (toRawFilePath file)
+			Nothing -> do
+				let fileref = Git.Ref.fileRef (toRawFilePath file)
+				indexmeta <- catObjectMetaData fileref
+				go b indexmeta =<< catKey' fileref indexmeta
 		)
 	stop
   where
-	go b oldkey = ifM (shouldAnnex file oldkey)
+	go b indexmeta oldkey = ifM (shouldAnnex file indexmeta oldkey)
 		( do
 			-- Before git 2.5, failing to consume all stdin here
 			-- would cause a SIGPIPE and crash it.
@@ -154,17 +160,17 @@ clean file = do
 -- added to the annex, so will be added to git. But some heuristics
 -- are used to avoid bad behavior:
 --
--- If the index already contains the file, preserve its annexed/not annexed
--- state. This prevents accidental conversions.
+-- If the file is annexed in the index, keep it annexed.
+-- This prevents accidental conversions.
 --
 -- Otherwise, when the file's inode is the same as one that was used for
 -- annexed content before, annex it. This handles cases such as renaming an
 -- unlocked annexed file followed by git add, which the user naturally
 -- expects to behave the same as git mv.
-shouldAnnex :: FilePath -> Maybe Key -> Annex Bool
-shouldAnnex file moldkey = ifM (annexGitAddToAnnex <$> Annex.getGitConfig)
-	( checkmatcher checkheuristics
-	, checkheuristics
+shouldAnnex :: FilePath -> Maybe (Sha, FileSize, ObjectType) -> Maybe Key -> Annex Bool
+shouldAnnex file indexmeta moldkey = ifM (annexGitAddToAnnex <$> Annex.getGitConfig)
+	( checkunchangedgitfile $ checkmatcher checkheuristics
+	, checkunchangedgitfile checkheuristics
 	)
   where
 	checkmatcher d
@@ -186,6 +192,31 @@ shouldAnnex file moldkey = ifM (annexGitAddToAnnex <$> Annex.getGitConfig)
 		Nothing -> pure False
 		Just ic -> Database.Keys.isInodeKnown ic =<< sentinalStatus
 
+	-- This checks for a case where the file had been added to git
+	-- previously, not to the annex before, and its content is not
+	-- changed, but git is running the clean filter again on it
+	-- (eg because its mtime or inode changed, or just because git feels
+	-- like it). Such a file should not be added to the annex, even if
+	-- annex.largefiles now matches it, because the content is not
+	-- changed.
+	checkunchangedgitfile cont = case (moldkey, indexmeta) of
+		(Nothing, Just (sha, sz, _)) -> liftIO (catchMaybeIO (getFileSize file)) >>= \case
+			Just sz' | sz' == sz -> do
+				-- The size is the same, so the file
+				-- is not much larger than what was stored
+				-- in git before, so it won't be out of
+				-- line to hash it. However, the content
+				-- is prevented from being stored in git
+				-- when hashing.
+				h <- inRepo $ hashObjectStart False
+				sha' <- liftIO $ hashFile h file
+				liftIO $ hashObjectStop h
+				if sha' == sha
+					then return False
+					else cont
+			_ -> cont
+		_ -> cont
+
 emitPointer :: Key -> IO ()
 emitPointer = S.putStr . formatPointer