let url claims optionally include a suggested filename

11 files changed, 67 insertions, 26 deletions

diff --git a/Annex/URLClaim.hs b/Annex/URLClaim.hs
new file mode 100644
index 000000000..3acb28e29
--- /dev/null
+++ b/Annex/URLClaim.hs
@@ -0,0 +1,29 @@
+{- Url claim checking.
+ -
+ - Copyright 2013-2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.URLClaim (
+	URLClaim(..),
+	urlClaim
+) where
+
+import Common.Annex
+import Types.URLClaim
+import Logs.Web
+import Remote
+import qualified Types.Remote as Remote
+
+urlClaim :: URLString -> Annex (Remote, URLClaim)
+urlClaim url = do
+	rs <- remoteList
+	-- The web special remote claims urls by default.
+	let web = Prelude.head $ filter (\r -> uuid r == webUUID) rs
+	fromMaybe (web, URLClaimed) <$> getM (\r -> ret r <$> checkclaim r) rs
+  where
+	checkclaim = maybe (pure Nothing) (flip id url) . Remote.claimUrl
+
+	ret _ Nothing = Nothing
+	ret r (Just c) = Just (r, c)
diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs
index 76095d6e4..27c8359b0 100644
--- a/Command/AddUrl.hs
+++ b/Command/AddUrl.hs
@@ -21,6 +21,7 @@ import qualified Annex.Url as Url
 import qualified Backend.URL
 import qualified Remote
 import qualified Types.Remote as Remote
+import Annex.URLClaim
 import Annex.Content
 import Logs.Web
 import Types.Key
@@ -58,23 +59,23 @@ seek ps = do
 
 start :: Bool -> Maybe FilePath -> Maybe Int -> String -> CommandStart
 start relaxed optfile pathdepth s = do
-	r <- Remote.claimingUrl s
+	(r, claim) <- urlClaim s
 	if Remote.uuid r == webUUID
 		then startWeb relaxed optfile pathdepth s
-		else startRemote r relaxed optfile pathdepth s
+		else startRemote r claim relaxed optfile pathdepth s
 
-startRemote :: Remote -> Bool -> Maybe FilePath -> Maybe Int -> String -> CommandStart
-startRemote r relaxed optfile pathdepth s = do
+startRemote :: Remote -> URLClaim -> Bool -> Maybe FilePath -> Maybe Int -> String -> CommandStart
+startRemote r claim relaxed optfile pathdepth s = do
 	url <- case Url.parseURIRelaxed s of
 		Nothing -> error $ "bad uri " ++ s
 		Just u -> pure u
 	pathmax <- liftIO $ fileNameLengthLimit "."
-	let file = choosefile $ url2file url pathdepth pathmax
+	let file = flip fromMaybe optfile $ case claim of
+		URLClaimedAs f -> f
+		URLClaimed -> url2file url pathdepth pathmax
 	showStart "addurl" file
 	showNote $ "using " ++ Remote.name r 
 	next $ performRemote r relaxed s file
-  where
-	choosefile = flip fromMaybe optfile
 
 performRemote :: Remote -> Bool -> URLString -> FilePath -> CommandPerform
 performRemote r relaxed uri file = ifAnnexed file adduri geturi
diff --git a/Command/ReKey.hs b/Command/ReKey.hs
index 5dadf4e60..a0348d858 100644
--- a/Command/ReKey.hs
+++ b/Command/ReKey.hs
@@ -16,6 +16,7 @@ import qualified Command.Add
 import Logs.Web
 import Logs.Location
 import Utility.CopyFile
+import Annex.URLClaim
 import qualified Remote
 
 cmd :: [Command]
@@ -63,7 +64,7 @@ cleanup file oldkey newkey = do
 	-- the new key as well.
 	urls <- getUrls oldkey
 	forM_ urls $ \url -> do
-		r <- Remote.claimingUrl url
+		r <- fst <$> urlClaim url
 		setUrlPresent (Remote.uuid r) newkey url
 
 	-- Update symlink to use the new key.
diff --git a/Command/RmUrl.hs b/Command/RmUrl.hs
index 570004266..737c935c5 100644
--- a/Command/RmUrl.hs
+++ b/Command/RmUrl.hs
@@ -10,6 +10,7 @@ module Command.RmUrl where
 import Common.Annex
 import Command
 import Logs.Web
+import Annex.URLClaim
 import qualified Remote
 
 cmd :: [Command]
@@ -27,7 +28,7 @@ start (file, url) = flip whenAnnexed file $ \_ key -> do
 
 cleanup :: String -> Key -> CommandCleanup
 cleanup url key = do
-	r <- Remote.claimingUrl url
+	r <- fst <$> urlClaim url
 	let url' = if Remote.uuid r == webUUID
 		then url
 		else setDownloader url OtherDownloader
diff --git a/Command/Whereis.hs b/Command/Whereis.hs
index 314c204be..5f75badde 100644
--- a/Command/Whereis.hs
+++ b/Command/Whereis.hs
@@ -14,6 +14,7 @@ import Command
 import Remote
 import Logs.Trust
 import Logs.Web
+import Annex.URLClaim
 
 cmd :: [Command]
 cmd = [noCommit $ withOptions (jsonOption : keyOptions) $
@@ -71,4 +72,4 @@ performRemote key remote = do
 			. filter (\(_, d) -> d == OtherDownloader)
 			. map getDownloader
 			<$> getUrls key
-		filterM (\u -> (==) <$> pure remote <*> claimingUrl u) us
+		filterM (\u -> (==) <$> pure remote <*> (fst <$> urlClaim u)) us
diff --git a/Remote.hs b/Remote.hs
index 65e725338..dd682493c 100644
--- a/Remote.hs
+++ b/Remote.hs
@@ -46,7 +46,6 @@ module Remote (
 	logStatus,
 	checkAvailable,
 	isXMPPRemote,
-	claimingUrl,
 ) where
 
 import qualified Data.Map as M
@@ -61,7 +60,6 @@ import Annex.UUID
 import Logs.UUID
 import Logs.Trust
 import Logs.Location hiding (logStatus)
-import Logs.Web
 import Remote.List
 import Config
 import Git.Types (RemoteName)
@@ -320,12 +318,3 @@ hasKey r k = either (Left  . show) Right <$> tryNonAsync (checkPresent r k)
 
 hasKeyCheap :: Remote -> Bool
 hasKeyCheap = checkPresentCheap
-
-{- The web special remote claims urls by default. -}
-claimingUrl :: URLString -> Annex Remote
-claimingUrl url = do
-	rs <- remoteList
-	let web = Prelude.head $ filter (\r -> uuid r == webUUID) rs
-	fromMaybe web <$> firstM checkclaim rs
-  where
-	checkclaim = maybe (pure False) (flip id url) . claimUrl
diff --git a/Remote/External.hs b/Remote/External.hs
index 62671755c..baae1ab9d 100644
--- a/Remote/External.hs
+++ b/Remote/External.hs
@@ -12,6 +12,7 @@ import qualified Annex
 import Common.Annex
 import Types.Remote
 import Types.CleanupActions
+import Types.URLClaim
 import qualified Git
 import Config
 import Remote.Helper.Special
@@ -421,12 +422,13 @@ getAvailability external r gc = maybe query return (remoteAnnexAvailability gc)
 		setRemoteAvailability r avail
 		return avail
 
-claimurl :: External -> URLString -> Annex Bool
+claimurl :: External -> URLString -> Annex (Maybe URLClaim)
 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
+		CLAIMURL_SUCCESS -> Just $ return $ Just URLClaimed
+		(CLAIMURL_AS f) -> Just $ return $ Just $ URLClaimedAs f
+		CLAIMURL_FAILURE -> Just $ return Nothing
+		UNSUPPORTED_REQUEST -> Just $ return Nothing
 		_ -> Nothing
 
 checkurl :: External -> URLString -> Annex (Maybe Integer)
diff --git a/Remote/External/Types.hs b/Remote/External/Types.hs
index b00352702..a230ef3d2 100644
--- a/Remote/External/Types.hs
+++ b/Remote/External/Types.hs
@@ -136,6 +136,7 @@ data Response
 	| INITREMOTE_SUCCESS
 	| INITREMOTE_FAILURE ErrorMsg
 	| CLAIMURL_SUCCESS
+	| CLAIMURL_AS FilePath
 	| CLAIMURL_FAILURE
 	| CHECKURL_SIZE Size
 	| CHECKURL_SIZEUNKNOWN
@@ -158,6 +159,7 @@ instance Proto.Receivable Response where
 	parseCommand "INITREMOTE-SUCCESS" = Proto.parse0 INITREMOTE_SUCCESS
 	parseCommand "INITREMOTE-FAILURE" = Proto.parse1 INITREMOTE_FAILURE
 	parseCommand "CLAIMURL-SUCCESS" = Proto.parse0 CLAIMURL_SUCCESS
+	parseCommand "CLAIMURL-AS" = Proto.parse1 CLAIMURL_AS
 	parseCommand "CLAIMURL-FAILURE" = Proto.parse0 CLAIMURL_FAILURE
 	parseCommand "CHECKURL-SIZE" = Proto.parse1 CHECKURL_SIZE
 	parseCommand "CHECKURL-SIZEUNKNOWN" = Proto.parse0 CHECKURL_SIZEUNKNOWN
diff --git a/Types/Remote.hs b/Types/Remote.hs
index baa857906..bb56bb01d 100644
--- a/Types/Remote.hs
+++ b/Types/Remote.hs
@@ -25,6 +25,7 @@ import Types.UUID
 import Types.GitConfig
 import Types.Availability
 import Types.Creds
+import Types.URLClaim
 import Config.Cost
 import Utility.Metered
 import Git.Types
@@ -103,7 +104,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 -> a Bool),
+	claimUrl :: Maybe (URLString -> a (Maybe URLClaim)),
 	-- Checks that the url is accessible, and gets the size of its
 	-- content. Returns Nothing if the url is accessible, but
 	-- its size cannot be determined inexpensively.
diff --git a/Types/URLClaim.hs b/Types/URLClaim.hs
new file mode 100644
index 000000000..f14333111
--- /dev/null
+++ b/Types/URLClaim.hs
@@ -0,0 +1,11 @@
+{- git-annex url claiming
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Types.URLClaim where
+
+data URLClaim = URLClaimed | URLClaimedAs FilePath
+	deriving (Eq)
diff --git a/doc/design/external_special_remote_protocol.mdwn b/doc/design/external_special_remote_protocol.mdwn
index 072c5a1a2..c62949b6d 100644
--- a/doc/design/external_special_remote_protocol.mdwn
+++ b/doc/design/external_special_remote_protocol.mdwn
@@ -179,6 +179,9 @@ while it's handling a request.
   Indicates that INITREMOTE failed.
 * `CLAIMURL-SUCCESS`  
   Indicates that the CLAIMURL url will be handled by this remote.
+* `CLAIMURL-AS Filename`
+  Indicates that the CLAIMURL url will be handled by this remote,
+  and suggests a filename to use for it.
 * `CLAIMURL-FAILURE`  
   Indicates that the CLAIMURL url wil not be handled by this remote.
 * `CHECKURL-SIZE Size`