{- 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)
-- 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)
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
)
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
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.
--
-- 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
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
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
chunk = 65536
#else
-tailVerify iv _ _ = failIncremental iv
+tailVerify iv _ _ = unableIncremental iv
#endif
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
| 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
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
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.
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
projects / git-annex.git / commitdiff