From 90950a37e52ac834a3986447ded79c0dae99f4f2 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 9 May 2022 12:25:04 -0400 Subject: [PATCH] support incremental verification when retrieving from export/import remotes None of the special remotes do it yet, but this lays the groundwork. Added MustFinishIncompleteVerify so that, when an incremental verify is started but not complete, it can be forced to finish it. Otherwise, it would have skipped doing it when verification is disabled, but verification must always be done when retrievin from export remotes since files can be modified during retrieval. Note that retrieveExportWithContentIdentifier doesn't support incremental verification yet. And I'm not sure if it can -- it doesn't know the Key before it downloads the content. It seems a new API call would need to be split out of that, which is provided with the key. Sponsored-by: Dartmouth College's Datalad project --- Annex/Verify.hs | 8 ++++++-- Command/TestRemote.hs | 2 +- Remote/Adb.hs | 6 ++++-- Remote/Directory.hs | 6 ++++-- Remote/External.hs | 6 ++++-- Remote/Helper/ExportImport.hs | 6 ++++-- Remote/HttpAlso.hs | 5 +++-- Remote/Rsync.hs | 6 ++++-- Remote/S3.hs | 3 ++- Remote/WebDAV.hs | 5 +++-- Types/Remote.hs | 11 +++++++---- 11 files changed, 42 insertions(+), 22 deletions(-) diff --git a/Annex/Verify.hs b/Annex/Verify.hs index 729dcfddc5..9e4deb93ab 100644 --- a/Annex/Verify.hs +++ b/Annex/Verify.hs @@ -79,15 +79,19 @@ verifyKeyContentPostRetrieval rsp v verification k f = case (rsp, verification) ( verify , return True ) - (_, MustVerify) -> verify (_, IncompleteVerify _) -> ifM (shouldVerify v) ( verify , return True ) + (_, MustVerify) -> verify + (_, MustFinishIncompleteVerify _) -> verify where verify = enteringStage VerifyStage $ case verification of - IncompleteVerify iv -> resumeVerifyKeyContent k f iv + IncompleteVerify iv -> + resumeVerifyKeyContent k f iv + MustFinishIncompleteVerify iv -> + resumeVerifyKeyContent k f iv _ -> verifyKeyContent k f verifyKeyContent :: Key -> RawFilePath -> Annex Bool diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs index ef90ff28b9..7e85db72be 100644 --- a/Command/TestRemote.hs +++ b/Command/TestRemote.hs @@ -354,7 +354,7 @@ testExportTree runannex mkr mkk1 mkk2 = liftIO $ hClose h tryNonAsync (Remote.retrieveExport ea k testexportlocation tmp nullMeterUpdate) >>= \case Left _ -> return False - Right () -> verifyKeyContentPostRetrieval RetrievalAllKeysSecure AlwaysVerify UnVerified k (toRawFilePath tmp) + Right v -> verifyKeyContentPostRetrieval RetrievalAllKeysSecure AlwaysVerify v k (toRawFilePath tmp) checkpresentexport ea k = Remote.checkPresentExport ea k testexportlocation removeexport ea k = Remote.removeExport ea k testexportlocation removeexportdirectory ea = case Remote.removeExportDirectory ea of diff --git a/Remote/Adb.hs b/Remote/Adb.hs index 915ab44b6f..09c2aa219e 100644 --- a/Remote/Adb.hs +++ b/Remote/Adb.hs @@ -255,8 +255,10 @@ storeExportM serial adir src _k loc _p = where dest = androidExportLocation adir loc -retrieveExportM :: AndroidSerial -> AndroidPath -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex () -retrieveExportM serial adir _k loc dest _p = retrieve' serial src dest +retrieveExportM :: AndroidSerial -> AndroidPath -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Verification +retrieveExportM serial adir _k loc dest _p = do + retrieve' serial src dest + return UnVerified where src = androidExportLocation adir loc diff --git a/Remote/Directory.hs b/Remote/Directory.hs index 93a78eda14..3164e4d3bf 100644 --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -316,8 +316,10 @@ storeExportM d cow src _k loc p = do dest = exportPath d loc go tmp () = void $ fileCopier cow src tmp p Nothing -retrieveExportM :: RawFilePath -> CopyCoWTried -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex () -retrieveExportM d cow _k loc dest p = void $ fileCopier cow src dest p Nothing +retrieveExportM :: RawFilePath -> CopyCoWTried -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Verification +retrieveExportM d cow _k loc dest p = do + void $ fileCopier cow src dest p Nothing + return UnVerified where src = fromRawFilePath $ exportPath d loc diff --git a/Remote/External.hs b/Remote/External.hs index 1137cd74f5..99dfae52fa 100644 --- a/Remote/External.hs +++ b/Remote/External.hs @@ -291,8 +291,10 @@ storeExportM external f k loc p = either giveup return =<< go _ -> Nothing req sk = TRANSFEREXPORT Upload sk f -retrieveExportM :: External -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex () -retrieveExportM external k loc d p = either giveup return =<< go +retrieveExportM :: External -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Verification +retrieveExportM external k loc d p = do + either giveup return =<< go + return UnVerified where go = handleRequestExport external loc req k (Just p) $ \resp -> case resp of TRANSFER_SUCCESS Download k' diff --git a/Remote/Helper/ExportImport.hs b/Remote/Helper/ExportImport.hs index 7e607ad892..7b0839fc55 100644 --- a/Remote/Helper/ExportImport.hs +++ b/Remote/Helper/ExportImport.hs @@ -349,8 +349,10 @@ adjustExportImport' isexport isimport r rs = do retrieveKeyFileFromExport dbv k _af dest p = ifM (isVerifiable k) ( do l <- getfirstexportloc dbv k - retrieveExport (exportActions r) k l dest p - return MustVerify + retrieveExport (exportActions r) k l dest p >>= return . \case + UnVerified -> MustVerify + IncompleteVerify iv -> MustFinishIncompleteVerify iv + v -> v , giveup $ "exported content cannot be verified due to using the " ++ decodeBS (formatKeyVariety (fromKey keyVariety k)) ++ " backend" ) diff --git a/Remote/HttpAlso.hs b/Remote/HttpAlso.hs index 49310fd01b..0f26af48b2 100644 --- a/Remote/HttpAlso.hs +++ b/Remote/HttpAlso.hs @@ -120,9 +120,10 @@ downloadKey baseurl ll key _af dest p vc = do downloadAction dest p iv key (keyUrlAction baseurl ll key) snd <$> finishVerifyKeyContentIncrementally iv -retriveExportHttpAlso :: Maybe URLString -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex () -retriveExportHttpAlso baseurl key loc dest p = +retriveExportHttpAlso :: Maybe URLString -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Verification +retriveExportHttpAlso baseurl key loc dest p = do downloadAction dest p Nothing key (exportLocationUrlAction baseurl loc) + return UnVerified downloadAction :: FilePath -> MeterUpdate -> Maybe IncrementalVerifier -> Key -> ((URLString -> Annex (Either String ())) -> Annex (Either String ())) -> Annex () downloadAction dest p iv key run = diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs index e7e9ff740f..2915671b51 100644 --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -316,8 +316,10 @@ storeExportM o src _k loc meterupdate = basedest = fromRawFilePath (fromExportLocation loc) populatedest = liftIO . createLinkOrCopy src -retrieveExportM :: RsyncOpts -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex () -retrieveExportM o _k loc dest p = rsyncRetrieve o [rsyncurl] dest (Just p) +retrieveExportM :: RsyncOpts -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Verification +retrieveExportM o _k loc dest p = do + rsyncRetrieve o [rsyncurl] dest (Just p) + return UnVerified where rsyncurl = mkRsyncUrl o (fromRawFilePath (fromExportLocation loc)) diff --git a/Remote/S3.hs b/Remote/S3.hs index 9ca1d7c87d..0cc59120fd 100644 --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -495,7 +495,7 @@ storeExportS3' hv r rs info magic f k loc p = withS3Handle hv $ \case setS3VersionID info rs k mvid return (metag, mvid) -retrieveExportS3 :: S3HandleVar -> Remote -> S3Info -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex () +retrieveExportS3 :: S3HandleVar -> Remote -> S3Info -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Verification retrieveExportS3 hv r info _k loc f p = do withS3Handle hv $ \case Just h -> retrieveHelper info h (Left (T.pack exportloc)) f p Nothing @@ -504,6 +504,7 @@ retrieveExportS3 hv r info _k loc f p = do Url.withUrlOptions (Url.download' p Nothing (geturl exportloc) f) Nothing -> giveup $ needS3Creds (uuid r) + return UnVerified where exportloc = bucketExportLocation info loc diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs index 94eb224b91..45c2f5e080 100644 --- a/Remote/WebDAV.hs +++ b/Remote/WebDAV.hs @@ -218,10 +218,11 @@ storeExportDav hdl f k loc p = case exportLocation loc of storeHelper dav (exportTmpLocation loc k) dest reqbody Left err -> giveup err -retrieveExportDav :: DavHandleVar -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex () +retrieveExportDav :: DavHandleVar -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Verification retrieveExportDav hdl _k loc d p = case exportLocation loc of - Right src -> withDavHandle hdl $ \h -> runExport h $ \_dav -> + Right src -> withDavHandle hdl $ \h -> runExport h $ \_dav -> do retrieveHelper src d p Nothing + return UnVerified Left err -> giveup err checkPresentExportDav :: DavHandleVar -> Remote -> Key -> ExportLocation -> Annex Bool diff --git a/Types/Remote.hs b/Types/Remote.hs index e8b25c2a81..d80d48fba0 100644 --- a/Types/Remote.hs +++ b/Types/Remote.hs @@ -208,12 +208,15 @@ data Verification -- again. The verification does not need to use a -- cryptographically secure hash, but the hash does need to -- have preimage resistance. - | MustVerify - -- ^ Content likely to have been altered during transfer, - -- verify even if verification is normally disabled | IncompleteVerify IncrementalVerifier -- ^ Content was partially verified during transfer, but -- the verification is not complete. + | MustVerify + -- ^ Content likely to have been altered during transfer, + -- verify even if verification is normally disabled + | MustFinishIncompleteVerify IncrementalVerifier + -- ^ Content likely to have been altered during transfer, + -- finish verification even if verification is normally disabled. unVerified :: Monad m => m a -> m (a, Verification) unVerified a = do @@ -262,7 +265,7 @@ data ExportActions a = ExportActions -- (The MeterUpdate does not need to be used if it writes -- sequentially to the file.) -- Throws exception on failure. - , retrieveExport :: Key -> ExportLocation -> FilePath -> MeterUpdate -> a () + , retrieveExport :: Key -> ExportLocation -> FilePath -> MeterUpdate -> a Verification -- Removes an exported file (succeeds if the contents are not present) -- Can throw exception if unable to access remote, or if remote -- refuses to remove the content.