factor out IncrementalHasher from IncrementalVerifier

This commit is contained in:
Joey Hess 2021-11-09 12:29:09 -04:00
parent 9d3ce224e3
commit 8034f2e9bb
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
9 changed files with 68 additions and 48 deletions

View file

@ -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)

View file

@ -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'

View file

@ -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

View file

@ -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)

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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
}

View file

@ -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