diff options
Diffstat (limited to 'Annex')
| -rw-r--r-- | Annex/Content.hs | 63 |
1 files changed, 53 insertions, 10 deletions
diff --git a/Annex/Content.hs b/Annex/Content.hs index 32c164417..679b7e6b7 100644 --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -16,6 +16,7 @@ module Annex.Content ( getViaTmp, getViaTmp', checkDiskSpaceToGet, + Verify(..), prepTmp, withTmp, checkDiskSpace, @@ -61,6 +62,9 @@ import Annex.Content.Direct import Annex.ReplaceFile import Utility.LockPool import Messages.Progress +import qualified Types.Remote +import qualified Types.Backend +import qualified Backend {- Checks if a given key's content is currently present. -} inAnnex :: Key -> Annex Bool @@ -214,25 +218,64 @@ lockContent key a = do {- Runs an action, passing it the temp file to get, - and if the action succeeds, verifies the file matches - the key and moves the file into the annex as a key's content. -} -getViaTmp :: Key -> (FilePath -> Annex Bool) -> Annex Bool -getViaTmp key action = checkDiskSpaceToGet key False $ getViaTmp' key action +getViaTmp :: Verify -> Key -> (FilePath -> Annex Bool) -> Annex Bool +getViaTmp v key action = checkDiskSpaceToGet key False $ + getViaTmp' v key action {- Like getViaTmp, but does not check that there is enough disk space - for the incoming key. For use when the key content is already on disk - and not being copied into place. -} -getViaTmp' :: Key -> (FilePath -> Annex Bool) -> Annex Bool -getViaTmp' key action = do +getViaTmp' :: Verify -> Key -> (FilePath -> Annex Bool) -> Annex Bool +getViaTmp' v key action = do tmpfile <- prepTmp key ifM (action tmpfile) - ( do - moveAnnex key tmpfile - logStatus key InfoPresent - return True - -- the tmp file is left behind, in case caller wants - -- to resume its transfer + ( ifM (verifyKeyContent v key tmpfile) + ( do + moveAnnex key tmpfile + logStatus key InfoPresent + return True + , do + warning "verification of content failed" + liftIO $ nukeFile tmpfile + return False + ) + -- On transfer failure, the tmp file is left behind, in case + -- caller wants to resume its transfer , return False ) +{- Verifies that a file is the expected content of a key. + - + - Most keys have a known size, and if so, the file size is checked. + - This is not expensive, so is always done. + - + - When the key's backend allows verifying the content (eg via checksum), + - it is checked. This is an expensive check, so configuration can prevent + - it, for either a particular remote or always. + -} +verifyKeyContent :: Verify -> Key -> FilePath -> Annex Bool +verifyKeyContent v k f = verifysize <&&> verifycontent + where + verifysize = case Types.Key.keySize k of + Nothing -> return True + Just size -> do + size' <- liftIO $ catchDefaultIO 0 $ getFileSize f + return (size' == size) + verifycontent = ifM (shouldVerify v) + ( case Types.Backend.verifyKeyContent =<< Backend.maybeLookupBackendName (Types.Key.keyBackendName k) of + Nothing -> return True + Just verifier -> verifier k f + , return True + ) + +data Verify = AlwaysVerify | RemoteVerify Remote | DefaultVerify + +shouldVerify :: Verify -> Annex Bool +shouldVerify AlwaysVerify = return True +shouldVerify DefaultVerify = annexVerify <$> Annex.getGitConfig +shouldVerify (RemoteVerify r) = shouldVerify DefaultVerify + <&&> pure (remoteAnnexVerify (Types.Remote.gitconfig r)) + {- Checks if there is enough free disk space to download a key - to its temp file. - |