summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Joey Hess <joeyh@joeyh.name>2014-12-08 13:57:13 -0400
committerGravatar Joey Hess <joeyh@joeyh.name>2014-12-08 13:57:13 -0400
commit28764ce2dc29d1d93989b4061b5b12bac10902de (patch)
tree3b052b0785d387a86dfd9a14d8fd885f2d78d809
parent335024d92294bd9504e9e9cd42ec0a4addfc4d69 (diff)
implement CLAIMURL for external special remote
-rw-r--r--Remote/External.hs11
-rw-r--r--Remote/External/Types.hs11
-rw-r--r--Types/Remote.hs2
-rw-r--r--doc/design/external_special_remote_protocol.mdwn8
-rw-r--r--doc/todo/extensible_addurl.mdwn2
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