other 80% of avoding verification when hard linking to objects in shared repo

In c3b38fb2a075b4250e867ebd910324c65712c747, it actually only handled
uploading objects to a shared repository. To avoid verification when
downloading objects from a shared repository, was a lot harder.

On the plus side, if the process of downloading a file from a remote
is able to verify its content on the side, the remote can indicate this
now, and avoid the extra post-download verification.

As of yet, I don't have any remotes (except Git) using this ability.
Some more work would be needed to support it in special remotes.

It would make sense for tahoe to implicitly verify things downloaded from it;
as long as you trust your tahoe server (which typically runs locally),
there's cryptographic integrity. OTOH, despite bup being based on shas,
a bup repo under an attacker's control could have the git ref used for an
object changed, and so a bup repo shouldn't implicitly verify. Indeed,
tahoe seems unique in being trustworthy enough to implicitly verify.

2 files changed, 37 insertions, 24 deletions

diff --git a/Annex/Content.hs b/Annex/Content.hs
index 266cb9ac1..5032e2691 100644
--- a/Annex/Content.hs
+++ b/Annex/Content.hs
@@ -16,7 +16,8 @@ module Annex.Content (
 	getViaTmp,
 	getViaTmp',
 	checkDiskSpaceToGet,
-	Verify(..),
+	VerifyConfig(..),
+	Types.Remote.unVerified,
 	prepTmp,
 	withTmp,
 	checkDiskSpace,
@@ -218,18 +219,19 @@ lockContent key a = do
 {- Runs an action, passing it the temp file to get,
  - and if the action succeeds, verifies the file matches
  - the key and moves the file into the annex as a key's content. -}
-getViaTmp :: Verify -> Key -> (FilePath -> Annex Bool) -> Annex Bool
+getViaTmp :: VerifyConfig -> Key -> (FilePath -> Annex (Bool, Types.Remote.Verification)) -> Annex Bool
 getViaTmp v key action = checkDiskSpaceToGet key False $
 	getViaTmp' v key action
 
 {- Like getViaTmp, but does not check that there is enough disk space
  - for the incoming key. For use when the key content is already on disk
  - and not being copied into place. -}
-getViaTmp' :: Verify -> Key -> (FilePath -> Annex Bool) -> Annex Bool
+getViaTmp' :: VerifyConfig -> Key -> (FilePath -> Annex (Bool, Types.Remote.Verification)) -> Annex Bool
 getViaTmp' v key action = do
 	tmpfile <- prepTmp key
-	ifM (action tmpfile)
-		( ifM (verifyKeyContent v key tmpfile)
+	(ok, verification) <- action tmpfile
+	if ok
+		then ifM (verifyKeyContent v verification key tmpfile)
 			( do
 				moveAnnex key tmpfile
 				logStatus key InfoPresent
@@ -241,8 +243,7 @@ getViaTmp' v key action = do
 			)
 		-- On transfer failure, the tmp file is left behind, in case
 		-- caller wants to resume its transfer
-		, return False
-		)
+		else return False
 
 {- Verifies that a file is the expected content of a key.
  - Configuration can prevent verification, for either a
@@ -253,8 +254,9 @@ getViaTmp' v key action = do
  - When the key's backend allows verifying the content (eg via checksum),
  - it is checked. 
  -}
-verifyKeyContent :: Verify -> Key -> FilePath -> Annex Bool
-verifyKeyContent v k f = ifM (shouldVerify v)
+verifyKeyContent :: VerifyConfig -> Types.Remote.Verification -> Key -> FilePath -> Annex Bool
+verifyKeyContent _ Types.Remote.Verified _ _ = return True
+verifyKeyContent v Types.Remote.UnVerified k f = ifM (shouldVerify v)
 	( verifysize <&&> verifycontent
 	, return True
 	)
@@ -268,9 +270,9 @@ verifyKeyContent v k f = ifM (shouldVerify v)
 		Nothing -> return True
 		Just verifier -> verifier k f
 
-data Verify = AlwaysVerify | NoVerify | RemoteVerify Remote | DefaultVerify
+data VerifyConfig = AlwaysVerify | NoVerify | RemoteVerify Remote | DefaultVerify
 
-shouldVerify :: Verify -> Annex Bool
+shouldVerify :: VerifyConfig -> Annex Bool
 shouldVerify AlwaysVerify = return True
 shouldVerify NoVerify = return False
 shouldVerify DefaultVerify = annexVerify <$> Annex.getGitConfig
diff --git a/Annex/Transfer.hs b/Annex/Transfer.hs
index a2bac34be..e72f737ea 100644
--- a/Annex/Transfer.hs
+++ b/Annex/Transfer.hs
@@ -5,7 +5,7 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, FlexibleInstances #-}
 
 module Annex.Transfer (
 	module X,
@@ -24,20 +24,31 @@ import Annex.Notification as X
 import Annex.Perms
 import Utility.Metered
 import Utility.LockPool
+import Types.Remote (Verification(..))
 
 import Control.Concurrent
 
-type TransferAction = MeterUpdate -> Annex Bool
-
 type TransferObserver = Bool -> Transfer -> TransferInfo -> Annex ()
 
+class Observable a where
+	observeBool :: a -> Bool
+	observeFailure :: a
+
+instance Observable Bool where
+	observeBool = id
+	observeFailure = False
+
+instance Observable (Bool, Verification) where
+	observeBool = fst
+	observeFailure = (False, UnVerified)
+
 noObserver :: TransferObserver
 noObserver _ _ _ = noop
 
-upload :: UUID -> Key -> AssociatedFile -> RetryDecider -> TransferObserver -> TransferAction -> NotifyWitness -> Annex Bool
+upload :: Observable v => UUID -> Key -> AssociatedFile -> RetryDecider -> TransferObserver -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v
 upload u key f d o a _witness = runTransfer (Transfer Upload u key) f d o a
 
-download :: UUID -> Key -> AssociatedFile -> RetryDecider -> TransferObserver -> TransferAction -> NotifyWitness -> Annex Bool
+download :: Observable v => UUID -> Key -> AssociatedFile -> RetryDecider -> TransferObserver -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v
 download u key f d o a _witness = runTransfer (Transfer Download u key) f d o a
 
 {- Runs a transfer action. Creates and locks the lock file while the
@@ -52,7 +63,7 @@ download u key f d o a _witness = runTransfer (Transfer Download u key) f d o a
  - An upload can be run from a read-only filesystem, and in this case
  - no transfer information or lock file is used.
  -}
-runTransfer :: Transfer -> Maybe FilePath -> RetryDecider -> TransferObserver -> TransferAction -> Annex Bool
+runTransfer :: Observable v => Transfer -> Maybe FilePath -> RetryDecider -> TransferObserver -> (MeterUpdate -> Annex v) -> Annex v
 runTransfer = runTransfer' False
 
 {- Like runTransfer, but ignores any existing transfer lock file for the
@@ -60,10 +71,10 @@ runTransfer = runTransfer' False
  -
  - Note that this may result in confusing progress meter display in the
  - webapp, if multiple processes are writing to the transfer info file. -}
-alwaysRunTransfer :: Transfer -> Maybe FilePath -> RetryDecider -> TransferObserver -> TransferAction -> Annex Bool
+alwaysRunTransfer :: Observable v => Transfer -> Maybe FilePath -> RetryDecider -> TransferObserver -> (MeterUpdate -> Annex v) -> Annex v
 alwaysRunTransfer = runTransfer' True
 
-runTransfer' :: Bool -> Transfer -> Maybe FilePath -> RetryDecider -> TransferObserver -> TransferAction -> Annex Bool
+runTransfer' :: Observable v => Bool -> Transfer -> Maybe FilePath -> RetryDecider -> TransferObserver -> (MeterUpdate -> Annex v) -> Annex v
 runTransfer' ignorelock t file shouldretry transferobserver transferaction = do
 	info <- liftIO $ startTransferInfo file
 	(meter, tfile, metervar) <- mkProgressUpdater t info
@@ -72,12 +83,12 @@ runTransfer' ignorelock t file shouldretry transferobserver transferaction = do
 	if inprogress && not ignorelock
 		then do
 			showNote "transfer already in progress, or unable to take transfer lock"
-			return False
+			return observeFailure
 		else do
-			ok <- retry info metervar $ transferaction meter
+			v <- retry info metervar $ transferaction meter
 			liftIO $ cleanup tfile lck
-			transferobserver ok t info
-			return ok
+			transferobserver (observeBool v) t info
+			return v
   where
 #ifndef mingw32_HOST_OS
 	prep tfile mode info = do
@@ -128,7 +139,7 @@ runTransfer' ignorelock t file shouldretry transferobserver transferaction = do
 				let newinfo = oldinfo { bytesComplete = Just b }
 				if shouldretry oldinfo newinfo
 					then retry newinfo metervar run
-					else return False
+					else return observeFailure
 	getbytescomplete metervar
 		| transferDirection t == Upload =
 			liftIO $ readMVar metervar