From de482c7eebef3ee8df01a7e46ef76e90326b50ef Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 27 Jul 2021 14:07:23 -0400 Subject: [PATCH] move verifyKeyContent to Annex.Verify The goal is that Database.Keys be able to use it; it can't use Annex.Content.Presence due to an import loop. Several other things also needed to be moved to Annex.Verify as a conseqence. --- Annex/Content.hs | 3 +- Annex/Content/Presence.hs | 64 +------------------------- Annex/CopyFile.hs | 1 - Annex/Verify.hs | 86 ++++++++++++++++++++++++++++++++++- Backend.hs | 18 -------- P2P/Annex.hs | 3 +- Remote/Helper/ExportImport.hs | 2 +- Remote/Helper/P2P.hs | 2 +- 8 files changed, 91 insertions(+), 88 deletions(-) diff --git a/Annex/Content.hs b/Annex/Content.hs index 3a4759a22b..7c95621031 100644 --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -66,6 +66,7 @@ import Annex.Common import Annex.Content.Presence import Annex.Content.LowLevel import Annex.Content.PointerFile +import Annex.Verify import qualified Git import qualified Annex import qualified Annex.Queue @@ -253,7 +254,7 @@ getViaTmpFromDisk rsp v key af action = checkallowed $ do -- RetrievalSecurityPolicy would cause verification to always fail. checkallowed a = case rsp of RetrievalAllKeysSecure -> a - RetrievalVerifiableKeysSecure -> ifM (Backend.isVerifiable key) + RetrievalVerifiableKeysSecure -> ifM (isVerifiable key) ( a , ifM (annexAllowUnverifiedDownloads <$> Annex.getGitConfig) ( a diff --git a/Annex/Content/Presence.hs b/Annex/Content/Presence.hs index b8f4fc635a..bfcdec694c 100644 --- a/Annex/Content/Presence.hs +++ b/Annex/Content/Presence.hs @@ -17,11 +17,6 @@ module Annex.Content.Presence ( isUnmodified, isUnmodified', isUnmodifiedCheap, - verifyKeyContent, - VerifyConfig(..), - Verification(..), - unVerified, - warnUnverifiableInsecure, contentLockFile, ) where @@ -29,15 +24,10 @@ import Annex.Common import qualified Annex import Annex.Verify import Annex.LockPool -import Annex.WorkerPool -import Types.Remote (unVerified, Verification(..), RetrievalSecurityPolicy(..)) -import qualified Types.Backend -import qualified Backend import qualified Database.Keys -import Types.Key +import Types.Remote import Annex.InodeSentinal import Utility.InodeCache -import Types.WorkerPool import qualified Utility.RawFilePath as R #ifdef mingw32_HOST_OS @@ -189,55 +179,3 @@ isUnmodifiedCheap' key fc = isUnmodifiedCheap'' fc isUnmodifiedCheap'' :: InodeCache -> [InodeCache] -> Annex Bool isUnmodifiedCheap'' fc ic = anyM (compareInodeCaches fc) ic - -{- Verifies that a file is the expected content of a key. - - - - Configuration can prevent verification, for either a - - particular remote or always, unless the RetrievalSecurityPolicy - - requires verification. - - - - Most keys have a known size, and if so, the file size is checked. - - - - When the key's backend allows verifying the content (via checksum), - - it is checked. - - - - If the RetrievalSecurityPolicy requires verification and the key's - - backend doesn't support it, the verification will fail. - -} -verifyKeyContent :: RetrievalSecurityPolicy -> VerifyConfig -> Verification -> Key -> RawFilePath -> Annex Bool -verifyKeyContent rsp v verification k f = case (rsp, verification) of - (_, Verified) -> return True - (RetrievalVerifiableKeysSecure, _) -> ifM (Backend.isVerifiable k) - ( verify - , ifM (annexAllowUnverifiedDownloads <$> Annex.getGitConfig) - ( verify - , warnUnverifiableInsecure k >> return False - ) - ) - (_, UnVerified) -> ifM (shouldVerify v) - ( verify - , return True - ) - (_, MustVerify) -> verify - where - verify = enteringStage VerifyStage $ verifysize <&&> verifycontent - verifysize = case fromKey keySize k of - Nothing -> return True - Just size -> do - size' <- liftIO $ catchDefaultIO 0 $ getFileSize f - return (size' == size) - verifycontent = Backend.maybeLookupBackendVariety (fromKey keyVariety k) >>= \case - Nothing -> return True - Just b -> case Types.Backend.verifyKeyContent b of - Nothing -> return True - Just verifier -> verifier k f - -warnUnverifiableInsecure :: Key -> Annex () -warnUnverifiableInsecure k = warning $ unwords - [ "Getting " ++ kv ++ " keys with this remote is not secure;" - , "the content cannot be verified to be correct." - , "(Use annex.security.allow-unverified-downloads to bypass" - , "this safety check.)" - ] - where - kv = decodeBS (formatKeyVariety (fromKey keyVariety k)) diff --git a/Annex/CopyFile.hs b/Annex/CopyFile.hs index 63eb1a95f1..07f389995e 100644 --- a/Annex/CopyFile.hs +++ b/Annex/CopyFile.hs @@ -16,7 +16,6 @@ import Utility.CopyFile import Utility.FileMode import Utility.Touch import Types.Backend -import Backend import Annex.Verify import Control.Concurrent diff --git a/Annex/Verify.hs b/Annex/Verify.hs index 6d1a6ab37f..826d0e7f40 100644 --- a/Annex/Verify.hs +++ b/Annex/Verify.hs @@ -5,11 +5,28 @@ - Licensed under the GNU AGPL version 3 or higher. -} -module Annex.Verify where +module Annex.Verify ( + VerifyConfig(..), + shouldVerify, + verifyKeyContent, + Verification(..), + unVerified, + warnUnverifiableInsecure, + isVerifiable, + startVerifyKeyContentIncrementally, + IncrementalVerifier(..), +) where import Annex.Common import qualified Annex import qualified Types.Remote +import qualified Types.Backend +import Types.Backend (IncrementalVerifier(..)) +import qualified Backend +import Types.Remote (unVerified, Verification(..), RetrievalSecurityPolicy(..)) +import Annex.WorkerPool +import Types.WorkerPool +import Types.Key data VerifyConfig = AlwaysVerify | NoVerify | RemoteVerify Remote | DefaultVerify @@ -23,3 +40,70 @@ shouldVerify (RemoteVerify r) = -- Export remotes are not key/value stores, so always verify -- content from them even when verification is disabled. <||> Types.Remote.isExportSupported r + +{- Verifies that a file is the expected content of a key. + - + - Configuration can prevent verification, for either a + - particular remote or always, unless the RetrievalSecurityPolicy + - requires verification. + - + - Most keys have a known size, and if so, the file size is checked. + - + - When the key's backend allows verifying the content (via checksum), + - it is checked. + - + - If the RetrievalSecurityPolicy requires verification and the key's + - backend doesn't support it, the verification will fail. + -} +verifyKeyContent :: RetrievalSecurityPolicy -> VerifyConfig -> Verification -> Key -> RawFilePath -> Annex Bool +verifyKeyContent rsp v verification k f = case (rsp, verification) of + (_, Verified) -> return True + (RetrievalVerifiableKeysSecure, _) -> ifM (isVerifiable k) + ( verify + , ifM (annexAllowUnverifiedDownloads <$> Annex.getGitConfig) + ( verify + , warnUnverifiableInsecure k >> return False + ) + ) + (_, UnVerified) -> ifM (shouldVerify v) + ( verify + , return True + ) + (_, MustVerify) -> verify + where + verify = enteringStage VerifyStage $ verifysize <&&> verifycontent + verifysize = case fromKey keySize k of + Nothing -> return True + Just size -> do + size' <- liftIO $ catchDefaultIO 0 $ getFileSize f + return (size' == size) + verifycontent = Backend.maybeLookupBackendVariety (fromKey keyVariety k) >>= \case + Nothing -> return True + Just b -> case Types.Backend.verifyKeyContent b of + Nothing -> return True + Just verifier -> verifier k f + +warnUnverifiableInsecure :: Key -> Annex () +warnUnverifiableInsecure k = warning $ unwords + [ "Getting " ++ kv ++ " keys with this remote is not secure;" + , "the content cannot be verified to be correct." + , "(Use annex.security.allow-unverified-downloads to bypass" + , "this safety check.)" + ] + where + kv = decodeBS (formatKeyVariety (fromKey keyVariety k)) + +isVerifiable :: Key -> Annex Bool +isVerifiable k = maybe False (isJust . Types.Backend.verifyKeyContent) + <$> Backend.maybeLookupBackendVariety (fromKey keyVariety k) + +startVerifyKeyContentIncrementally :: VerifyConfig -> Key -> Annex (Maybe IncrementalVerifier) +startVerifyKeyContentIncrementally verifyconfig k = + ifM (shouldVerify verifyconfig) + ( Backend.maybeLookupBackendVariety (fromKey keyVariety k) >>= \case + Just b -> case Types.Backend.verifyKeyContentIncrementally b of + Just v -> Just <$> v k + Nothing -> return Nothing + Nothing -> return Nothing + , return Nothing + ) diff --git a/Backend.hs b/Backend.hs index 76ba12313a..d327fde3d3 100644 --- a/Backend.hs +++ b/Backend.hs @@ -16,14 +16,11 @@ module Backend ( maybeLookupBackendVariety, isStableKey, isCryptographicallySecure, - isVerifiable, - startVerifyKeyContentIncrementally, ) where import Annex.Common import qualified Annex import Annex.CheckAttr -import Annex.Verify import Types.Key import Types.KeySource import qualified Types.Backend as B @@ -125,18 +122,3 @@ isStableKey k = maybe False (`B.isStableKey` k) isCryptographicallySecure :: Key -> Annex Bool isCryptographicallySecure k = maybe False (`B.isCryptographicallySecure` k) <$> maybeLookupBackendVariety (fromKey keyVariety k) - -isVerifiable :: Key -> Annex Bool -isVerifiable k = maybe False (isJust . B.verifyKeyContent) - <$> maybeLookupBackendVariety (fromKey keyVariety k) - -startVerifyKeyContentIncrementally :: VerifyConfig -> Key -> Annex (Maybe B.IncrementalVerifier) -startVerifyKeyContentIncrementally verifyconfig k = - ifM (shouldVerify verifyconfig) - ( maybeLookupBackendVariety (fromKey keyVariety k) >>= \case - Just b -> case B.verifyKeyContentIncrementally b of - Just v -> Just <$> v k - Nothing -> return Nothing - Nothing -> return Nothing - , return Nothing - ) diff --git a/P2P/Annex.hs b/P2P/Annex.hs index b3b5d1f5b7..5f0e174666 100644 --- a/P2P/Annex.hs +++ b/P2P/Annex.hs @@ -23,8 +23,7 @@ import P2P.IO import Logs.Location import Types.NumCopies import Utility.Metered -import Types.Backend (IncrementalVerifier(..)) -import Backend +import Annex.Verify import Control.Monad.Free import Control.Concurrent.STM diff --git a/Remote/Helper/ExportImport.hs b/Remote/Helper/ExportImport.hs index dbe6ef1ffe..77351b3077 100644 --- a/Remote/Helper/ExportImport.hs +++ b/Remote/Helper/ExportImport.hs @@ -13,7 +13,7 @@ import Annex.Common import Types.Remote import Types.Key import Types.ProposedAccepted -import Backend +import Annex.Verify import Remote.Helper.Encryptable (encryptionIsEnabled) import qualified Database.Export as Export import qualified Database.ContentIdentifier as ContentIdentifier diff --git a/Remote/Helper/P2P.hs b/Remote/Helper/P2P.hs index 4d048c8bc9..9e00101c87 100644 --- a/Remote/Helper/P2P.hs +++ b/Remote/Helper/P2P.hs @@ -17,7 +17,7 @@ import Annex.Content import Messages.Progress import Utility.Metered import Types.NumCopies -import Backend +import Annex.Verify import Control.Concurrent -- 2.39.5