implement CLAIMURL for external special remote

5 files changed, 29 insertions, 5 deletions

diff --git a/Remote/External.hs b/Remote/External.hs
index a8526566f..97aa247ba 100644
--- a/Remote/External.hs
+++ b/Remote/External.hs
@@ -70,7 +70,7 @@ gen r u c gc = do
 			mkUnavailable = gen r u c $
 				gc { remoteAnnexExternalType = Just "!dne!" },
 			getInfo = return [("externaltype", externaltype)],
-			claimUrl = Nothing
+			claimUrl = Just (claimurl external)
 		}
   where
 	externaltype = fromMaybe (error "missing externaltype") (remoteAnnexExternalType gc)
@@ -416,3 +416,12 @@ getAvailability external r gc = maybe query return (remoteAnnexAvailability gc)
 			_ -> Nothing
 		setRemoteAvailability r avail
 		return avail
+
+claimurl :: External -> URLString -> Annex Bool
+claimurl external url =
+	handleRequest external (CLAIMURL url) Nothing $ \req -> case req of
+		CLAIMURL_SUCCESS -> Just $ return True
+		CLAIMURL_FAILURE -> Just $ return False
+		UNSUPPORTED_REQUEST -> Just $ return False
+		_ -> Nothing
+
diff --git a/Remote/External/Types.hs b/Remote/External/Types.hs
index cdcb657ea..2fc29e5b4 100644
--- a/Remote/External/Types.hs
+++ b/Remote/External/Types.hs
@@ -39,6 +39,7 @@ import Logs.Transfer (Direction(..))
 import Config.Cost (Cost)
 import Types.Remote (RemoteConfig)
 import Types.Availability (Availability(..))
+import Utility.Url (URLString)
 import qualified Utility.SimpleProtocol as Proto
 
 import Control.Concurrent.STM
@@ -90,6 +91,7 @@ data Request
 	| INITREMOTE
 	| GETCOST
 	| GETAVAILABILITY
+	| CLAIMURL URLString
 	| TRANSFER Direction Key FilePath
 	| CHECKPRESENT Key
 	| REMOVE Key
@@ -106,6 +108,7 @@ instance Proto.Sendable Request where
 	formatMessage INITREMOTE = ["INITREMOTE"]
 	formatMessage GETCOST = ["GETCOST"]
 	formatMessage GETAVAILABILITY = ["GETAVAILABILITY"]
+	formatMessage (CLAIMURL url) = [ "CLAIMURL", Proto.serialize url ]
 	formatMessage (TRANSFER direction key file) =
 		[ "TRANSFER"
 		, Proto.serialize direction
@@ -130,6 +133,8 @@ data Response
 	| AVAILABILITY Availability
 	| INITREMOTE_SUCCESS
 	| INITREMOTE_FAILURE ErrorMsg
+	| CLAIMURL_SUCCESS
+	| CLAIMURL_FAILURE
 	| UNSUPPORTED_REQUEST
 	deriving (Show)
 
@@ -147,6 +152,8 @@ instance Proto.Receivable Response where
 	parseCommand "AVAILABILITY" = Proto.parse1 AVAILABILITY
 	parseCommand "INITREMOTE-SUCCESS" = Proto.parse0 INITREMOTE_SUCCESS
 	parseCommand "INITREMOTE-FAILURE" = Proto.parse1 INITREMOTE_FAILURE
+	parseCommand "CLAIMURL-SUCCESS" = Proto.parse0 CLAIMURL_SUCCESS
+	parseCommand "CLAIMURL-FAILURE" = Proto.parse0 CLAIMURL_FAILURE
 	parseCommand "UNSUPPORTED-REQUEST" = Proto.parse0 UNSUPPORTED_REQUEST
 	parseCommand _ = Proto.parseFail
 
@@ -165,8 +172,8 @@ data RemoteRequest
 	| GETWANTED
 	| SETSTATE Key String
 	| GETSTATE Key
-	| SETURLPRESENT Key String
-	| SETURLMISSING Key String
+	| SETURLPRESENT Key URLString
+	| SETURLMISSING Key URLString
 	| GETURLS Key String
 	| DEBUG String
 	deriving (Show)
diff --git a/Types/Remote.hs b/Types/Remote.hs
index 46a0648bb..3f71e1fb4 100644
--- a/Types/Remote.hs
+++ b/Types/Remote.hs
@@ -103,7 +103,7 @@ data RemoteA a = Remote {
 	-- Information about the remote, for git annex info to display.
 	getInfo :: a [(String, String)],
 	-- Some remotes can download from an url (or uri).
-	claimUrl :: Maybe (URLString -> IO Bool)
+	claimUrl :: Maybe (URLString -> a Bool)
 }
 
 instance Show (RemoteA a) where
diff --git a/doc/design/external_special_remote_protocol.mdwn b/doc/design/external_special_remote_protocol.mdwn
index 00533095c..332cc37b1 100644
--- a/doc/design/external_special_remote_protocol.mdwn
+++ b/doc/design/external_special_remote_protocol.mdwn
@@ -125,6 +125,10 @@ replying with `UNSUPPORTED-REQUEST` is acceptable.
   If the remote replies with `UNSUPPORTED-REQUEST`, its availability
   is assumed to be global. So, only remotes that are only reachable
   locally need to worry about implementing this.
+* `CLAIMURL Value`  
+  Asks the remote if it wishes to claim responsibility for downloading
+  an url. If so, the remote should send back an `CLAIMURL-SUCCESS` reply.
+  If not, it can send `CLAIMURL-FAILURE`.
 
 More optional requests may be added, without changing the protocol version,
 so if an unknown request is seen, reply with `UNSUPPORTED-REQUEST`.
@@ -167,6 +171,10 @@ while it's handling a request.
   Indicates the INITREMOTE succeeded and the remote is ready to use.
 * `INITREMOTE-FAILURE ErrorMsg`  
   Indicates that INITREMOTE failed.
+* `CLAIMURL-SUCCESS`  
+  Indicates that the CLAIMURL url will be handled by this remote.
+* `CLAIMURL-FAILURE`  
+  Indicates that the CLAIMURL url wil not be handled by this remote.
 * `UNSUPPORTED-REQUEST`  
   Indicates that the special remote does not know how to handle a request.
 
diff --git a/doc/todo/extensible_addurl.mdwn b/doc/todo/extensible_addurl.mdwn
index 0db4085d1..e9a8d070a 100644
--- a/doc/todo/extensible_addurl.mdwn
+++ b/doc/todo/extensible_addurl.mdwn
@@ -22,7 +22,7 @@ both available from CERN and from a torrent, for example.
 
 Solution: Add a new method to remotes:
 
-	claimUrl :: Maybe (URLString -> IO Bool)
+	claimUrl :: Maybe (URLString -> Annex Bool)
 
 Remotes that implement this method (including special remotes) will
 be queried when such an uri is added, to see which claims it. Once the