implement URL to VURL migration

This needs the content to be present in order to hash it. But it's not
possible for a module used by Backend.URL to call inAnnex because that
would entail a dependency loop. So instead, rely on the fact that
Command.Migrate calls inAnnex before performing a migration.

But, Command.ExamineKey calls fastMigrate and the key may or may not
exist, and it's not wanting to actually perform a migration in any case.
To handle that, had to add an additional value to fastMigrate to
indicate whether the content is inAnnex.

Factored generateEquivilantKey out of Remote.Web.

Note that migrateFromURLToVURL hardcodes use of the SHA256E backend.
It would have been difficult not to, given all the dependency loop
issues. But --backend and annex.backend are used to tell git-annex
migrate to use VURL in any case, so there's no config knob that
the user could expect to configure that.

Sponsored-by: Brock Spratlen on Patreon

Backend.hs

@@ -38,11 +38,6 @@ import qualified Backend.VURL
 builtinList :: [Backend]
 builtinList = regularBackendList ++ Backend.VURL.backends
 
-{- The default hashing backend. This must use a cryptographically secure
- - hash. -}
-defaultHashBackend :: Backend
-defaultHashBackend = Prelude.head builtinList
-
 {- Backend to use by default when generating a new key. Takes git config
  - and --backend option into account. -}
 defaultBackend :: Annex Backend

Backend/Hash.hs

@@ -53,8 +53,10 @@ cryptographicallySecure (Blake2spHash _) = True
 cryptographicallySecure SHA1Hash = False
 cryptographicallySecure MD5Hash = False
 
-{- Order is slightly significant; want SHA256 first, and more general
- - sizes earlier. -}
+{- Order is significant. The first hash is the default one that git-annex
+ - uses, and must be cryptographically secure. 
+ -
+ - Also, want more common sizes earlier than uncommon sizes. -}
 hashes :: [Hash]
 hashes = concat 
 	[ map (SHA2Hash . HashSize) [256, 512, 224, 384]
@@ -167,8 +169,8 @@ needsUpgrade key = or
 	, not (hasExt (fromKey keyVariety key)) && keyHash key /= S.fromShort (fromKey keyName key)
 	]
 
-trivialMigrate :: Key -> Backend -> AssociatedFile -> Annex (Maybe Key)
-trivialMigrate oldkey newbackend afile = trivialMigrate' oldkey newbackend afile
+trivialMigrate :: Key -> Backend -> AssociatedFile -> Bool -> Annex (Maybe Key)
+trivialMigrate oldkey newbackend afile _inannex = trivialMigrate' oldkey newbackend afile
 	<$> (annexMaxExtensionLength <$> Annex.getGitConfig)
 
 trivialMigrate' :: Key -> Backend -> AssociatedFile -> Maybe Int -> Maybe Key

Backend/URL.hs

@@ -14,6 +14,7 @@ import Annex.Common
 import Types.Key
 import Types.Backend
 import Backend.Utilities
+import Backend.VURL.Utilities (migrateFromURLToVURL)
 
 backends :: [Backend]
 backends = [backendURL]
@@ -25,7 +26,7 @@ backendURL = Backend
 	, verifyKeyContent = Nothing
 	, verifyKeyContentIncrementally = Nothing
 	, canUpgradeKey = Nothing
-	, fastMigrate = Nothing
+	, fastMigrate = Just migrateFromURLToVURL
 	-- The content of an url can change at any time, so URL keys are
 	-- not stable.
 	, isStableKey = const False

Backend/VURL.hs

@@ -99,4 +99,3 @@ backendVURL = Backend
 	allowedequiv ek = fromKey keyVariety ek /= VURLKey
 	varietymap = makeVarietyMap regularBackendList
 	getbackend ek = maybeLookupBackendVarietyMap (fromKey keyVariety ek) varietymap
-

Backend/VURL/Utilities.hs

@@ -0,0 +1,51 @@
+{- git-annex VURL backend utilities
+ -
+ - Copyright 2024 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+module Backend.VURL.Utilities where
+
+import Annex.Common
+import Types.Key
+import Types.Backend
+import Types.KeySource
+import Logs.EquivilantKeys
+import qualified Backend.Hash
+import Utility.Metered
+
+migrateFromURLToVURL :: Key -> Backend -> AssociatedFile -> Bool -> Annex (Maybe Key)
+migrateFromURLToVURL oldkey newbackend _af inannex
+	| inannex && fromKey keyVariety oldkey == URLKey && backendVariety newbackend == VURLKey = do
+		let newkey = mkKey $ const $
+			(keyData oldkey)
+				{ keyVariety = VURLKey }
+		contentfile <- calcRepo (gitAnnexLocation oldkey)
+		generateEquivilantKey hashbackend contentfile >>= \case
+			Nothing -> return Nothing
+			Just ek -> do
+				setEquivilantKey newkey ek
+				return (Just newkey)
+	| otherwise = do
+		liftIO $ print ("migrateFromURL", inannex, fromKey keyVariety oldkey)
+		return Nothing
+  where
+	-- Relies on the first hash being cryptographically secure, and the
+	-- default hash used by git-annex.
+	hashbackend = Prelude.head Backend.Hash.backends
+
+-- The Backend must use a cryptographically secure hash.
+generateEquivilantKey :: Backend -> RawFilePath -> Annex (Maybe Key)
+generateEquivilantKey b f =
+	case genKey b of
+		Just genkey -> do
+			showSideAction (UnquotedString Backend.Hash.descChecksum)
+			Just <$> genkey source nullMeterUpdate
+		Nothing -> return Nothing
+  where
+	source = KeySource
+		{ keyFilename = mempty -- avoid adding any extension
+		, contentLocation = f
+		, inodeCache = Nothing
+		}

Backend/Variety.hs

@@ -25,6 +25,10 @@ regularBackendList = Backend.Hash.backends
 	++ Backend.WORM.backends 
 	++ Backend.URL.backends
 
+{- The default hashing backend. -}
+defaultHashBackend :: Backend
+defaultHashBackend = Prelude.head regularBackendList
+
 makeVarietyMap :: [Backend] -> M.Map KeyVariety Backend
 makeVarietyMap l = M.fromList $ zip (map backendVariety l) l
 

Backend/WORM.hs

@@ -59,8 +59,8 @@ needsUpgrade :: Key -> Bool
 needsUpgrade key =
 	any (`S8.elem` S.fromShort (fromKey keyName key)) [' ', '\r']
 
-removeProblemChars :: Key -> Backend -> AssociatedFile -> Annex (Maybe Key)
-removeProblemChars oldkey newbackend _
+removeProblemChars :: Key -> Backend -> AssociatedFile -> Bool -> Annex (Maybe Key)
+removeProblemChars oldkey newbackend _ _
 	| migratable = return $ Just $ alterKey oldkey $ \d -> d
 		{ keyName = S.toShort $ encodeBS $ reSanitizeKeyName $ decodeBS $ S.fromShort $ keyName d }
 	| otherwise = return Nothing

Command/ExamineKey.hs

@@ -78,6 +78,6 @@ run o _ input = do
 		Just v -> getParsed v >>= \b ->
 			maybeLookupBackendVariety (fromKey keyVariety ik) >>= \case
 				Just ib -> case fastMigrate ib of
-					Just fm -> fromMaybe ik <$> fm ik b af
+					Just fm -> fromMaybe ik <$> fm ik b af False
 					Nothing -> pure ik
 				Nothing -> pure ik

Command/Migrate.hs

@@ -149,7 +149,7 @@ perform onlytweaksize o file oldkey oldkeyrec oldbackend newbackend = go =<< gen
 			}
 		newkey <- fst <$> genKey source nullMeterUpdate newbackend
 		return $ Just (newkey, False)
-	genkey (Just fm) = fm oldkey newbackend afile >>= \case
+	genkey (Just fm) = fm oldkey newbackend afile True >>= \case
 		Just newkey -> return (Just (newkey, True))
 		Nothing -> genkey Nothing
 	tweaksize k

Remote/Web.hs

@@ -12,7 +12,6 @@ import Types.Remote
 import Types.ProposedAccepted
 import Types.Creds
 import Types.Key
-import Types.KeySource
 import Remote.Helper.Special
 import Remote.Helper.ExportImport
 import qualified Git
@@ -31,7 +30,7 @@ import Annex.SpecialRemote.Config
 import Logs.Remote
 import Logs.EquivilantKeys
 import Backend
-import Backend.Hash (descChecksum)
+import Backend.VURL.Utilities (generateEquivilantKey)
 
 import qualified Data.Map as M
 
@@ -175,17 +174,12 @@ downloadKey urlincludeexclude key _af dest p vc =
 		let b = if isCryptographicallySecure db
 			then db
 			else defaultHashBackend
-		showSideAction (UnquotedString descChecksum)
-		(hashk, _) <- genKey ks nullMeterUpdate b
-		unless (hashk `elem` eks) $
-			setEquivilantKey key hashk
+		generateEquivilantKey b (toRawFilePath dest) >>= \case
+			Nothing -> return Nothing
+			Just ek -> do
+				unless (ek `elem` eks) $
+					setEquivilantKey key ek
 				return (Just Verified)
-	  where
-		ks = KeySource
-			{ keyFilename = mempty -- avoid adding any extension
-			, contentLocation = toRawFilePath dest
-			, inodeCache = Nothing
-			}
 
 uploadKey :: Key -> AssociatedFile -> MeterUpdate -> Annex ()
 uploadKey _ _ _ = giveup "upload to web not supported"

Types/Backend.hs

@@ -29,7 +29,9 @@ data BackendA a = Backend
 	, canUpgradeKey :: Maybe (Key -> Bool)
 	-- Checks if there is a fast way to migrate a key to a different
 	-- backend (ie, without re-hashing).
-	, fastMigrate :: Maybe (Key -> BackendA a -> AssociatedFile -> a (Maybe Key))
+	-- The Bool is true if the content of the key has been verified to
+	-- be inAnnex.
+	, fastMigrate :: Maybe (Key -> BackendA a -> AssociatedFile -> Bool -> a (Maybe Key))
 	-- Checks if a key is known (or assumed) to always refer to the
 	-- same data.
 	, isStableKey :: Key -> Bool

doc/git-annex-addurl.mdwn

@@ -57,8 +57,9 @@ be used to get better filenames.
   content is downloaded from the web. Once a checksum has been recorded,
   subsequent downloads from the web must have the same checksum.
 
-  Note that this option currently only has an effect when using the
-  web special remote, not other special remotes that handle urls.
+  When addurl was used without this option before, the file it added 
+  can be converted to be verifiable by migrating it to the VURL backend.
+  For example: `git-annex migrate foo --backend=VURL`
 
 * `--raw`
 

doc/todo/verified_relaxed_urls.mdwn

@@ -11,8 +11,7 @@ verify the content.
 The web special remote can hash the content as it's downloading it from the
 web, and record the resulting hash-based key.
 
-> Status: Working, but it's not yet possible to migrate an URL key to a VURL key. Should be easy
-> to add support for this. --[[Joey]]
+> [[done]] --[[Joey]]
 
 ## handling upgrades
 
@@ -126,4 +125,3 @@ key what is the same VURL, or another VURL in a loop. Leading to a crafted
 git-annex branch that DOSes git-annex.
 
 To avoid this, any VURL in equivilant keys will be ignored.
-

git-annex.cabal

@@ -585,6 +585,7 @@ Executable git-annex
     Backend.Utilities
     Backend.Variety
     Backend.VURL
+    Backend.VURL.Utilities
     Backend.WORM
     Benchmark
     Build.BundledPrograms