registerurl, unregisterurl: Added --remote option

This serves two purposes. --remote=web bypasses other special remotes that
claim the url, same as addurl --raw. And, specifying some other remote
allows making sure that an url is claimed by the remote you expect,
which makes then using setpresentkey not be fragile.

Sponsored-By: the NIH-funded NICEMAN (ReproNim TR&D3) project

CHANGELOG

@@ -6,6 +6,7 @@ git-annex (10.20230330) UNRELEASED; urgency=medium
   * Fix laziness bug introduced in last release that breaks use
     of --unlock-present and --hide-missing adjusted branches.
   * Support user.useConfigOnly git config.
+  * registerurl, unregisterurl: Added --remote option.
 
  -- Joey Hess <id@joeyh.name>  Fri, 31 Mar 2023 12:48:54 -0400
 

CmdLine/GitAnnex/Options.hs

@@ -119,8 +119,8 @@ parseAutoOption = switch
 	<> help "automatic mode"
 	)
 
-parseRemoteOption :: RemoteName -> DeferredParse Remote
-parseRemoteOption = DeferredParse 
+mkParseRemoteOption :: RemoteName -> DeferredParse Remote
+mkParseRemoteOption = DeferredParse 
 	. (fromJust <$$> Remote.byNameWithUUID)
 	. Just
 
@@ -145,8 +145,8 @@ instance DeferredParseClass FromToOptions where
 
 parseFromToOptions :: Parser FromToOptions
 parseFromToOptions = 
-	(FromRemote . parseRemoteOption <$> parseFromOption) 
-	<|> (ToRemote . parseRemoteOption <$> parseToOption)
+	(FromRemote . mkParseRemoteOption <$> parseFromOption) 
+	<|> (ToRemote . mkParseRemoteOption <$> parseToOption)
 
 parseFromOption :: Parser RemoteName
 parseFromOption = strOption
@@ -162,6 +162,12 @@ parseToOption = strOption
 	<> completeRemotes
 	)
 
+parseRemoteOption :: Parser RemoteName
+parseRemoteOption = strOption
+	( long "remote" <> metavar paramRemote
+	<> completeRemotes
+	)
+
 -- | From or to a remote, or both, or a special --to=here
 data FromToHereOptions 
 	= FromOrToRemote FromToOptions
@@ -174,14 +180,14 @@ parseFromToHereOptions = go
 	<*> optional parseToOption
   where
 	go (Just from) (Just to) = Just $ FromRemoteToRemote
-		(parseRemoteOption from)
-		(parseRemoteOption to)
+		(mkParseRemoteOption from)
+		(mkParseRemoteOption to)
 	go (Just from) Nothing = Just $ FromOrToRemote
-		(FromRemote $ parseRemoteOption from)
+		(FromRemote $ mkParseRemoteOption from)
 	go Nothing (Just to) = Just $ case to of
 		"here" -> ToHere
 		"." -> ToHere
-		_ -> FromOrToRemote $ ToRemote $ parseRemoteOption to
+		_ -> FromOrToRemote $ ToRemote $ mkParseRemoteOption to
 	go Nothing Nothing = Nothing
 
 instance DeferredParseClass FromToHereOptions where

Command/Drop.hs

@@ -44,7 +44,7 @@ optParser desc = DropOptions
 	<*> parseBatchOption True
 
 parseDropFromOption :: Parser (DeferredParse Remote)
-parseDropFromOption = parseRemoteOption <$> strOption
+parseDropFromOption = mkParseRemoteOption <$> strOption
 	( long "from" <> short 'f' <> metavar paramRemote
 	<> help "drop content from a remote"
 	<> completeRemotes

Command/Export.hs

@@ -59,7 +59,7 @@ data ExportOptions = ExportOptions
 optParser :: CmdParamsDesc -> Parser ExportOptions
 optParser _ = ExportOptions
 	<$> (Git.Ref <$> parsetreeish)
-	<*> (parseRemoteOption <$> parseToOption)
+	<*> (mkParseRemoteOption <$> parseToOption)
 	<*> parsetracking
   where
 	parsetreeish = argument str

Command/Fsck.hs

@@ -74,7 +74,7 @@ data IncrementalOpt
 optParser :: CmdParamsDesc -> Parser FsckOptions
 optParser desc = FsckOptions
 	<$> cmdParams desc
-	<*> optional (parseRemoteOption <$> strOption 
+	<*> optional (mkParseRemoteOption <$> strOption 
 		( long "from" <> short 'f' <> metavar paramRemote 
 		<> help "check remote"
 		<> completeRemotes

Command/Get.hs

@@ -32,7 +32,7 @@ data GetOptions = GetOptions
 optParser :: CmdParamsDesc -> Parser GetOptions
 optParser desc = GetOptions
 	<$> cmdParams desc
-	<*> optional (parseRemoteOption <$> parseFromOption)
+	<*> optional (mkParseRemoteOption <$> parseFromOption)
 	<*> parseAutoOption
 	<*> optional (parseIncompleteOption <|> parseKeyOptions <|> parseFailedTransfersOption)
 	<*> parseBatchOption True

Command/Import.hs

@@ -75,7 +75,7 @@ data ImportOptions
 optParser :: CmdParamsDesc -> Parser ImportOptions
 optParser desc = do
 	ps <- cmdParams desc
-	mfromremote <- optional $ parseRemoteOption <$> parseFromOption
+	mfromremote <- optional $ mkParseRemoteOption <$> parseFromOption
 	content <- invertableSwitch "content" True
 		( help "do not get contents of imported files"
 		)

Command/RegisterUrl.hs

@@ -11,6 +11,7 @@ import Command
 import Logs.Web
 import Command.FromKey (keyOpt, keyOpt')
 import qualified Remote
+import Annex.UUID
 
 cmd :: Command
 cmd = withAnnexOptions [jsonOptions] $ command "registerurl"
@@ -21,24 +22,26 @@ cmd = withAnnexOptions [jsonOptions] $ command "registerurl"
 data RegisterUrlOptions = RegisterUrlOptions
 	{ keyUrlPairs :: CmdParams
 	, batchOption :: BatchMode
+	, remoteOption :: Maybe (DeferredParse Remote)
 	}
 
 optParser :: CmdParamsDesc -> Parser RegisterUrlOptions
 optParser desc = RegisterUrlOptions
 	<$> cmdParams desc
 	<*> parseBatchOption False
+	<*> optional (mkParseRemoteOption <$> parseRemoteOption)
 
 seek :: RegisterUrlOptions -> CommandSeek
 seek o = case (batchOption o, keyUrlPairs o) of
 	(Batch fmt, _) -> seekBatch setUrlPresent o fmt
 	-- older way of enabling batch input, does not support BatchNull
 	(NoBatch, []) -> seekBatch setUrlPresent o (BatchFormat BatchLine (BatchKeys False))
-	(NoBatch, ps) -> commandAction (start setUrlPresent ps)
+	(NoBatch, ps) -> commandAction (start setUrlPresent o ps)
 
 seekBatch :: (Key -> URLString -> Annex ()) -> RegisterUrlOptions -> BatchFormat -> CommandSeek
 seekBatch a o fmt = batchOnly Nothing (keyUrlPairs o) $
 	batchInput fmt (pure . parsebatch) $
-		batchCommandAction . start' a
+		batchCommandAction . start' a o
   where
 	parsebatch l = 
 		let (keyname, u) = separate (== ' ') l
@@ -48,21 +51,29 @@ seekBatch a o fmt = batchOnly Nothing (keyUrlPairs o) $
 				Left e -> Left e
 				Right k -> Right (k, u)
 
-start :: (Key -> URLString -> Annex ()) -> [String] -> CommandStart
-start a (keyname:url:[]) = start' a (si, (keyOpt keyname, url))
+start :: (Key -> URLString -> Annex ()) -> RegisterUrlOptions -> [String] -> CommandStart
+start a o (keyname:url:[]) = start' a o (si, (keyOpt keyname, url))
   where
 	si = SeekInput [keyname, url]
-start _ _ = giveup "specify a key and an url"
+start _ _ _ = giveup "specify a key and an url"
 
-start' :: (Key -> URLString -> Annex ()) -> (SeekInput, (Key, URLString)) -> CommandStart
-start' a (si, (key, url)) =
+start' :: (Key -> URLString -> Annex ()) -> RegisterUrlOptions -> (SeekInput, (Key, URLString)) -> CommandStart
+start' a o (si, (key, url)) =
 	starting "registerurl" ai si $
-		perform a key url
+		perform a o key url
   where
 	ai = ActionItemOther (Just url)
 
-perform :: (Key -> URLString -> Annex ()) -> Key -> URLString -> CommandPerform
-perform a key url = do
-	r <- Remote.claimingUrl url
-	a key (setDownloader' url r)
-	next $ return True
+perform :: (Key -> URLString -> Annex ()) -> RegisterUrlOptions -> Key -> URLString -> CommandPerform
+perform a o key url = do
+	needremote <- maybe (pure Nothing) (Just <$$> getParsed) (remoteOption o)
+	r <- case needremote of
+		Just nr | Remote.uuid nr == webUUID -> pure nr
+		_ -> Remote.claimingUrl url
+	case needremote of
+		Just nr | nr /= r -> do
+			showNote $ "The url " ++ url ++ " is claimed by remote " ++ Remote.name r
+			next $ return False
+		_ -> do
+			a key (setDownloader' url r)
+			next $ return True

Command/UnregisterUrl.hs

@@ -22,7 +22,7 @@ cmd = withAnnexOptions [jsonOptions] $ command "unregisterurl"
 seek :: RegisterUrlOptions -> CommandSeek
 seek o = case (batchOption o, keyUrlPairs o) of
 	(Batch fmt, _) -> seekBatch unregisterUrl o fmt
-	(NoBatch, ps) -> commandAction (start unregisterUrl ps)
+	(NoBatch, ps) -> commandAction (start unregisterUrl o ps)
 
 unregisterUrl :: Key -> String -> Annex ()
 unregisterUrl key url = do

doc/bugs/registerurl_does_not_register_if_external_remote/comment_5_b9057ce47bb57b3a3dbe390672310898._comment

@@ -11,6 +11,8 @@ So, you can then use registerurl with --remote=$uuid, check that it
 succeeded, and then use setpresentkey to mark it present on that uuid.
 Without the fragility you complained of.
 
+Update: The --remote parameter is implemented now.
+
 (Could registerurl with --remote update location tracking itself? Maybe,
 but I'd worry about a scenario like in the previous comment.)
 """]]

doc/git-annex-registerurl.mdwn

@@ -17,8 +17,19 @@ Normally the key is a git-annex formatted key. However, to make it easier
 to use this to add urls, if the key cannot be parsed as a key, and is a
 valid url, an URL key is constructed from the url.
 
+Registering an url makes content be treated as being present in the web
+special remote, unless some other special remote claims the url.
+
 # OPTIONS
 
+* `--remote=name|uuid`
+
+  Indicate that the url is expected to be claimed by the specified remote.
+  If some other remote claims the url instead, registering it will fail.
+
+  Note that `--remote=web` will prevent any other remote from claiming
+  the url.
+
 * `--batch`
 
   In batch input mode, lines are read from stdin, and each line

doc/git-annex-unregisterurl.mdwn

@@ -19,6 +19,14 @@ parsed as a key, and is a valid url, an URL key is constructed from the url.
 
 # OPTIONS
 
+* `--remote=name|uuid`
+
+  Indicate that the url is expected to be claimed by the specified remote.
+  If some other remote claims the url instead, unregistering it will fail.
+
+  Note that `--remote=web` will prevent any other remote from claiming
+  the url.
+
 * `--batch`
 
   In batch input mode, lines are read from stdin, and each line

doc/todo/registerurl_--remote_REMOTE.mdwn

@@ -3,3 +3,5 @@ If a remote can handle some urls (e.g. regular http) which annex can handle as w
 
 [[!meta author=yoh]]
 [[!tag projects/repronim]]
+
+> [[fixed|done]] --[[Joey]]

doc/todo/registerurl_--remote_REMOTE/comment_4_334ce2eb815d6d8489f9cb00c09b0bd7._comment

@@ -0,0 +1,8 @@
+[[!comment format=mdwn
+ username="joey"
+ subject="""comment 4"""
+ date="2023-04-05T19:52:38Z"
+ content="""
+Implemented --remote for registerurl and unregisterurl. Including the --remote=web
+special case.
+"""]]