early cancelation of transfer that annex.securehashesonly prohibits

This avoids sending all the data to a remote, only to have it reject it
because it has annex.securehashesonly set. It assumes that local and
remote will have the same annex.securehashesonly setting in most cases.
If a remote does not have that set, and local does, the remote won't get
some content it would otherwise accept.

Also avoids downloading data that will not be added to the local object
store due to annex.securehashesonly.

Note that, while encrypted special remotes use a GPGHMAC key variety,
which is not collisiton resistent, Transfers are not used for such
keys, so this check is avoided. Which is what we want, so encrypted
special remotes still work.

This commit was sponsored by Ewen McNeill.

1 files changed, 27 insertions, 2 deletions

diff --git a/Annex/Transfer.hs b/Annex/Transfer.hs
index b33dace4a..d6282cbf3 100644
--- a/Annex/Transfer.hs
+++ b/Annex/Transfer.hs
@@ -1,6 +1,6 @@
 {- git-annex transfers
  -
- - Copyright 2012-2016 Joey Hess <id@joeyh.name>
+ - Copyright 2012-2017 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -26,6 +26,7 @@ import Annex.Notification as X
 import Annex.Perms
 import Utility.Metered
 import Annex.LockPool
+import Types.Key
 import Types.Remote (Verification(..))
 import qualified Types.Remote as Remote
 import Types.Concurrency
@@ -87,7 +88,7 @@ alwaysRunTransfer :: Observable v => Transfer -> Maybe FilePath -> RetryDecider
 alwaysRunTransfer = runTransfer' True
 
 runTransfer' :: Observable v => Bool -> Transfer -> Maybe FilePath -> RetryDecider -> (MeterUpdate -> Annex v) -> Annex v
-runTransfer' ignorelock t file shouldretry transferaction = do
+runTransfer' ignorelock t file shouldretry transferaction = checkSecureHashes t $ do
 	info <- liftIO $ startTransferInfo file
 	(meter, tfile, metervar) <- mkProgressUpdater t info
 	mode <- annexFileMode
@@ -167,6 +168,30 @@ runTransfer' ignorelock t file shouldretry transferaction = do
 			f <- fromRepo $ gitAnnexTmpObjectLocation (transferKey t)
 			liftIO $ catchDefaultIO 0 $ getFileSize f
 
+{- Avoid download and upload of keys with insecure content when
+ - annex.securehashesonly is configured.
+ -
+ - This is not a security check. Even if this let the content be
+ - downloaded, the actual security checks would prevent the content from
+ - being added to the repository. The only reason this is done here is to
+ - avoid transferring content that's going to be rejected anyway.
+ -
+ - We assume that, if annex.securehashesonly is set and the local repo
+ - still contains content using an insecure hash, remotes will likewise
+ - tend to be configured to reject it, so Upload is also prevented.
+ -}
+checkSecureHashes :: Observable v => Transfer -> Annex v -> Annex v
+checkSecureHashes t a
+	| cryptographicallySecure variety = a
+	| otherwise = ifM (annexSecureHashesOnly <$> Annex.getGitConfig)
+		( do
+			warning $ "annex.securehashesonly blocked transfer of " ++ formatKeyVariety variety ++ " key"
+			return observeFailure
+		, a
+		)
+  where
+	variety = keyVariety (transferKey t)
+
 type RetryDecider = TransferInfo -> TransferInfo -> Bool
 
 noRetry :: RetryDecider