plumb VerifyConfig into retrieveKeyFile

This fixes the recent reversion that annex.verify is not honored,
because retrieveChunks was passed RemoteVerify baser, but baser
did not have export/import set up.

Sponsored-by: Dartmouth College's DANDI project

Annex/Content.hs

@@ -53,7 +53,8 @@ module Annex.Content (
 	isUnmodifiedCheap,
 	verifyKeyContentPostRetrieval,
 	verifyKeyContent,
-	VerifyConfig(..),
+	VerifyConfig,
+	VerifyConfigA(..),
 	Verification(..),
 	unVerified,
 	withTmpWorkDir,
@@ -83,7 +84,7 @@ import Annex.InodeSentinal
 import Annex.ReplaceFile
 import Annex.AdjustedBranch (adjustedBranchRefresh)
 import Messages.Progress
-import Types.Remote (RetrievalSecurityPolicy(..))
+import Types.Remote (RetrievalSecurityPolicy(..), VerifyConfigA(..))
 import Types.NumCopies
 import Types.Key
 import Types.Transfer

Annex/Transfer.hs

@@ -78,10 +78,11 @@ download r key f d witness = logStatusAfter key $ stallDetection r >>= \case
 	Just StallDetectionDisabled -> go Nothing
 	Just sd -> runTransferrer sd r key f d Download witness
   where
-	go sd = getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) key f $ \dest ->
+	go sd = getViaTmp (Remote.retrievalSecurityPolicy r) vc key f $ \dest ->
 		download' (Remote.uuid r) key f sd d (go' dest) witness
 	go' dest p = verifiedAction $
-		Remote.retrieveKeyFile r key f (fromRawFilePath dest) p
+		Remote.retrieveKeyFile r key f (fromRawFilePath dest) p vc
+	vc = Remote.RemoteVerify r
 
 -- Download, not supporting canceling detected stalls.
 download' :: Observable v => UUID -> Key -> AssociatedFile -> Maybe StallDetection -> RetryDecider -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v

Annex/Verify.hs

@@ -8,7 +8,6 @@
 {-# LANGUAGE CPP #-}
 
 module Annex.Verify (
-	VerifyConfig(..),
 	shouldVerify,
 	verifyKeyContentPostRetrieval,
 	verifyKeyContent,
@@ -24,6 +23,7 @@ module Annex.Verify (
 import Annex.Common
 import qualified Annex
 import qualified Types.Remote
+import Types.Remote (VerifyConfigA(..))
 import qualified Types.Backend
 import Types.Backend (IncrementalVerifier(..))
 import qualified Backend
@@ -39,8 +39,6 @@ import qualified Data.ByteString as S
 import qualified System.FilePath.ByteString as P
 #endif
 
-data VerifyConfig = AlwaysVerify | NoVerify | RemoteVerify Remote | DefaultVerify
-
 shouldVerify :: VerifyConfig -> Annex Bool
 shouldVerify AlwaysVerify = return True
 shouldVerify NoVerify = return False

Command/AddUrl.hs

@@ -201,7 +201,8 @@ downloadRemoteFile addunlockedmatcher r o uri file sz = checkCanAdd o file $ \ca
 			-- should use to download it.
 			setTempUrl urlkey loguri
 			let downloader = \dest p ->
-				fst <$> Remote.verifiedAction (Remote.retrieveKeyFile r urlkey af dest p)
+				fst <$> Remote.verifiedAction
+					(Remote.retrieveKeyFile r urlkey af dest p (RemoteVerify r))
 			ret <- downloadWith canadd addunlockedmatcher downloader urlkey (Remote.uuid r) loguri file
 			removeTempUrl urlkey
 			return ret

Command/Fsck.hs

@@ -199,7 +199,7 @@ performRemote key afile backend numcopies remote =
 			)
 		, return Nothing
 		)
-	getfile' tmp = Remote.retrieveKeyFile remote key (AssociatedFile Nothing) (fromRawFilePath tmp) dummymeter
+	getfile' tmp = Remote.retrieveKeyFile remote key (AssociatedFile Nothing) (fromRawFilePath tmp) dummymeter (RemoteVerify remote)
 	dummymeter _ = noop
 	getcheap tmp = case Remote.retrieveKeyFileCheap remote of
 		Just a -> isRight <$> tryNonAsync (a key afile (fromRawFilePath tmp))

Command/TestRemote.hs

@@ -297,7 +297,7 @@ test runannex mkr mkk =
 			Nothing -> return True
 			Just verifier -> verifier k (serializeKey' k)
 	get r k = logStatusAfter k $ getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) $ \dest ->
-		tryNonAsync (Remote.retrieveKeyFile r k (AssociatedFile Nothing) (fromRawFilePath dest) nullMeterUpdate) >>= \case
+		tryNonAsync (Remote.retrieveKeyFile r k (AssociatedFile Nothing) (fromRawFilePath dest) nullMeterUpdate (RemoteVerify r)) >>= \case
 			Right v -> return (True, v)
 			Left _ -> return (False, UnVerified)
 	store r k = Remote.storeKey r k (AssociatedFile Nothing) nullMeterUpdate
@@ -371,7 +371,7 @@ testUnavailable runannex mkr mkk =
 		Remote.checkPresent r k
 	, check (== Right False) "retrieveKeyFile" $ \r k ->
 		logStatusAfter k $ getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) $ \dest ->
-			tryNonAsync (Remote.retrieveKeyFile r k (AssociatedFile Nothing) (fromRawFilePath dest) nullMeterUpdate) >>= \case
+			tryNonAsync (Remote.retrieveKeyFile r k (AssociatedFile Nothing) (fromRawFilePath dest) nullMeterUpdate (RemoteVerify r)) >>= \case
 				Right v -> return (True, v)
 				Left _ -> return (False, UnVerified)
 	, check (== Right False) "retrieveKeyFileCheap" $ \r k -> case Remote.retrieveKeyFileCheap r of

Command/TransferKey.hs

@@ -63,12 +63,14 @@ toPerform key file remote = go Upload file $
 fromPerform :: Key -> AssociatedFile -> Remote -> CommandPerform
 fromPerform key file remote = go Upload file $
 	download' (uuid remote) key file Nothing stdRetry $ \p ->
-		logStatusAfter key $ getViaTmp (retrievalSecurityPolicy remote) (RemoteVerify remote) key file $ \t ->
-			tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p) >>= \case
+		logStatusAfter key $ getViaTmp (retrievalSecurityPolicy remote) vc key file $ \t ->
+			tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p vc) >>= \case
 				Right v -> return (True, v)	
 				Left e -> do
 					warning (show e)
 					return (False, UnVerified)
+  where
+	vc = RemoteVerify remote
 
 go :: Direction -> AssociatedFile -> (NotifyWitness -> Annex Bool) -> CommandPerform
 go direction file a = notifyTransfer direction file a >>= liftIO . exitBool

Command/TransferKeys.hs

@@ -51,7 +51,7 @@ start = do
 		| otherwise = notifyTransfer direction file $
 			download' (Remote.uuid remote) key file Nothing stdRetry $ \p ->
 				logStatusAfter key $ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file $ \t -> do
-					r <- tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p) >>= \case
+					r <- tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p (RemoteVerify remote)) >>= \case
 						Left e -> do
 							warning (show e)
 							return (False, UnVerified)

Command/Transferrer.hs

@@ -56,7 +56,7 @@ start = do
 		-- and for retrying, and updating location log,
 		-- and stall canceling.
 		let go p = getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file $ \t -> do
-			Remote.verifiedAction (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p)
+			Remote.verifiedAction (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p (RemoteVerify remote))
 		in download' (Remote.uuid remote) key file Nothing noRetry go 
 			noNotification
 	runner (AssistantUploadRequest _ key (TransferAssociatedFile file)) remote =
@@ -73,7 +73,7 @@ start = do
 		notifyTransfer Download file $
 			download' (Remote.uuid remote) key file Nothing stdRetry $ \p ->
 				logStatusAfter key $ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file $ \t -> do
-					r <- tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p) >>= \case
+					r <- tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p (RemoteVerify remote)) >>= \case
 						Left e -> do
 							warning (show e)
 							return (False, UnVerified)

Remote/BitTorrent.hs

@@ -96,8 +96,8 @@ gen r _ rc gc rs = do
 		, remoteStateHandle = rs
 		}
 
-downloadKey :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Verification
-downloadKey key _file dest p = do
+downloadKey :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification
+downloadKey key _file dest p _ = do
 	get . map (torrentUrlNum . fst . getDownloader) =<< getBitTorrentUrls key
 	-- While bittorrent verifies the hash in the torrent file,
 	-- the torrent file itself is downloaded without verification,

Remote/Git.hs

@@ -529,16 +529,16 @@ lockKey' repo r st@(State connpool duc _ _ _) key callback
 	failedlock = giveup "can't lock content"
 
 {- Tries to copy a key's content from a remote's annex to a file. -}
-copyFromRemote :: Remote -> State -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Verification
+copyFromRemote :: Remote -> State -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification
 copyFromRemote = copyFromRemote' False
 
-copyFromRemote' :: Bool -> Remote -> State -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Verification
-copyFromRemote' forcersync r st key file dest meterupdate = do
+copyFromRemote' :: Bool -> Remote -> State -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification
+copyFromRemote' forcersync r st key file dest meterupdate vc = do
 	repo <- getRepo r
-	copyFromRemote'' repo forcersync r st key file dest meterupdate
+	copyFromRemote'' repo forcersync r st key file dest meterupdate vc
 
-copyFromRemote'' :: Git.Repo -> Bool -> Remote -> State -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Verification
-copyFromRemote'' repo forcersync r st@(State connpool _ _ _ _) key file dest meterupdate
+copyFromRemote'' :: Git.Repo -> Bool -> Remote -> State -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification
+copyFromRemote'' repo forcersync r st@(State connpool _ _ _ _) key file dest meterupdate vc
 	| Git.repoIsHttp repo = do
 		gc <- Annex.getGitConfig
 		ok <- Url.withUrlOptionsPromptingCreds $
@@ -555,12 +555,11 @@ copyFromRemote'' repo forcersync r st@(State connpool _ _ _ _) key file dest met
 				let checksuccess = check >>= \case
 					Just err -> giveup err
 					Nothing -> return True
-				let verify = Annex.Content.RemoteVerify r
 				copier <- mkFileCopier hardlink st
 				(ok, v) <- runTransfer (Transfer Download u (fromKey id key))
 					file Nothing stdRetry $ \p ->
 						metered (Just (combineMeterUpdate p meterupdate)) key $ \_ p' -> 
-							copier object dest key p' checksuccess verify
+							copier object dest key p' checksuccess vc
 				if ok
 					then return v
 					else giveup "failed to retrieve content from remote"
@@ -572,9 +571,8 @@ copyFromRemote'' repo forcersync r st@(State connpool _ _ _ _) key file dest met
 				then return v
 				else giveup "failed to retrieve content from remote"
 		else P2PHelper.retrieve
-			(Annex.Content.RemoteVerify r)
 			(\p -> Ssh.runProto r connpool (return (False, UnVerified)) (fallback p))
-			key file dest meterupdate
+			key file dest meterupdate vc
 	| otherwise = giveup "copying from non-ssh, non-http remote not supported"
   where
 	fallback p = unVerified $ feedprogressback $ \p' -> do
@@ -699,7 +697,7 @@ copyToRemote' repo r st@(State connpool duc _ _ _) key file meterupdate
 		res <- onLocalFast st $ ifM (Annex.Content.inAnnex key)
 			( return True
 			, runTransfer (Transfer Download u (fromKey id key)) file Nothing stdRetry $ \p -> do
-				let verify = Annex.Content.RemoteVerify r
+				let verify = RemoteVerify r
 				copier <- mkFileCopier hardlink st
 				let rsp = RetrievalAllKeysSecure
 				let checksuccess = liftIO checkio >>= \case

Remote/Helper/ExportImport.hs

@@ -171,14 +171,14 @@ adjustExportImport' isexport isimport r rs = do
 		, lockContent = if versioned
 			then lockContent r
 			else Nothing
-		, retrieveKeyFile = \k af dest p ->
+		, retrieveKeyFile = \k af dest p vc ->
 			if isimport
-				then supportversionedretrieve k af dest p $
+				then supportversionedretrieve k af dest p vc $
 					retrieveKeyFileFromImport dbv ciddbv k af dest p
 				else if isexport
-					then supportversionedretrieve k af dest p $
+					then supportversionedretrieve k af dest p vc $
 						retrieveKeyFileFromExport dbv k af dest p
-					else retrieveKeyFile r k af dest p
+					else retrieveKeyFile r k af dest p vc
 		, retrieveKeyFileCheap = if versioned
 			then retrieveKeyFileCheap r
 			else Nothing
@@ -369,9 +369,9 @@ adjustExportImport' isexport isimport r rs = do
 	-- versionedExport remotes have a key/value store, so can use
 	-- the usual retrieveKeyFile, rather than an import/export
 	-- variant. However, fall back to that if retrieveKeyFile fails.
-	supportversionedretrieve k af dest p a
+	supportversionedretrieve k af dest p vc a
 		| versionedExport (exportActions r) =
-			retrieveKeyFile r k af dest p
+			retrieveKeyFile r k af dest p vc
 				`catchNonAsync` const a
 		| otherwise = a
 

Remote/Helper/Hooks.hs

@@ -34,8 +34,10 @@ addHooks' r Nothing Nothing = r
 addHooks' r starthook stophook = r'
   where
 	r' = r
-		{ storeKey = \k f p -> wrapper $ storeKey r k f p
-		, retrieveKeyFile = \k f d p -> wrapper $ retrieveKeyFile r k f d p
+		{ storeKey = \k f p -> 
+			wrapper $ storeKey r k f p
+		, retrieveKeyFile = \k f d p vc -> 
+			wrapper $ retrieveKeyFile r k f d p vc
 		, retrieveKeyFileCheap = case retrieveKeyFileCheap r of
 			Just a -> Just $ \k af f -> wrapper $ a k af f
 			Nothing -> Nothing

Remote/Helper/P2P.hs

@@ -40,8 +40,8 @@ store runner k af p = do
 			Just False -> giveup "Transfer failed"
 			Nothing -> remoteUnavail
 
-retrieve :: VerifyConfig -> (MeterUpdate -> ProtoRunner (Bool, Verification)) -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Verification
-retrieve verifyconfig runner k af dest p = do
+retrieve :: (MeterUpdate -> ProtoRunner (Bool, Verification)) -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification
+retrieve runner k af dest p verifyconfig = do
 	iv <- startVerifyKeyContentIncrementally verifyconfig k
 	metered (Just p) k $ \m p' -> 
 		runner p' (P2P.get dest k iv af m p') >>= \case

Remote/Helper/Special.hs

@@ -146,8 +146,8 @@ fileRetriever' a k m miv callback = do
  -}
 storeKeyDummy :: Key -> AssociatedFile -> MeterUpdate -> Annex ()
 storeKeyDummy _ _ _ = error "missing storeKey implementation"
-retrieveKeyFileDummy :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Verification
-retrieveKeyFileDummy _ _ _ _ = error "missing retrieveKeyFile implementation"
+retrieveKeyFileDummy :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification
+retrieveKeyFileDummy _ _ _ _ _ = error "missing retrieveKeyFile implementation"
 removeKeyDummy :: Key -> Annex ()
 removeKeyDummy _ = error "missing removeKey implementation"
 checkPresentDummy :: Key -> Annex Bool
@@ -192,7 +192,7 @@ specialRemote' cfg c storer retriever remover checkpresent baser = encr
   where
 	encr = baser
 		{ storeKey = \k _f p -> cip >>= storeKeyGen k p
-		, retrieveKeyFile = \k _f d p -> cip >>= retrieveKeyFileGen k d p
+		, retrieveKeyFile = \k _f d p vc -> cip >>= retrieveKeyFileGen k d p vc
 		, retrieveKeyFileCheap = case retrieveKeyFileCheap baser of
 			Nothing -> Nothing
 			Just a
@@ -241,11 +241,9 @@ specialRemote' cfg c storer retriever remover checkpresent baser = encr
 		enck = maybe id snd enc
 
 	-- call retriever to get chunks; decrypt them; stream to dest file
-	retrieveKeyFileGen k dest p enc =
+	retrieveKeyFileGen k dest p vc enc =
 		displayprogress p k Nothing $ \p' ->
-			retrieveChunks retriever
-				(uuid baser)
-				(RemoteVerify baser) 
+			retrieveChunks retriever (uuid baser) vc
 				chunkconfig enck k dest p' enc encr
 	  where
 		enck = maybe id snd enc

Remote/HttpAlso.hs

@@ -113,8 +113,8 @@ httpAlsoSetup _ (Just u) _ c gc = do
 	gitConfigSpecialRemote u c' [("httpalso", "true")]
 	return (c', u)
 
-downloadKey :: Maybe URLString -> LearnedLayout -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Verification
-downloadKey baseurl ll key _af dest p = do
+downloadKey :: Maybe URLString -> LearnedLayout -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification
+downloadKey baseurl ll key _af dest p _vc = do
 	downloadAction dest p key (keyUrlAction baseurl ll key)
 	return UnVerified
 

Remote/P2P.hs

@@ -13,7 +13,6 @@ module Remote.P2P (
 import Annex.Common
 import qualified Annex
 import qualified P2P.Protocol as P2P
-import qualified Annex.Content
 import P2P.Address
 import P2P.Annex
 import P2P.IO
@@ -57,7 +56,7 @@ chainGen addr r u rc gc rs = do
 		, cost = cst
 		, name = Git.repoDescribe r
 		, storeKey = store (const protorunner)
-		, retrieveKeyFile = retrieve (Annex.Content.RemoteVerify this) (const protorunner)
+		, retrieveKeyFile = retrieve (const protorunner)
 		, retrieveKeyFileCheap = Nothing
 		, retrievalSecurityPolicy = RetrievalAllKeysSecure
 		, removeKey = remove protorunner

Remote/Tahoe.hs

@@ -144,8 +144,8 @@ store rs hdl k _f _p = sendAnnex k noop $ \src ->
 		(giveup "tahoe failed to store content")
 		(\cap -> storeCapability rs k cap)
 
-retrieve :: RemoteStateHandle -> TahoeHandle -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Verification
-retrieve rs hdl k _f d _p = do
+retrieve :: RemoteStateHandle -> TahoeHandle -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification
+retrieve rs hdl k _f d _p _ = do
 	go =<< getCapability rs k
 	-- Tahoe verifies the content it retrieves using cryptographically
 	-- secure methods.

Remote/Web.hs

@@ -81,8 +81,8 @@ gen r _ rc gc rs = do
 		, remoteStateHandle = rs
 		}
 
-downloadKey :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Verification
-downloadKey key _af dest p = do
+downloadKey :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification
+downloadKey key _af dest p _ = do
 	get =<< getWebUrls key
 	return UnVerified
   where

Types.hs

@@ -15,6 +15,7 @@ module Types (
 	RemoteGitConfig(..),
 	Remote,
 	RemoteType,
+	VerifyConfig,
 ) where
 
 import Annex
@@ -27,3 +28,4 @@ import Types.Remote
 type Backend = BackendA Annex
 type Remote = RemoteA Annex
 type RemoteType = RemoteTypeA Annex
+type VerifyConfig = VerifyConfigA Annex

Types/Remote.hs

@@ -16,6 +16,7 @@ module Types.Remote
 	, RemoteStateHandle
 	, SetupStage(..)
 	, Availability(..)
+	, VerifyConfigA(..)
 	, Verification(..)
 	, unVerified
 	, RetrievalSecurityPolicy(..)
@@ -95,7 +96,7 @@ data RemoteA a = Remote
 	-- (The MeterUpdate does not need to be used if it writes
 	-- sequentially to the file.)
 	-- Throws exception on failure.
-	, retrieveKeyFile :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> a Verification
+	, retrieveKeyFile :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfigA a -> a Verification
 	-- Retrieves a key's contents to a tmp file, if it can be done cheaply.
 	-- It's ok to create a symlink or hardlink.
 	-- Throws exception on failure.
@@ -192,6 +193,12 @@ instance Ord (RemoteA a) where
 instance ToUUID (RemoteA a) where
 	toUUID = uuid
 
+data VerifyConfigA a
+	= AlwaysVerify
+	| NoVerify
+	| RemoteVerify (RemoteA a)
+	| DefaultVerify
+
 data Verification
 	= UnVerified 
 	-- ^ Content was not verified during transfer, but is probably