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

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