diff --git a/Annex/Content.hs b/Annex/Content.hs index 4f05d61f67..eba9c266dd 100644 --- a/Annex/Content.hs +++ b/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 diff --git a/Annex/Transfer.hs b/Annex/Transfer.hs index e6a6e4c806..c57dbaf3ec 100644 --- a/Annex/Transfer.hs +++ b/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 diff --git a/Annex/Verify.hs b/Annex/Verify.hs index 4b5d81caee..c41a793f62 100644 --- a/Annex/Verify.hs +++ b/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 diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs index 916cbdaa52..e12d44e2b5 100644 --- a/Command/AddUrl.hs +++ b/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 diff --git a/Command/Fsck.hs b/Command/Fsck.hs index 5ab724362f..2408c439d6 100644 --- a/Command/Fsck.hs +++ b/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)) diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs index bc12e4580b..9d7daa8297 100644 --- a/Command/TestRemote.hs +++ b/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 diff --git a/Command/TransferKey.hs b/Command/TransferKey.hs index 8eac1c6892..6b38a0bc53 100644 --- a/Command/TransferKey.hs +++ b/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 diff --git a/Command/TransferKeys.hs b/Command/TransferKeys.hs index 5c55d23e84..699febbfaa 100644 --- a/Command/TransferKeys.hs +++ b/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) diff --git a/Command/Transferrer.hs b/Command/Transferrer.hs index 77cd4d9ae5..d3cf624a34 100644 --- a/Command/Transferrer.hs +++ b/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) diff --git a/Remote/BitTorrent.hs b/Remote/BitTorrent.hs index 723c0896c5..818676eb6d 100644 --- a/Remote/BitTorrent.hs +++ b/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, diff --git a/Remote/Git.hs b/Remote/Git.hs index 4a2a3e0179..352b920069 100644 --- a/Remote/Git.hs +++ b/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 diff --git a/Remote/Helper/ExportImport.hs b/Remote/Helper/ExportImport.hs index 77351b3077..7e607ad892 100644 --- a/Remote/Helper/ExportImport.hs +++ b/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 diff --git a/Remote/Helper/Hooks.hs b/Remote/Helper/Hooks.hs index c3f487516d..3df75dd059 100644 --- a/Remote/Helper/Hooks.hs +++ b/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 diff --git a/Remote/Helper/P2P.hs b/Remote/Helper/P2P.hs index 9e00101c87..647bc6b016 100644 --- a/Remote/Helper/P2P.hs +++ b/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 diff --git a/Remote/Helper/Special.hs b/Remote/Helper/Special.hs index 5528470da1..86ba114d8c 100644 --- a/Remote/Helper/Special.hs +++ b/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 diff --git a/Remote/HttpAlso.hs b/Remote/HttpAlso.hs index 796ee19718..522100dfc9 100644 --- a/Remote/HttpAlso.hs +++ b/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 diff --git a/Remote/P2P.hs b/Remote/P2P.hs index cc39ea9e0c..21cf5b42e1 100644 --- a/Remote/P2P.hs +++ b/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 diff --git a/Remote/Tahoe.hs b/Remote/Tahoe.hs index 22616c53c1..22edac4810 100644 --- a/Remote/Tahoe.hs +++ b/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. diff --git a/Remote/Web.hs b/Remote/Web.hs index 6b18a2fb31..049ed61120 100644 --- a/Remote/Web.hs +++ b/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 diff --git a/Types.hs b/Types.hs index 9f7a40b243..43c945e12a 100644 --- a/Types.hs +++ b/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 diff --git a/Types/Remote.hs b/Types/Remote.hs index ff1919bc4e..709d16da2f 100644 --- a/Types/Remote.hs +++ b/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