implement isCryptographicallySecureKey for VURL

Considerable difficulty to work around an import cycle. Had to move the
list of backends (except for VURL) to Backend.Variety to VURL could use
it.

Sponsored-by: Kevin Mueller on Patreon

Annex/Content.hs

@@ -439,7 +439,7 @@ moveAnnex key af src = ifM (checkSecureHashes' key)
 	alreadyhave = liftIO $ R.removeLink src
 
 checkSecureHashes :: Key -> Annex (Maybe String)
-checkSecureHashes key = ifM (Backend.isCryptographicallySecure key)
+checkSecureHashes key = ifM (Backend.isCryptographicallySecureKey key)
 	( return Nothing
 	, ifM (annexSecureHashesOnly <$> Annex.getGitConfig)
 		( return $ Just $ "annex.securehashesonly blocked adding " ++ decodeBS (formatKeyVariety (fromKey keyVariety key)) ++ " key"

Annex/Transfer.hs

@@ -42,7 +42,7 @@ import Types.WorkerPool
 import Annex.WorkerPool
 import Annex.TransferrerPool
 import Annex.StallDetection
-import Backend (isCryptographicallySecure)
+import Backend (isCryptographicallySecureKey)
 import Types.StallDetection
 import qualified Utility.RawFilePath as R
 
@@ -276,10 +276,10 @@ runTransferrer sd r k afile retrydecider direction _witness =
 preCheckSecureHashes :: Observable v => Key -> Maybe Backend -> Annex v -> Annex v
 preCheckSecureHashes k meventualbackend a = case meventualbackend of
 	Just eventualbackend -> go
-		(Types.Backend.isCryptographicallySecure eventualbackend)
+		(pure (Types.Backend.isCryptographicallySecure eventualbackend))
 		(Types.Backend.backendVariety eventualbackend)
 	Nothing -> go
-		(isCryptographicallySecure k)
+		(isCryptographicallySecureKey k)
 		(fromKey keyVariety k)
   where
 	go checksecure variety = ifM checksecure

Backend.hs

@@ -18,10 +18,12 @@ module Backend (
 	lookupBuiltinBackendVariety,
 	maybeLookupBackendVariety,
 	isStableKey,
+	isCryptographicallySecureKey,
 	isCryptographicallySecure,
-	isCryptographicallySecure',
 ) where
 
+import qualified Data.Map as M
+
 import Annex.Common
 import qualified Annex
 import Annex.CheckAttr
@@ -29,18 +31,12 @@ import Types.Key
 import Types.KeySource
 import qualified Types.Backend as B
 import Utility.Metered
-
--- When adding a new backend, import it here and add it to the builtinList.
-import qualified Backend.Hash
-import qualified Backend.WORM
-import qualified Backend.URL
-import qualified Backend.External
-
-import qualified Data.Map as M
+import Backend.Variety
+import qualified Backend.VURL
 
 {- Built-in backends. Does not include externals. -}
 builtinList :: [Backend]
-builtinList = Backend.Hash.backends ++ Backend.WORM.backends ++ Backend.URL.backends
+builtinList = regularBackendList ++ Backend.VURL.backends
 
 {- The default hashing backend. This must use a cryptographically secure
  - hash. -}
@@ -107,25 +103,24 @@ lookupBuiltinBackendVariety :: KeyVariety -> Backend
 lookupBuiltinBackendVariety v = fromMaybe (giveup (unknownBackendVarietyMessage v)) $
 	maybeLookupBuiltinBackendVariety v
 
-maybeLookupBackendVariety :: KeyVariety -> Annex (Maybe Backend)
-maybeLookupBackendVariety (ExternalKey s hasext) =
-	Just <$> Backend.External.makeBackend s hasext
-maybeLookupBackendVariety v = 
-	pure $ M.lookup v varietyMap
-
 maybeLookupBuiltinBackendVariety :: KeyVariety -> Maybe Backend
 maybeLookupBuiltinBackendVariety v = M.lookup v varietyMap
 
+maybeLookupBackendVariety :: KeyVariety -> Annex (Maybe Backend)
+maybeLookupBackendVariety v = maybeLookupBackendVarietyMap v varietyMap
+
 varietyMap :: M.Map KeyVariety Backend
-varietyMap = M.fromList $ zip (map B.backendVariety builtinList) builtinList
+varietyMap = makeVarietyMap builtinList
 
 isStableKey :: Key -> Annex Bool
 isStableKey k = maybe False (`B.isStableKey` k) 
 	<$> maybeLookupBackendVariety (fromKey keyVariety k)
 
-isCryptographicallySecure :: Key -> Annex Bool
-isCryptographicallySecure k = maybe (pure False) isCryptographicallySecure'
+isCryptographicallySecureKey :: Key -> Annex Bool
+isCryptographicallySecureKey k = maybe 
+	(pure False)
+	(\b -> B.isCryptographicallySecureKey b k)
 	=<< maybeLookupBackendVariety (fromKey keyVariety k)
 
-isCryptographicallySecure' :: Backend -> Annex Bool
-isCryptographicallySecure' = B.isCryptographicallySecure
+isCryptographicallySecure :: Backend -> Bool
+isCryptographicallySecure = B.isCryptographicallySecure

Backend/External.hs

@@ -72,7 +72,8 @@ makeBackend' ebname@(ExternalBackendName bname) hasext (Right p) = do
 		, canUpgradeKey = Nothing
 		, fastMigrate = Nothing
 		, isStableKey = const isstable
-		, isCryptographicallySecure = pure iscryptographicallysecure
+		, isCryptographicallySecure = iscryptographicallysecure
+		, isCryptographicallySecureKey = const (pure iscryptographicallysecure)
 		}
 makeBackend' ebname hasext (Left _) = return $ unavailBackend ebname hasext
 
@@ -86,7 +87,8 @@ unavailBackend (ExternalBackendName bname) hasext =
 		, canUpgradeKey = Nothing
 		, fastMigrate = Nothing
 		, isStableKey = const False
-		, isCryptographicallySecure = pure False
+		, isCryptographicallySecure = False
+		, isCryptographicallySecureKey = const (pure False)
 		}
 
 genKeyExternal :: ExternalBackendName -> HasExt -> KeySource -> MeterUpdate -> Annex Key

Backend/Hash.hs

@@ -81,7 +81,9 @@ genBackend hash = Backend
 	, canUpgradeKey = Just needsUpgrade
 	, fastMigrate = Just trivialMigrate
 	, isStableKey = const True
-	, isCryptographicallySecure = pure $ cryptographicallySecure hash
+	, isCryptographicallySecure = cryptographicallySecure hash
+	, isCryptographicallySecureKey = const $ pure $
+		cryptographicallySecure hash
 	}
 
 genBackendE :: Hash -> Backend

Backend/URL.hs

@@ -1,5 +1,4 @@
-{- git-annex "URL" and "VURL" backends -- keys whose content is
- - available from urls.
+{- git-annex URL backend -- keys whose content is available from urls.
  -
  - Copyright 2011-2024 Joey Hess <id@joeyh.name>
  -
@@ -15,10 +14,9 @@ import Annex.Common
 import Types.Key
 import Types.Backend
 import Backend.Utilities
-import Logs.EquivilantKeys
 
 backends :: [Backend]
-backends = [backendURL, backendVURL]
+backends = [backendURL]
 
 backendURL :: Backend
 backendURL = Backend
@@ -31,25 +29,8 @@ backendURL = Backend
 	-- The content of an url can change at any time, so URL keys are
 	-- not stable.
 	, isStableKey = const False
-	, isCryptographicallySecure = pure False
-	}
-
-backendVURL :: Backend
-backendVURL = Backend
-	{ backendVariety = VURLKey
-	, genKey = Nothing
-	, verifyKeyContent = Nothing -- TODO
-	, verifyKeyContentIncrementally = Nothing -- TODO
-	, canUpgradeKey = Nothing
-	, fastMigrate = Nothing
-	-- Even if a hash is recorded on initial download from the web and
-	-- is used to verify every subsequent transfer including other
-	-- downloads from the web, in a split-brain situation there
-	-- can be more than one hash and different versions of the content.
-	-- So the content is not stable.
-	, isStableKey = const False
-	, isCryptographicallySecure = pure False 
-	-- TODO it is when all recorded hashes are
+	, isCryptographicallySecure = False
+	, isCryptographicallySecureKey = const (pure False)
 	}
 
 {- Every unique url has a corresponding key. -}

Backend/Utilities.hs

@@ -1,6 +1,6 @@
 {- git-annex backend utilities
  -
- - Copyright 2012-2020 Joey Hess <id@joeyh.name>
+ - Copyright 2012-2024 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}

Backend/VURL.hs

@@ -0,0 +1,59 @@
+{- git-annex VURL backend -- like URL, but with hash-based verification
+ - of transfers between git-annex repositories.
+ -
+ - Copyright 2024 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+module Backend.VURL (
+	backends,
+) where
+
+import Annex.Common
+import Types.Key
+import Types.Backend
+import Logs.EquivilantKeys
+import Backend.Variety
+
+backends :: [Backend]
+backends = [backendVURL]
+
+backendVURL :: Backend
+backendVURL = Backend
+	{ backendVariety = VURLKey
+	, genKey = Nothing
+	, verifyKeyContent = Nothing -- TODO
+	, verifyKeyContentIncrementally = Nothing -- TODO
+	, canUpgradeKey = Nothing
+	, fastMigrate = Nothing
+	-- Even if a hash is recorded on initial download from the web and
+	-- is used to verify every subsequent transfer including other
+	-- downloads from the web, in a split-brain situation there
+	-- can be more than one hash and different versions of the content.
+	-- So the content is not stable.
+	, isStableKey = const False
+	-- Not all keys using this backend are necessarily 
+	-- cryptographically secure.
+	, isCryptographicallySecure = False
+	-- A key is secure when all recorded equivilant keys are.
+	-- If there are none recorded yet, it's secure because when
+	-- downloaded, an equivilant key that is cryptographically secure
+	-- will be constructed then.
+	, isCryptographicallySecureKey = \k ->
+		equivkeys k >>= \case
+			[] -> return True
+			l -> do
+				let check ek = getbackend ek >>= \case
+					Nothing -> pure False
+					Just b -> isCryptographicallySecureKey b ek
+				allM check l
+	}
+  where
+	equivkeys k = filter allowedequiv <$> getEquivilantKeys k
+	-- Don't allow using VURL keys as equivilant keys, because that
+	-- could let a crafted git-annex branch cause an infinite loop.
+	allowedequiv ek = fromKey keyVariety ek /= VURLKey
+	varietymap = makeVarietyMap regularBackendList
+	getbackend ek = maybeLookupBackendVarietyMap (fromKey keyVariety ek) varietymap
+

Backend/Variety.hs

@@ -0,0 +1,35 @@
+{- git-annex backend varieties
+ -
+ - Copyright 2012-2024 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+module Backend.Variety where
+
+import qualified Data.Map as M
+
+import Annex.Common
+import Types.Key
+import Types.Backend
+import qualified Backend.External
+
+-- When adding a new backend, import it here and add it to the builtinList.
+import qualified Backend.Hash
+import qualified Backend.WORM
+import qualified Backend.URL
+
+{- Regular backends. Does not include externals or VURL. -}
+regularBackendList :: [Backend]
+regularBackendList = Backend.Hash.backends 
+	++ Backend.WORM.backends 
+	++ Backend.URL.backends
+
+makeVarietyMap :: [Backend] -> M.Map KeyVariety Backend
+makeVarietyMap l = M.fromList $ zip (map backendVariety l) l
+
+maybeLookupBackendVarietyMap :: KeyVariety -> M.Map KeyVariety Backend -> Annex (Maybe Backend)
+maybeLookupBackendVarietyMap (ExternalKey s hasext) _varitymap =
+	Just <$> Backend.External.makeBackend s hasext
+maybeLookupBackendVarietyMap v varietymap = 
+	pure $ M.lookup v varietymap

Backend/WORM.hs

@@ -32,7 +32,8 @@ backend = Backend
 	, canUpgradeKey = Just needsUpgrade
 	, fastMigrate = Just removeProblemChars
 	, isStableKey = const True
-	, isCryptographicallySecure = pure False
+	, isCryptographicallySecure = False
+	, isCryptographicallySecureKey = const (pure False)
 	}
 
 {- The key includes the file size, modification time, and the

Command/Fsck.hs

@@ -328,8 +328,8 @@ verifyLocationLog key keystatus ai = do
 	{- Warn when annex.securehashesonly is set and content using an 
 	 - insecure hash is present. This should only be able to happen
 	 - if the repository already contained the content before the
-	 - config was set. -}
-	whenM (pure present <&&> (not <$> Backend.isCryptographicallySecure key)) $
+	 - config was set, or of course if a hash was broken. -}
+	whenM (pure present <&&> (not <$> Backend.isCryptographicallySecureKey key)) $
 		whenM (annexSecureHashesOnly <$> Annex.getGitConfig) $
 			warning $ "** Despite annex.securehashesonly being set, " <> QuotedPath obj <> " has content present in the annex using an insecure " <> UnquotedString (decodeBS (formatKeyVariety (fromKey keyVariety key))) <> " key"
 

Limit.hs

@@ -575,7 +575,7 @@ addSecureHash = addLimit $ Right limitSecureHash
 
 limitSecureHash :: MatchFiles Annex
 limitSecureHash = MatchFiles
-	{ matchAction = const $ checkKey isCryptographicallySecure
+	{ matchAction = const $ checkKey isCryptographicallySecureKey
 	, matchNeedsFileName = False
 	, matchNeedsFileContent = False
 	, matchNeedsKey = True

Remote/Web.hs

@@ -171,10 +171,9 @@ downloadKey urlincludeexclude key _af dest p vc =
 		-- Make sure to pick a backend that is cryptographically
 		-- secure.
 		db <- defaultBackend
-		b <- ifM (isCryptographicallySecure' db)
-			( pure db
-			, pure defaultHashBackend
-			)
+		let b = if isCryptographicallySecure db
+			then db
+			else defaultHashBackend
 		showSideAction (UnquotedString descChecksum)
 		(hashk, _) <- genKey ks nullMeterUpdate b
 		unless (hashk `elem` eks) $

Types/Backend.hs

@@ -2,7 +2,7 @@
  -
  - Most things should not need this, using Types instead
  -
- - Copyright 2010-2021 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2024 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
@@ -33,8 +33,11 @@ data BackendA a = Backend
 	-- Checks if a key is known (or assumed) to always refer to the
 	-- same data.
 	, isStableKey :: Key -> Bool
+	-- Are all keys using this backend verified using a cryptographically
+	-- secure hash?
+	, isCryptographicallySecure :: Bool
 	-- Checks if a key is verified using a cryptographically secure hash.
-	, isCryptographicallySecure :: a Bool
+	, isCryptographicallySecureKey :: Key -> a Bool
 	}
 
 instance Show (BackendA a) where

doc/todo/verified_relaxed_urls.mdwn

@@ -85,8 +85,8 @@ cryptographically secure hashes were recorded for a VURL. But of course,
 which hashes are considered secure can change. Still, let's start by
 only allowing currently secure hashes to be used for VURLs. This way,
 when there are multiple hashes recorded for a VURL, they will all be
-cryptographically secure, and so the VURL can have
-`isCryptographicallySecure = True`. If any of the hashes later becomes
+cryptographically secure normally, and so the VURL can be considered
+cryptographically secure itself. If any of the hashes later becomes
 broken, the VURL will no longer be treated as cryptographically secure,
 because the broken hash can be used to verify its content.
 In that case, the user would probably just migrate to a hash-based key,

git-annex.cabal

@@ -583,6 +583,8 @@ Executable git-annex
     Backend.Hash
     Backend.URL
     Backend.Utilities
+    Backend.Variety
+    Backend.VURL
     Backend.WORM
     Benchmark
     Build.BundledPrograms