Urls can now be claimed by remotes. This will allow creating, for example, a external special remote that handles magnet: and *.torrent urls.

14 files changed, 60 insertions, 18 deletions

diff --git a/Remote/Bup.hs b/Remote/Bup.hs
index 8744aa357..405ce3056 100644
--- a/Remote/Bup.hs
+++ b/Remote/Bup.hs
@@ -75,6 +75,7 @@ gen r u c gc = do
 		, mkUnavailable = return Nothing
 		, getInfo = return [("repo", buprepo)]
 		, claimUrl = Nothing
+		, checkUrl = const $ return Nothing
 		}
 	return $ Just $ specialRemote' specialcfg c
 		(simplyPrepare $ store this buprepo)
diff --git a/Remote/Ddar.hs b/Remote/Ddar.hs
index a57f5f6c3..1b8003dd8 100644
--- a/Remote/Ddar.hs
+++ b/Remote/Ddar.hs
@@ -72,6 +72,7 @@ gen r u c gc = do
 		, mkUnavailable = return Nothing
 		, getInfo = return [("repo", ddarrepo)]
 		, claimUrl = Nothing
+		, checkUrl = const $ return Nothing
 		}
 	ddarrepo = fromMaybe (error "missing ddarrepo") $ remoteAnnexDdarRepo gc
 	specialcfg = (specialRemoteCfg c)
diff --git a/Remote/Directory.hs b/Remote/Directory.hs
index d83ab2dae..fec40baa8 100644
--- a/Remote/Directory.hs
+++ b/Remote/Directory.hs
@@ -69,7 +69,8 @@ gen r u c gc = do
 			mkUnavailable = gen r u c $
 				gc { remoteAnnexDirectory = Just "/dev/null" },
 			getInfo = return [("directory", dir)],
-			claimUrl = Nothing
+			claimUrl = Nothing,
+			checkUrl = const $ return Nothing
 		}
   where
 	dir = fromMaybe (error "missing directory") $ remoteAnnexDirectory gc
diff --git a/Remote/External.hs b/Remote/External.hs
index 97aa247ba..b6928a827 100644
--- a/Remote/External.hs
+++ b/Remote/External.hs
@@ -70,7 +70,8 @@ gen r u c gc = do
 			mkUnavailable = gen r u c $
 				gc { remoteAnnexExternalType = Just "!dne!" },
 			getInfo = return [("externaltype", externaltype)],
-			claimUrl = Just (claimurl external)
+			claimUrl = Just (claimurl external),
+			checkUrl = checkurl external
 		}
   where
 	externaltype = fromMaybe (error "missing externaltype") (remoteAnnexExternalType gc)
@@ -217,8 +218,10 @@ handleRequest' lck external req mp responsehandler
 		state <- fromMaybe ""
 			<$> getRemoteState (externalUUID external) key
 		send $ VALUE state
-	handleRemoteRequest (SETURLPRESENT key url) = setUrlPresent key url
-	handleRemoteRequest (SETURLMISSING key url) = setUrlMissing key url
+	handleRemoteRequest (SETURLPRESENT key url) =
+		setUrlPresent (externalUUID external) key url
+	handleRemoteRequest (SETURLMISSING key url) =
+		setUrlMissing (externalUUID external) key url
 	handleRemoteRequest (GETURLS key prefix) = do
 		mapM_ (send . VALUE) =<< getUrlsWithPrefix key prefix
 		send (VALUE "") -- end of list
@@ -425,3 +428,11 @@ claimurl external url =
 		UNSUPPORTED_REQUEST -> Just $ return False
 		_ -> Nothing
 
+checkurl :: External -> URLString -> Annex (Maybe Integer)
+checkurl external url = 
+	handleRequest external (CHECKURL url) Nothing $ \req -> case req of
+		CHECKURL_SIZE sz -> Just $ return $ Just sz
+		CHECKURL_SIZEUNKNOWN -> Just $ return Nothing
+		CHECKURL_FAILURE errmsg -> Just $ error errmsg
+		UNSUPPORTED_REQUEST -> error "CHECKURL not implemented by external special remote"
+		_ -> Nothing
diff --git a/Remote/External/Types.hs b/Remote/External/Types.hs
index 2fc29e5b4..b00352702 100644
--- a/Remote/External/Types.hs
+++ b/Remote/External/Types.hs
@@ -92,6 +92,7 @@ data Request
 	| GETCOST
 	| GETAVAILABILITY
 	| CLAIMURL URLString
+	| CHECKURL URLString
 	| TRANSFER Direction Key FilePath
 	| CHECKPRESENT Key
 	| REMOVE Key
@@ -109,6 +110,7 @@ instance Proto.Sendable Request where
 	formatMessage GETCOST = ["GETCOST"]
 	formatMessage GETAVAILABILITY = ["GETAVAILABILITY"]
 	formatMessage (CLAIMURL url) = [ "CLAIMURL", Proto.serialize url ]
+	formatMessage (CHECKURL url) = [ "CHECKURL", Proto.serialize url ]
 	formatMessage (TRANSFER direction key file) =
 		[ "TRANSFER"
 		, Proto.serialize direction
@@ -135,6 +137,9 @@ data Response
 	| INITREMOTE_FAILURE ErrorMsg
 	| CLAIMURL_SUCCESS
 	| CLAIMURL_FAILURE
+	| CHECKURL_SIZE Size
+	| CHECKURL_SIZEUNKNOWN
+	| CHECKURL_FAILURE ErrorMsg
 	| UNSUPPORTED_REQUEST
 	deriving (Show)
 
@@ -154,6 +159,9 @@ instance Proto.Receivable Response where
 	parseCommand "INITREMOTE-FAILURE" = Proto.parse1 INITREMOTE_FAILURE
 	parseCommand "CLAIMURL-SUCCESS" = Proto.parse0 CLAIMURL_SUCCESS
 	parseCommand "CLAIMURL-FAILURE" = Proto.parse0 CLAIMURL_FAILURE
+	parseCommand "CHECKURL-SIZE" = Proto.parse1 CHECKURL_SIZE
+	parseCommand "CHECKURL-SIZEUNKNOWN" = Proto.parse0 CHECKURL_SIZEUNKNOWN
+	parseCommand "CHECKURL-FAILURE" = Proto.parse1 CHECKURL_FAILURE
 	parseCommand "UNSUPPORTED-REQUEST" = Proto.parse0 UNSUPPORTED_REQUEST
 	parseCommand _ = Proto.parseFail
 
@@ -225,6 +233,7 @@ instance Proto.Receivable AsyncMessage where
 type ErrorMsg = String
 type Setting = String
 type ProtocolVersion = Int
+type Size = Integer
 
 supportedProtocolVersions :: [ProtocolVersion]
 supportedProtocolVersions = [1]
@@ -253,6 +262,10 @@ instance Proto.Serializable Cost where
 	serialize = show
 	deserialize = readish
 
+instance Proto.Serializable Size where
+	serialize = show
+	deserialize = readish
+
 instance Proto.Serializable Availability where
 	serialize GloballyAvailable = "GLOBAL"
 	serialize LocallyAvailable = "LOCAL"
diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs
index 43e3d8b16..6bf99c135 100644
--- a/Remote/GCrypt.hs
+++ b/Remote/GCrypt.hs
@@ -123,6 +123,7 @@ gen' r u c gc = do
 		, mkUnavailable = return Nothing
 		, getInfo = return $ gitRepoInfo r
 		, claimUrl = Nothing
+		, checkUrl = const $ return Nothing
 	}
 	return $ Just $ specialRemote' specialcfg c
 		(simplyPrepare $ store this rsyncopts)
diff --git a/Remote/Git.hs b/Remote/Git.hs
index fdadac2d6..74fb81965 100644
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -161,6 +161,7 @@ gen r u c gc
 			, mkUnavailable = unavailable r u c gc
 			, getInfo = return $ gitRepoInfo r
 			, claimUrl = Nothing
+			, checkUrl = const $ return Nothing
 			}
 
 unavailable :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs
index 5484a0d2f..17f755000 100644
--- a/Remote/Glacier.hs
+++ b/Remote/Glacier.hs
@@ -69,7 +69,8 @@ gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost
 			mkUnavailable = return Nothing,
 			getInfo = includeCredsInfo c (AWS.creds u) $
 				[ ("glacier vault", getVault c) ],
-			claimUrl = Nothing
+			claimUrl = Nothing,
+			checkUrl = const $ return Nothing
 		}
 	specialcfg = (specialRemoteCfg c)
 		-- Disabled until jobList gets support for chunks.
diff --git a/Remote/Hook.hs b/Remote/Hook.hs
index a84ee8554..09297a6e2 100644
--- a/Remote/Hook.hs
+++ b/Remote/Hook.hs
@@ -62,7 +62,8 @@ gen r u c gc = do
 			mkUnavailable = gen r u c $
 				gc { remoteAnnexHookType = Just "!dne!" },
 			getInfo = return [("hooktype", hooktype)],
-			claimUrl = Nothing
+			claimUrl = Nothing,
+			checkUrl = const $ return Nothing
 		}
   where
 	hooktype = fromMaybe (error "missing hooktype") $ remoteAnnexHookType gc
diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs
index 6e71cb2bb..7a7f68165 100644
--- a/Remote/Rsync.hs
+++ b/Remote/Rsync.hs
@@ -85,6 +85,7 @@ gen r u c gc = do
 			, mkUnavailable = return Nothing
 			, getInfo = return [("url", url)]
 			, claimUrl = Nothing
+			, checkUrl = const $ return Nothing
 			}
   where
 	specialcfg = (specialRemoteCfg c)
diff --git a/Remote/S3.hs b/Remote/S3.hs
index 42f4f1ffb..f56904729 100644
--- a/Remote/S3.hs
+++ b/Remote/S3.hs
@@ -93,7 +93,8 @@ gen r u c gc = do
 					else Nothing
 				, Just ("partsize", maybe "unlimited" (roughSize storageUnits False) (getPartSize c))
 				],
-			claimUrl = Nothing
+			claimUrl = Nothing,
+			checkUrl = const $ return Nothing
 		}
 
 s3Setup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
@@ -163,7 +164,7 @@ store r h = fileStorer $ \k f p -> do
 		_ -> singlepartupload k f p	
 	-- Store public URL to item in Internet Archive.
 	when (isIA (hinfo h) && not (isChunkKey k)) $
-		setUrlPresent k (iaKeyUrl r k)
+		setUrlPresent webUUID k (iaKeyUrl r k)
 	return True
   where
 	singlepartupload k f p = do
diff --git a/Remote/Tahoe.hs b/Remote/Tahoe.hs
index 8df590f57..8b56bbd50 100644
--- a/Remote/Tahoe.hs
+++ b/Remote/Tahoe.hs
@@ -86,7 +86,8 @@ gen r u c gc = do
 		remotetype = remote,
 		mkUnavailable = return Nothing,
 		getInfo = return [],
-		claimUrl = Nothing
+		claimUrl = Nothing,
+		checkUrl = const $ return Nothing
 	}
 
 tahoeSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
diff --git a/Remote/Web.hs b/Remote/Web.hs
index 6ddf1a45a..3845dddf5 100644
--- a/Remote/Web.hs
+++ b/Remote/Web.hs
@@ -1,4 +1,4 @@
-{- Web remotes.
+{- Web remote.
  -
  - Copyright 2011 Joey Hess <joey@kitenet.net>
  -
@@ -52,7 +52,7 @@ gen r _ c gc =
 		removeKey = dropKey,
 		checkPresent = checkKey,
 		checkPresentCheap = False,
-		whereisKey = Just getUrls,
+		whereisKey = Just getWebUrls,
 		remoteFsck = Nothing,
 		repairRepo = Nothing,
 		config = c,
@@ -64,11 +64,12 @@ gen r _ c gc =
 		remotetype = remote,
 		mkUnavailable = return Nothing,
 		getInfo = return [],
-		claimUrl = Nothing -- implicitly claims all urls
+		claimUrl = Nothing, -- implicitly claims all urls
+		checkUrl = const $ return Nothing
 	}
 
 downloadKey :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool
-downloadKey key _file dest _p = get =<< getUrls key
+downloadKey key _file dest _p = get =<< getWebUrls key
   where
 	get [] = do
 		warning "no known url"
@@ -86,7 +87,7 @@ downloadKey key _file dest _p = get =<< getUrls key
 					warning "quvi support needed for this url"
 					return False
 #endif
-				DefaultDownloader -> downloadUrl [u'] dest
+				_ -> downloadUrl [u'] dest
 
 downloadKeyCheap :: Key -> FilePath -> Annex Bool
 downloadKeyCheap _ _ = return False
@@ -98,12 +99,12 @@ uploadKey _ _ _ = do
 
 dropKey :: Key -> Annex Bool
 dropKey k = do
-	mapM_ (setUrlMissing k) =<< getUrls k
+	mapM_ (setUrlMissing webUUID k) =<< getWebUrls k
 	return True
 
 checkKey :: Key -> Annex Bool
 checkKey key = do
-	us <- getUrls key
+	us <- getWebUrls key
 	if null us
 		then return False
 		else either error return =<< checkKey' key us
@@ -118,7 +119,7 @@ checkKey' key us = firsthit us (Right False) $ \u -> do
 #else
 			return $ Left "quvi support needed for this url"
 #endif
-		DefaultDownloader -> do
+		_ -> do
 			Url.withUrlOptions $ catchMsgIO .
 				Url.checkBoth u' (keySize key)
   where
@@ -128,3 +129,9 @@ checkKey' key us = firsthit us (Right False) $ \u -> do
 		case r of
 			Right _ -> return r
 			Left _ -> firsthit rest r a
+
+getWebUrls :: Key -> Annex [URLString]
+getWebUrls key = filter supported <$> getUrls key
+  where
+	supported u = snd (getDownloader u) 
+		`elem` [WebDownloader, QuviDownloader]
diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs
index 6b56acca6..57e1dd785 100644
--- a/Remote/WebDAV.hs
+++ b/Remote/WebDAV.hs
@@ -74,7 +74,8 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
 			mkUnavailable = gen r u (M.insert "url" "http://!dne!/" c) gc,
 			getInfo = includeCredsInfo c (davCreds u) $
 				[("url", fromMaybe "unknown" (M.lookup "url" c))],
-			claimUrl = Nothing
+			claimUrl = Nothing,
+			checkUrl = const $ return Nothing
 		}
 		chunkconfig = getChunkConfig c