annex.securehashesonly

Cryptographically secure hashes can be forced to be used in a repository,
by setting annex.securehashesonly. This does not prevent the git repository
from containing files with insecure hashes, but it does prevent the content
of such files from being pulled into .git/annex/objects from another
repository.

We want to make sure that at no point does git-annex accept content into
.git/annex/objects that is hashed with an insecure key. Here's how it
was done:

* .git/annex/objects/xx/yy/KEY/ is kept frozen, so nothing can be
  written to it normally
* So every place that writes content must call, thawContent or modifyContent.
  We can audit for these, and be sure we've considered all cases.
* The main functions are moveAnnex, and linkToAnnex; these were made to
  check annex.securehashesonly, and are the main security boundary
  for annex.securehashesonly.
* Most other calls to modifyContent deal with other files in the KEY
  directory (inode cache etc). The other ones that mess with the content
  are:
	- Annex.Direct.toDirectGen, in which content already in the
	  annex directory is moved to the direct mode file, so not relevant.
	- fix and lock, which don't add new content
	- Command.ReKey.linkKey, which manually unlocks it to make a
	  copy.
* All other calls to thawContent appear safe.

Made moveAnnex return a Bool, so checked all callsites and made them
deal with a failure in appropriate ways.

linkToAnnex simply returns LinkAnnexFailed; all callsites already deal
with it failing in appropriate ways.

This commit was sponsored by Riku Voipio.

3 files changed, 59 insertions, 26 deletions

diff --git a/Annex/Content.hs b/Annex/Content.hs
index 8e225548f..0001e8ac9 100644
--- a/Annex/Content.hs
+++ b/Annex/Content.hs
@@ -1,6 +1,6 @@
 {- git-annex file content managing
  -
- - Copyright 2010-2015 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2017 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -80,6 +80,7 @@ import qualified Types.Backend
 import qualified Backend
 import qualified Database.Keys
 import Types.NumCopies
+import Types.Key
 import Annex.UUID
 import Annex.InodeSentinal
 import Utility.InodeCache
@@ -307,10 +308,12 @@ getViaTmp' v key action = do
 	(ok, verification) <- action tmpfile
 	if ok
 		then ifM (verifyKeyContent v verification key tmpfile)
-			( do
-				moveAnnex key tmpfile
-				logStatus key InfoPresent
-				return True
+			( ifM (moveAnnex key tmpfile)
+				( do
+					logStatus key InfoPresent
+					return True
+				, return False
+				)
 			, do
 				warning "verification of content failed"
 				liftIO $ nukeFile tmpfile
@@ -465,9 +468,18 @@ checkDiskSpace' need destdir key alreadythere samefilesystem = ifM (Annex.getSta
  - key, and one of them will probably get deleted later. So, adding the
  - check here would only raise expectations that git-annex cannot truely
  - meet.
+ -
+ - May return false, when a particular variety of key is not being
+ - accepted into the repository. Will display a warning message in this
+ - case. May also throw exceptions in some cases.
  -}
-moveAnnex :: Key -> FilePath -> Annex ()
-moveAnnex key src = withObjectLoc key storeobject storedirect
+moveAnnex :: Key -> FilePath -> Annex Bool
+moveAnnex key src = ifM (checkSecureHashes key)
+	( do
+		withObjectLoc key storeobject storedirect
+		return True
+	, return False
+	)
   where
 	storeobject dest = ifM (liftIO $ doesFileExist dest)
 		( alreadyhave
@@ -509,6 +521,16 @@ moveAnnex key src = withObjectLoc key storeobject storedirect
 	
 	alreadyhave = liftIO $ removeFile src
 
+checkSecureHashes :: Key -> Annex Bool
+checkSecureHashes key
+	| cryptographicallySecure (keyVariety key) = return True
+	| otherwise = ifM (annexSecureHashesOnly <$> Annex.getGitConfig)
+		( do
+			warning $ "annex.securehashesonly blocked adding " ++ formatKeyVariety (keyVariety key) ++ " key to annex objects"
+			return False
+		, return True
+		)
+
 populatePointerFile :: Key -> FilePath -> FilePath -> Annex ()
 populatePointerFile k obj f = go =<< liftIO (isPointerFile f)
   where
@@ -526,9 +548,12 @@ data LinkAnnexResult = LinkAnnexOk | LinkAnnexFailed | LinkAnnexNoop
 {- Populates the annex object file by hard linking or copying a source
  - file to it. -}
 linkToAnnex :: Key -> FilePath -> Maybe InodeCache -> Annex LinkAnnexResult
-linkToAnnex key src srcic = do
-	dest <- calcRepo (gitAnnexLocation key)
-	modifyContent dest $ linkAnnex To key src srcic dest Nothing
+linkToAnnex key src srcic = ifM (checkSecureHashes key)
+	( do
+		dest <- calcRepo (gitAnnexLocation key)
+		modifyContent dest $ linkAnnex To key src srcic dest Nothing
+	, return LinkAnnexFailed
+	)
 
 {- Makes a destination file be a link or copy from the annex object. -}
 linkFromAnnex :: Key -> FilePath -> Maybe FileMode -> Annex LinkAnnexResult
diff --git a/Annex/Direct.hs b/Annex/Direct.hs
index e5c1c47c8..08a15e180 100644
--- a/Annex/Direct.hs
+++ b/Annex/Direct.hs
@@ -383,10 +383,10 @@ removeDirect :: Key -> FilePath -> Annex ()
 removeDirect k f = do
 	void $ removeAssociatedFileUnchecked k f
 	unlessM (inAnnex k) $
-		ifM (goodContent k f)
-			( moveAnnex k f
-			, logStatus k InfoMissing
-			)
+		-- If moveAnnex rejects the content of the key,
+		-- treat that the same as its content having changed.
+		whenM (goodContent k f <&&> moveAnnex k f) $
+			logStatus k InfoMissing
 	liftIO $ do
 		nukeFile f
 		void $ tryIO $ removeDirectory $ parentDir f
diff --git a/Annex/Ingest.hs b/Annex/Ingest.hs
index 5f6e38ff2..4dabb1b58 100644
--- a/Annex/Ingest.hs
+++ b/Annex/Ingest.hs
@@ -172,10 +172,13 @@ ingest' preferredbackend (Just (LockedDown cfg source)) mk = withTSDelta $ \delt
 	go _ _ _ = failure "failed to generate a key"
 
 	golocked key mcache s = do
-		catchNonAsync (moveAnnex key $ contentLocation source)
-			(restoreFile (keyFilename source) key)
-		populateAssociatedFiles key source
-		success key mcache s
+		v <- tryNonAsync (moveAnnex key $ contentLocation source)
+		case v of
+			Right True -> do
+				populateAssociatedFiles key source
+				success key mcache s		
+			Right False -> giveup "failed to add content to annex"
+			Left e -> restoreFile (keyFilename source) key e
 
 	gounlocked key (Just cache) s = do
 		-- Remove temp directory hard link first because
@@ -352,8 +355,11 @@ cachedCurrentBranch = maybe cache (return . Just)
 
 {- Adds a file to the work tree for the key, and stages it in the index.
  - The content of the key may be provided in a temp file, which will be
- - moved into place. -}
-addAnnexedFile :: FilePath -> Key -> Maybe FilePath -> Annex ()
+ - moved into place.
+ -
+ - When the content of the key is not accepted into the annex, returns False.
+ -}
+addAnnexedFile :: FilePath -> Key -> Maybe FilePath -> Annex Bool
 addAnnexedFile file key mtmp = ifM (addUnlocked <&&> not <$> isDirect)
 	( do
 		mode <- maybe
@@ -363,12 +369,13 @@ addAnnexedFile file key mtmp = ifM (addUnlocked <&&> not <$> isDirect)
 		stagePointerFile file mode =<< hashPointerFile key
 		Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath file)
 		case mtmp of
-			Just tmp -> do
-				moveAnnex key tmp
-				linkunlocked mode
+			Just tmp -> ifM (moveAnnex key tmp)
+				( linkunlocked mode >> return True
+				, writepointer mode >> return False
+				)
 			Nothing -> ifM (inAnnex key)
-				( linkunlocked mode
-				, liftIO $ writePointerFile file key mode
+				( linkunlocked mode >> return True
+				, writepointer mode >> return True
 				)
 	, do
 		addLink file key Nothing
@@ -381,7 +388,7 @@ addAnnexedFile file key mtmp = ifM (addUnlocked <&&> not <$> isDirect)
 				whenM isDirect $
 					Annex.Queue.flush
 				moveAnnex key tmp
-			Nothing -> return ()
+			Nothing -> return True
 	)
   where
 	linkunlocked mode = do
@@ -390,3 +397,4 @@ addAnnexedFile file key mtmp = ifM (addUnlocked <&&> not <$> isDirect)
 			LinkAnnexFailed -> liftIO $
 				writePointerFile file key mode
 			_ -> return ()
+	writepointer mode = liftIO $ writePointerFile file key mode