From: Joey Hess Date: Tue, 9 Nov 2021 16:29:09 +0000 (-0400) Subject: factor out IncrementalHasher from IncrementalVerifier X-Git-Tag: archive/raspbian/10.20250416-2+rpi1~2^2^2~57^2~42 X-Git-Url: https://dgit.raspbian.org/?a=commitdiff_plain;h=8034f2e9bb68ab710a7ca546b258c42aa357df06;p=git-annex.git factor out IncrementalHasher from IncrementalVerifier --- diff --git a/Annex/Content.hs b/Annex/Content.hs index 491d2766cf..58f1244070 100644 --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -656,8 +656,8 @@ downloadUrl listfailedurls k p iv urls file uo = -- to be used for the other urls. case iv of Just iv' -> - liftIO $ positionIncremental iv' >>= \case - Just n | n > 0 -> unableIncremental iv' + liftIO $ positionIncrementalVerifier iv' >>= \case + Just n | n > 0 -> unableIncrementalVerifier iv' _ -> noop Nothing -> noop go us ((u, err) : errs) diff --git a/Annex/CopyFile.hs b/Annex/CopyFile.hs index 66c17b7aeb..d33cfaff31 100644 --- a/Annex/CopyFile.hs +++ b/Annex/CopyFile.hs @@ -86,7 +86,7 @@ fileCopier _ src dest meterupdate iv = docopy fileCopier copycowtried src dest meterupdate iv = ifM (liftIO $ tryCopyCoW copycowtried src dest meterupdate) ( do - liftIO $ maybe noop unableIncremental iv + liftIO $ maybe noop unableIncrementalVerifier iv return CopiedCoW , docopy ) @@ -119,7 +119,7 @@ fileCopier copycowtried src dest meterupdate iv = else do let sofar' = addBytesProcessed sofar (S.length s) S.hPut hdest s - maybe noop (flip updateIncremental s) iv + maybe noop (flip updateIncrementalVerifier s) iv meterupdate sofar' docopy' hdest hsrc sofar' @@ -134,7 +134,7 @@ fileCopier copycowtried src dest meterupdate iv = s' <- getnoshort (S.length s) hsrc if s == s' then do - maybe noop (flip updateIncremental s) iv + maybe noop (flip updateIncrementalVerifier s) iv let sofar' = addBytesProcessed sofar (S.length s) meterupdate sofar' compareexisting hdest hsrc sofar' diff --git a/Annex/Verify.hs b/Annex/Verify.hs index 56d310a248..729dcfddc5 100644 --- a/Annex/Verify.hs +++ b/Annex/Verify.hs @@ -102,7 +102,7 @@ verifyKeyContent' k f = Just verifier -> verifier k f resumeVerifyKeyContent :: Key -> RawFilePath -> IncrementalVerifier -> Annex Bool -resumeVerifyKeyContent k f iv = liftIO (positionIncremental iv) >>= \case +resumeVerifyKeyContent k f iv = liftIO (positionIncrementalVerifier iv) >>= \case Nothing -> fallback Just endpos -> do fsz <- liftIO $ catchDefaultIO 0 $ getFileSize f @@ -119,21 +119,21 @@ resumeVerifyKeyContent k f iv = liftIO (positionIncremental iv) >>= \case go fsz endpos | fsz == endpos = liftIO $ catchDefaultIO (Just False) $ - finalizeIncremental iv + finalizeIncrementalVerifier iv | otherwise = do - showAction (descVerify iv) + showAction (descIncrementalVerifier iv) liftIO $ catchDefaultIO (Just False) $ withBinaryFile (fromRawFilePath f) ReadMode $ \h -> do hSeek h AbsoluteSeek endpos feedincremental h - finalizeIncremental iv + finalizeIncrementalVerifier iv feedincremental h = do b <- S.hGetSome h chunk if S.null b then return () else do - updateIncremental iv b + updateIncrementalVerifier iv b feedincremental h chunk = 65536 @@ -174,7 +174,7 @@ finishVerifyKeyContentIncrementally :: Maybe IncrementalVerifier -> Annex (Bool, finishVerifyKeyContentIncrementally Nothing = return (True, UnVerified) finishVerifyKeyContentIncrementally (Just iv) = - liftIO (finalizeIncremental iv) >>= \case + liftIO (finalizeIncrementalVerifier iv) >>= \case Just True -> return (True, Verified) Just False -> do warning "verification of content failed" @@ -224,7 +224,7 @@ tailVerify :: IncrementalVerifier -> RawFilePath -> TMVar () -> IO () tailVerify iv f finished = tryNonAsync go >>= \case Right r -> return r - Left _ -> unableIncremental iv + Left _ -> unableIncrementalVerifier iv where -- Watch the directory containing the file, and wait for -- the file to be modified. It's possible that the file already @@ -249,7 +249,7 @@ tailVerify iv f finished = let cleanup = void . tryNonAsync . INotify.removeWatch let stop w = do cleanup w - unableIncremental iv + unableIncrementalVerifier iv waitopen modified >>= \case Nothing -> stop wd Just h -> do @@ -301,12 +301,12 @@ tailVerify iv f finished = <$> takeTMVar finished) cont else do - updateIncremental iv b + updateIncrementalVerifier iv b atomically (tryTakeTMVar finished) >>= \case Nothing -> follow h modified Just () -> return () chunk = 65536 #else -tailVerify iv _ _ = unableIncremental iv +tailVerify iv _ _ = unableIncrementalVerifier iv #endif diff --git a/P2P/Annex.hs b/P2P/Annex.hs index a4e3a453d6..a2641d38da 100644 --- a/P2P/Annex.hs +++ b/P2P/Annex.hs @@ -178,7 +178,7 @@ runLocal runst runner a = case a of then defaultChunkSize else fromIntegral n b <- S.hGet h c - updateIncremental iv b + updateIncrementalVerifier iv b unless (b == S.empty) $ go iv (n - fromIntegral (S.length b)) @@ -192,7 +192,7 @@ runLocal runst runner a = case a of Nothing -> \c -> S.hPut h c Just iv -> \c -> do S.hPut h c - updateIncremental iv c + updateIncrementalVerifier iv c meteredWrite p' writechunk b indicatetransferred ti @@ -203,7 +203,7 @@ runLocal runst runner a = case a of runner validitycheck >>= \case Right (Just Valid) -> case incrementalverifier of Just iv - | rightsize -> liftIO (finalizeIncremental iv) >>= \case + | rightsize -> liftIO (finalizeIncrementalVerifier iv) >>= \case Nothing -> return (True, UnVerified) Just True -> return (True, Verified) Just False -> return (False, UnVerified) diff --git a/Remote/Helper/Chunked.hs b/Remote/Helper/Chunked.hs index b56d43389a..a8d928c597 100644 --- a/Remote/Helper/Chunked.hs +++ b/Remote/Helper/Chunked.hs @@ -372,7 +372,7 @@ retrieveChunks retriever u vc chunkconfig encryptor basek dest basep enc encc finalize (Right Nothing) = return UnVerified finalize (Right (Just iv)) = - liftIO (finalizeIncremental iv) >>= \case + liftIO (finalizeIncrementalVerifier iv) >>= \case Just True -> return Verified _ -> return UnVerified finalize (Left v) = return v @@ -426,7 +426,7 @@ writeRetrievedContent dest enc encc mh mp content miv = case (enc, mh, content) Just p -> let writer = case miv of Just iv -> \s -> do - updateIncremental iv s + updateIncrementalVerifier iv s S.hPut h s Nothing -> S.hPut h in meteredWrite p writer b diff --git a/Remote/Helper/Http.hs b/Remote/Helper/Http.hs index 2bd2c26bc7..3dc6598e5f 100644 --- a/Remote/Helper/Http.hs +++ b/Remote/Helper/Http.hs @@ -83,5 +83,5 @@ httpBodyRetriever dest meterupdate iv resp let sofar' = addBytesProcessed sofar $ S.length b S.hPut h b meterupdate sofar' - maybe noop (flip updateIncremental b) iv + maybe noop (flip updateIncrementalVerifier b) iv go sofar' h diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs index fb8a38994f..94eb224b91 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 unableIncremental iv + liftIO $ maybe noop unableIncrementalVerifier 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 d708421ca8..38e0b885e2 100644 --- a/Utility/Hash.hs +++ b/Utility/Hash.hs @@ -64,6 +64,8 @@ module Utility.Hash ( Mac(..), calcMac, props_macs_stable, + IncrementalHasher(..), + mkIncrementalHasher, IncrementalVerifier(..), mkIncrementalVerifier, ) where @@ -280,44 +282,62 @@ props_macs_stable = map (\(desc, mac, result) -> (desc ++ " stable", calcMac mac key = T.encodeUtf8 $ T.pack "foo" msg = T.encodeUtf8 $ T.pack "bar" -data IncrementalVerifier = IncrementalVerifier - { updateIncremental :: S.ByteString -> IO () +data IncrementalHasher = IncrementalHasher + { updateIncrementalHasher :: S.ByteString -> IO () -- ^ Called repeatedly on each peice of the content. - , 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) + , finalizeIncrementalHasher :: IO (Maybe String) + -- ^ Called once the full content has been sent, returns + -- the hash. (Nothing if unableIncremental was called.) + , unableIncrementalHasher :: IO () + -- ^ Call if the incremental hashing is unable to be done. + , positionIncrementalHasher :: IO (Maybe Integer) -- ^ Returns the number of bytes that have been fed to this - -- incremental verifier so far. (Nothing if unableIncremental was + -- incremental hasher so far. (Nothing if unableIncremental was -- called.) - , descVerify :: String - -- ^ A description of what is done to verify the content. + , descIncrementalHasher :: String } -mkIncrementalVerifier :: HashAlgorithm h => Context h -> String -> (String -> Bool) -> IO IncrementalVerifier -mkIncrementalVerifier ctx descverify samechecksum = do +mkIncrementalHasher :: HashAlgorithm h => Context h -> String -> IO IncrementalHasher +mkIncrementalHasher ctx desc = do v <- newIORef (Just (ctx, 0)) - return $ IncrementalVerifier - { updateIncremental = \b -> + return $ IncrementalHasher + { updateIncrementalHasher = \b -> modifyIORef' v $ \case (Just (ctx', n)) -> let !ctx'' = hashUpdate ctx' b !n' = n + fromIntegral (S.length b) in (Just (ctx'', n')) Nothing -> Nothing - , finalizeIncremental = + , finalizeIncrementalHasher = readIORef v >>= \case (Just (ctx', _)) -> do let digest = hashFinalize ctx' - return $ Just $ - samechecksum (show digest) + return $ Just $ show digest Nothing -> return Nothing - , unableIncremental = writeIORef v Nothing - , positionIncremental = readIORef v >>= \case + , unableIncrementalHasher = writeIORef v Nothing + , positionIncrementalHasher = readIORef v >>= \case Just (_, n) -> return (Just n) Nothing -> return Nothing - , descVerify = descverify + , descIncrementalHasher = desc + } + +data IncrementalVerifier = IncrementalVerifier + { updateIncrementalVerifier :: S.ByteString -> IO () + , finalizeIncrementalVerifier :: IO (Maybe Bool) + , unableIncrementalVerifier :: IO () + , positionIncrementalVerifier :: IO (Maybe Integer) + , descIncrementalVerifier :: String + } + +mkIncrementalVerifier :: HashAlgorithm h => Context h -> String -> (String -> Bool) -> IO IncrementalVerifier +mkIncrementalVerifier ctx desc samechecksum = do + hasher <- mkIncrementalHasher ctx desc + return $ IncrementalVerifier + { updateIncrementalVerifier = updateIncrementalHasher hasher + , finalizeIncrementalVerifier = + maybe Nothing (Just . samechecksum) + <$> finalizeIncrementalHasher hasher + , unableIncrementalVerifier = unableIncrementalHasher hasher + , positionIncrementalVerifier = positionIncrementalHasher hasher + , descIncrementalVerifier = descIncrementalHasher hasher } diff --git a/Utility/Url.hs b/Utility/Url.hs index 3cf268f8bf..54608d505c 100644 --- a/Utility/Url.hs +++ b/Utility/Url.hs @@ -451,7 +451,7 @@ download' nocurlerror meterupdate iv url file uo = Nothing -> throwIO ex followredir _ ex = throwIO ex - noverification = maybe noop unableIncremental iv + noverification = maybe noop unableIncrementalVerifier iv {- Download a perhaps large file using conduit, with auto-resume - of incomplete downloads. @@ -554,7 +554,7 @@ downloadConduit meterupdate iv req file uo = () <- signalsuccess False throwM e - noverification = maybe noop unableIncremental iv + noverification = maybe noop unableIncrementalVerifier iv {- Sinks a Response's body to a file. The file can either be appended to - (AppendMode), or written from the start of the response (WriteMode). @@ -575,9 +575,9 @@ sinkResponseFile sinkResponseFile meterupdate iv initialp file mode resp = do ui <- case (iv, mode) of (Just iv', AppendMode) -> do - liftIO $ unableIncremental iv' + liftIO $ unableIncrementalVerifier iv' return (const noop) - (Just iv', _) -> return (updateIncremental iv') + (Just iv', _) -> return (updateIncrementalVerifier iv') (Nothing, _) -> return (const noop) (fr, fh) <- allocate (openBinaryFile file mode) hClose runConduit $ responseBody resp .| go ui initialp fh