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.

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

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

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

CHANGELOG

@@ -1,5 +1,10 @@
 git-annex (6.20170215) UNRELEASED; urgency=medium
 
+  * 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 added to .git/annex/objects.
   * sync, merge: Fail when the current branch has no commits yet, instead
     of not merging in anything from remotes and appearing to succeed.
   * Run ssh with -n whenever input is not being piped into it,

Command/AddUrl.hs

@@ -356,10 +356,13 @@ cleanup u url file key mtmp = case mtmp of
   where
 	go = do
 		maybeShowJSON $ JSONChunk [("key", key2file key)]
-		when (isJust mtmp) $
-			logStatus key InfoPresent
 		setUrlPresent u key url
-		addAnnexedFile file key mtmp
+		ifM (addAnnexedFile file key mtmp)
+			( do
+				when (isJust mtmp) $
+					logStatus key InfoPresent
+			, liftIO $ maybe noop nukeFile mtmp
+			)
 
 nodownload :: URLString -> Url.UrlInfo -> FilePath -> Annex (Maybe Key)
 nodownload url urlinfo file

Command/Indirect.hs

@@ -86,16 +86,16 @@ perform = do
 		whenM (liftIO $ not . isSymbolicLink <$> getSymbolicLinkStatus f) $ do
 			v <- tryNonAsync (moveAnnex k f)
 			case v of
-				Right _ -> do 
+				Right True -> do 
 					l <- calcRepo $ gitAnnexLink f k
 					liftIO $ createSymbolicLink l f
-				Left e -> catchNonAsync (restoreFile f k e)
-					warnlocked
+				Right False -> warnlocked "Failed to move file to annex"
+				Left e -> catchNonAsync (restoreFile f k e) $
+					warnlocked . show
 		showEndOk
 
-	warnlocked :: SomeException -> Annex ()
-	warnlocked e = do
-		warning $ show e
+	warnlocked msg = do
+		warning msg
 		warning "leaving this file as-is; correct this problem and run git annex add on it"
 	
 cleanup :: CommandCleanup

Command/Reinject.hs

@@ -74,9 +74,8 @@ perform src key = ifM move
 	, error "failed"
 	)
   where
-	move = checkDiskSpaceToGet key False $ do
+	move = checkDiskSpaceToGet key False $
 		moveAnnex key src
-		return True
 
 cleanup :: Key -> CommandCleanup
 cleanup key = do

Types/GitConfig.hs

@@ -82,6 +82,7 @@ data GitConfig = GitConfig
 	, annexPidLock :: Bool
 	, annexPidLockTimeout :: Seconds
 	, annexAddUnlocked :: Bool
+	, annexSecureHashesOnly :: Bool
 	, coreSymlinks :: Bool
 	, coreSharedRepository :: SharedRepository
 	, receiveDenyCurrentBranch :: DenyCurrentBranch
@@ -136,6 +137,7 @@ extractGitConfig r = GitConfig
 	, annexPidLockTimeout = Seconds $ fromMaybe 300 $
 		getmayberead (annex "pidlocktimeout")
 	, annexAddUnlocked = getbool (annex "addunlocked") False
+	, annexSecureHashesOnly = getbool (annex "securehashesonly") False
 	, coreSymlinks = getbool "core.symlinks" True
 	, coreSharedRepository = getSharedRepository r
 	, receiveDenyCurrentBranch = getDenyCurrentBranch r