convert tailVerify to not finalize the verification

Added failIncremental so it can force failure to verify.

Sponsored-by: Dartmouth College's DANDI project
This commit is contained in:
Joey Hess 2021-08-13 13:39:02 -04:00
parent 9d533b347f
commit e07625df8a
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
3 changed files with 55 additions and 38 deletions

View file

@ -36,6 +36,7 @@ import Types.Key
import qualified System.INotify as INotify
import Control.Concurrent.STM
import qualified Data.ByteString as S
import qualified System.FilePath.ByteString as P
import Data.Time.Clock.POSIX
#endif
@ -131,13 +132,13 @@ startVerifyKeyContentIncrementally verifyconfig k =
-- The file does not need to exist yet when this is called. It will wait
-- for the file to appear before opening it and starting verification.
--
-- This is not supported for all OSs, and will return False on OS's
-- where it is not supported.
-- This is not supported for all OSs, and on OS's where it is not
-- supported, verification will fail.
--
-- 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
-- of order, or gets replaced part way through. To deal with such cases,
-- when False is returned, it should not be treated as if the file's
-- when verification fails, it should not be treated as if the file's
-- content is known to be incorrect, but instead as an indication that the
-- file should be verified again, once it's done being written to.
--
@ -162,27 +163,22 @@ startVerifyKeyContentIncrementally verifyconfig k =
-- writer has finished. If there is more work still to do, it returns an IO
-- action that will complete the work. This way, the caller can display
-- something appropriate while that is running.
tailVerify :: IncrementalVerifier -> FilePath -> TMVar () -> IO (Either (IO Bool) Bool)
tailVerify :: IncrementalVerifier -> RawFilePath -> TMVar () -> IO (Maybe (IO ()))
#if WITH_INOTIFY
tailVerify iv f finished =
catchDefaultIO (Right False) $
INotify.withINotify $ \i -> do
h <- waitforfiletoexist i
tryIO (go i h) >>= \case
Right r -> return r
Left _ -> do
maybe noop hClose h
return (Right False)
tryIO go >>= \case
Right r -> return r
Left _ -> do
failIncremental iv
return Nothing
where
rf = toRawFilePath f
d = toRawFilePath (takeDirectory f)
waitforfiletoexist i = tryIO (openBinaryFile f ReadMode) >>= \case
f' = fromRawFilePath f
waitforfiletoexist i = tryIO (openBinaryFile f' ReadMode) >>= \case
Right h -> return (Just h)
Left _ -> do
hv <- newEmptyTMVarIO
wd <- inotifycreate i $
tryIO (openBinaryFile f ReadMode) >>= \case
tryIO (openBinaryFile f' ReadMode) >>= \case
Right h ->
unlessM (atomically $ tryPutTMVar hv h) $
hClose h
@ -200,16 +196,16 @@ tailVerify iv f finished =
INotify.removeWatch wd
return v
inotifycreate i cont = INotify.addWatch i evs d $ \case
inotifycreate i cont = INotify.addWatch i evs (P.takeDirectory f) $ \case
-- Ignore changes to other files in the directory.
INotify.Created { INotify.filePath = fn }
| fn /= rf -> noop
| fn /= f -> noop
INotify.MovedIn { INotify.filePath = fn }
| fn /= rf -> noop
| fn /= f -> noop
INotify.Opened { INotify.maybeFilePath = fn }
| fn /= Just rf -> noop
| fn /= Just f -> noop
INotify.Modified { INotify.maybeFilePath = fn }
| fn /= Just rf -> noop
| fn /= Just f -> noop
_ -> cont
where
evs =
@ -220,16 +216,27 @@ tailVerify iv f finished =
, INotify.Modify
]
go i (Just h) = do
go = INotify.withINotify $ \i -> do
h <- waitforfiletoexist i
tryIO (go' i h) >>= \case
Right r -> return r
Left _ -> do
maybe noop hClose h
failIncremental iv
return Nothing
go' i (Just h) = do
modified <- newEmptyTMVarIO
wd <- INotify.addWatch i [INotify.Modify] rf $ \_event ->
wd <- INotify.addWatch i [INotify.Modify] f $ \_event ->
atomically $ void $ tryPutTMVar modified ()
r <- follow h modified
INotify.removeWatch wd
return r
-- File never showed up, but we've been told it's done being
-- written to.
go _ Nothing = return (Right False)
go' _ Nothing = do
failIncremental iv
return Nothing
follow h modified = do
b <- S.hGetNonBlocking h chunk
@ -259,26 +266,28 @@ tailVerify iv f finished =
if S.null b
then do
hClose h
Right <$> finalizeIncremental iv
return Nothing
else do
updateIncremental iv b
now <- getPOSIXTime
if now - starttime > 0.5
then return (Left (deferredfinish h))
then return $ Just $
tryIO (deferredfinish h) >>= \case
Right () -> noop
Left _ -> failIncremental iv
else finish h starttime
deferredfinish h = do
b <- S.hGet h chunk
if S.null b
then do
hClose h
finalizeIncremental iv
then hClose h
else do
updateIncremental iv b
deferredfinish h
chunk = 65536
#else
tailVerify _ _ _ = return (Right False) -- not supported
tailVerify iv _ _ = do
failIncremental iv
return Nothing
#endif

View file

@ -280,13 +280,19 @@ md5Hasher = mkHasher md5 md5_context
mkIncrementalVerifier :: HashAlgorithm h => Context h -> Key -> IO IncrementalVerifier
mkIncrementalVerifier ctx key = do
v <- newIORef ctx
v <- newIORef (Just ctx)
return $ IncrementalVerifier
{ updateIncremental = modifyIORef' v . flip hashUpdate
, finalizeIncremental = do
ctx' <- readIORef v
let digest = hashFinalize ctx'
return $ sameCheckSum key (show digest)
{ updateIncremental = \b ->
modifyIORef' v $ \case
Just ctx' -> Just (hashUpdate ctx' b)
Nothing -> Nothing
, finalizeIncremental =
readIORef v >>= \case
Just ctx' -> do
let digest = hashFinalize ctx'
return $ sameCheckSum key (show digest)
Nothing -> return False
, failIncremental = writeIORef v Nothing
}
{- A varient of the SHA256E backend, for testing that needs special keys

View file

@ -50,4 +50,6 @@ data IncrementalVerifier = IncrementalVerifier
, 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.
}