diff --git a/Annex/Content.hs b/Annex/Content.hs index eba9c266dd..fa8b35734f 100644 --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -633,8 +633,8 @@ saveState nocommit = doSideAction $ do {- Downloads content from any of a list of urls, displaying a progress - meter. -} -downloadUrl :: Key -> MeterUpdate -> [Url.URLString] -> FilePath -> Url.UrlOptions -> Annex Bool -downloadUrl k p urls file uo = +downloadUrl :: Key -> MeterUpdate -> Maybe IncrementalVerifier -> [Url.URLString] -> FilePath -> Url.UrlOptions -> Annex Bool +downloadUrl k p iv urls file uo = -- Poll the file to handle configurations where an external -- download command is used. meteredFile file (Just p) k (go urls Nothing) @@ -643,7 +643,7 @@ downloadUrl k p urls file uo = -- download. go [] (Just err) = warning err >> return False go [] Nothing = return False - go (u:us) _ = Url.download' p u file uo >>= \case + go (u:us) _ = Url.download' p iv u file uo >>= \case Right () -> return True Left err -> go us (Just err) diff --git a/Annex/CopyFile.hs b/Annex/CopyFile.hs index e60abe9cce..b49f2ef45b 100644 --- a/Annex/CopyFile.hs +++ b/Annex/CopyFile.hs @@ -72,9 +72,7 @@ fileCopier _ src dest meterupdate iv = docopy fileCopier copycowtried src dest meterupdate iv = ifM (liftIO $ tryCopyCoW copycowtried src dest meterupdate) ( do - -- Make sure the incremental verifier fails, - -- since we did not feed it. - liftIO $ maybe noop failIncremental iv + liftIO $ maybe noop unableIncremental iv return CopiedCoW , docopy ) diff --git a/Annex/Verify.hs b/Annex/Verify.hs index 22cdf02c92..1316a25f8f 100644 --- a/Annex/Verify.hs +++ b/Annex/Verify.hs @@ -110,17 +110,19 @@ resumeVerifyKeyContent k f iv = liftIO (positionIncremental iv) >>= \case then fallback else case fromKey keySize k of Just size | fsz /= size -> return False - _ -> go fsz endpos + _ -> go fsz endpos >>= \case + Just v -> return v + Nothing -> fallback where fallback = verifyKeyContent k f go fsz endpos | fsz == endpos = - liftIO $ catchDefaultIO False $ + liftIO $ catchDefaultIO (Just False) $ finalizeIncremental iv | otherwise = do showAction (descVerify iv) - liftIO $ catchDefaultIO False $ + liftIO $ catchDefaultIO (Just False) $ withBinaryFile (fromRawFilePath f) ReadMode $ \h -> do hSeek h AbsoluteSeek endpos feedincremental h @@ -172,12 +174,13 @@ finishVerifyKeyContentIncrementally :: Maybe IncrementalVerifier -> Annex (Bool, finishVerifyKeyContentIncrementally Nothing = return (True, UnVerified) finishVerifyKeyContentIncrementally (Just iv) = - ifM (liftIO $ finalizeIncremental iv) - ( return (True, Verified) - , do + liftIO (finalizeIncremental iv) >>= \case + Just True -> return (True, Verified) + Just False -> do warning "verification of content failed" return (False, UnVerified) - ) + -- Incremental verification was not able to be done. + Nothing -> return (True, UnVerified) -- | Reads the file as it grows, and feeds it to the incremental verifier. -- @@ -190,11 +193,11 @@ finishVerifyKeyContentIncrementally (Just iv) = -- for the file to appear before opening it and starting verification. -- -- This is not supported for all OSs, and on OS's where it is not --- supported, verification will fail. +-- supported, verification will not happen. -- -- The writer probably needs to be another process. If the file is being -- written directly by git-annex, the haskell RTS will prevent opening it --- for read at the same time, and verification will fail. +-- for read at the same time, and verification will not happen. -- -- Note that there are situations where the file may fail to verify despite -- having the correct content. For example, when the file is written out @@ -221,7 +224,7 @@ tailVerify :: IncrementalVerifier -> RawFilePath -> TMVar () -> IO () tailVerify iv f finished = tryNonAsync go >>= \case Right r -> return r - Left _ -> failIncremental iv + Left _ -> unableIncremental iv where -- Watch the directory containing the file, and wait for -- the file to be modified. It's possible that the file already @@ -246,7 +249,7 @@ tailVerify iv f finished = let cleanup = void . tryNonAsync . INotify.removeWatch let stop w = do cleanup w - failIncremental iv + unableIncremental iv waitopen modified >>= \case Nothing -> stop wd Just h -> do @@ -305,5 +308,5 @@ tailVerify iv f finished = chunk = 65536 #else -tailVerify iv _ _ = failIncremental iv +tailVerify iv _ _ = unableIncremental iv #endif diff --git a/P2P/Annex.hs b/P2P/Annex.hs index 5f0e174666..a4e3a453d6 100644 --- a/P2P/Annex.hs +++ b/P2P/Annex.hs @@ -202,10 +202,12 @@ runLocal runst runner a = case a of runner validitycheck >>= \case Right (Just Valid) -> case incrementalverifier of - Just iv -> ifM (liftIO (finalizeIncremental iv) <&&> pure rightsize) - ( return (True, Verified) - , return (False, UnVerified) - ) + Just iv + | rightsize -> liftIO (finalizeIncremental iv) >>= \case + Nothing -> return (True, UnVerified) + Just True -> return (True, Verified) + Just False -> return (False, UnVerified) + | otherwise -> return (False, UnVerified) Nothing -> return (rightsize, UnVerified) Right (Just Invalid) | l == 0 -> -- Special case, for when diff --git a/Remote/Helper/Chunked.hs b/Remote/Helper/Chunked.hs index 1edeb408ad..ade47f3f4c 100644 --- a/Remote/Helper/Chunked.hs +++ b/Remote/Helper/Chunked.hs @@ -366,11 +366,10 @@ retrieveChunks retriever u vc chunkconfig encryptor basek dest basep enc encc | otherwise = Nothing finalize (Right Nothing) = return UnVerified - finalize (Right (Just iv)) = - ifM (liftIO $ finalizeIncremental iv) - ( return Verified - , return UnVerified - ) + finalize (Right (Just iv)) = + liftIO (finalizeIncremental iv) >>= \case + Just True -> return Verified + _ -> return UnVerified finalize (Left v) = return v {- Writes retrieved file content to the provided Handle, decrypting it diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs index b888727ab2..fb8a38994f 100644 --- a/Remote/WebDAV.hs +++ b/Remote/WebDAV.hs @@ -173,7 +173,7 @@ retrieve hv cc = fileRetriever' $ \d k p iv -> withDavHandle hv $ \dav -> case cc of LegacyChunks _ -> do -- Not doing incremental verification for chunks. - liftIO $ maybe noop failIncremental iv + liftIO $ maybe noop unableIncremental iv retrieveLegacyChunked (fromRawFilePath d) k p dav _ -> liftIO $ goDAV dav $ retrieveHelper (keyLocation k) (fromRawFilePath d) p iv diff --git a/Utility/Hash.hs b/Utility/Hash.hs index 7fa2175a10..d708421ca8 100644 --- a/Utility/Hash.hs +++ b/Utility/Hash.hs @@ -283,14 +283,15 @@ props_macs_stable = map (\(desc, mac, result) -> (desc ++ " stable", calcMac mac data IncrementalVerifier = IncrementalVerifier { updateIncremental :: S.ByteString -> IO () -- ^ Called repeatedly on each peice of the content. - , finalizeIncremental :: IO Bool - -- ^ Called once the full content has been sent, returns true - -- if the hash verified. - , failIncremental :: IO () - -- ^ Call if the incremental verification needs to fail. + , finalizeIncremental :: IO (Maybe Bool) + -- ^ Called once the full content has been sent, returns True + -- if the hash verified, False if it did not, and Nothing if + -- incremental verification was unable to be done. + , unableIncremental :: IO () + -- ^ Call if the incremental verification is unable to be done. , positionIncremental :: IO (Maybe Integer) -- ^ Returns the number of bytes that have been fed to this - -- incremental verifier so far. (Nothing if failIncremental was + -- incremental verifier so far. (Nothing if unableIncremental was -- called.) , descVerify :: String -- ^ A description of what is done to verify the content. @@ -311,9 +312,10 @@ mkIncrementalVerifier ctx descverify samechecksum = do readIORef v >>= \case (Just (ctx', _)) -> do let digest = hashFinalize ctx' - return $ samechecksum (show digest) - Nothing -> return False - , failIncremental = writeIORef v Nothing + return $ Just $ + samechecksum (show digest) + Nothing -> return Nothing + , unableIncremental = writeIORef v Nothing , positionIncremental = readIORef v >>= \case Just (_, n) -> return (Just n) Nothing -> return Nothing