Expand checkurl to support recommended filename, and multi-file-urls

This commit was sponsored by an anonymous bitcoiner.

14 files changed, 38 insertions, 23 deletions

diff --git a/Remote/Bup.hs b/Remote/Bup.hs
index 405ce3056..16f73a66f 100644
--- a/Remote/Bup.hs
+++ b/Remote/Bup.hs
@@ -75,7 +75,7 @@ gen r u c gc = do
 		, mkUnavailable = return Nothing
 		, getInfo = return [("repo", buprepo)]
 		, claimUrl = Nothing
-		, checkUrl = const $ return Nothing
+		, checkUrl = Nothing
 		}
 	return $ Just $ specialRemote' specialcfg c
 		(simplyPrepare $ store this buprepo)
diff --git a/Remote/Ddar.hs b/Remote/Ddar.hs
index 1b8003dd8..f77193051 100644
--- a/Remote/Ddar.hs
+++ b/Remote/Ddar.hs
@@ -72,7 +72,7 @@ gen r u c gc = do
 		, mkUnavailable = return Nothing
 		, getInfo = return [("repo", ddarrepo)]
 		, claimUrl = Nothing
-		, checkUrl = const $ return Nothing
+		, checkUrl = Nothing
 		}
 	ddarrepo = fromMaybe (error "missing ddarrepo") $ remoteAnnexDdarRepo gc
 	specialcfg = (specialRemoteCfg c)
diff --git a/Remote/Directory.hs b/Remote/Directory.hs
index fec40baa8..b798ff07c 100644
--- a/Remote/Directory.hs
+++ b/Remote/Directory.hs
@@ -70,7 +70,7 @@ gen r u c gc = do
 				gc { remoteAnnexDirectory = Just "/dev/null" },
 			getInfo = return [("directory", dir)],
 			claimUrl = Nothing,
-			checkUrl = const $ return Nothing
+			checkUrl = Nothing
 		}
   where
 	dir = fromMaybe (error "missing directory") $ remoteAnnexDirectory gc
diff --git a/Remote/External.hs b/Remote/External.hs
index 62671755c..c5330f7ea 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.UrlContents
 import qualified Git
 import Config
 import Remote.Helper.Special
@@ -71,7 +72,7 @@ gen r u c gc = do
 				gc { remoteAnnexExternalType = Just "!dne!" },
 			getInfo = return [("externaltype", externaltype)],
 			claimUrl = Just (claimurl external),
-			checkUrl = checkurl external
+			checkUrl = Just (checkurl external)
 		}
   where
 	externaltype = fromMaybe (error "missing externaltype") (remoteAnnexExternalType gc)
@@ -429,11 +430,14 @@ claimurl external url =
 		UNSUPPORTED_REQUEST -> Just $ return False
 		_ -> Nothing
 
-checkurl :: External -> URLString -> Annex (Maybe Integer)
+checkurl :: External -> URLString -> Annex UrlContents
 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_CONTENTS sz f -> Just $ return $ UrlContents sz
+			(if null f then id else const f)
+		CHECKURL_MULTI l -> Just $ return $ UrlNested $ map mknested l
 		CHECKURL_FAILURE errmsg -> Just $ error errmsg
 		UNSUPPORTED_REQUEST -> error "CHECKURL not implemented by external special remote"
 		_ -> Nothing
+  where
+	mknested (url', sz, f) = (url', UrlContents sz (const f))
diff --git a/Remote/External/Types.hs b/Remote/External/Types.hs
index b00352702..73177d316 100644
--- a/Remote/External/Types.hs
+++ b/Remote/External/Types.hs
@@ -137,8 +137,8 @@ data Response
 	| INITREMOTE_FAILURE ErrorMsg
 	| CLAIMURL_SUCCESS
 	| CLAIMURL_FAILURE
-	| CHECKURL_SIZE Size
-	| CHECKURL_SIZEUNKNOWN
+	| CHECKURL_CONTENTS Size FilePath
+	| CHECKURL_MULTI [(URLString, Size, FilePath)]
 	| CHECKURL_FAILURE ErrorMsg
 	| UNSUPPORTED_REQUEST
 	deriving (Show)
@@ -159,8 +159,8 @@ 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-CONTENTS" = Proto.parse2 CHECKURL_CONTENTS
+	parseCommand "CHECKURL-MULTI" = Proto.parse1 CHECKURL_MULTI
 	parseCommand "CHECKURL-FAILURE" = Proto.parse1 CHECKURL_FAILURE
 	parseCommand "UNSUPPORTED-REQUEST" = Proto.parse0 UNSUPPORTED_REQUEST
 	parseCommand _ = Proto.parseFail
@@ -233,7 +233,7 @@ instance Proto.Receivable AsyncMessage where
 type ErrorMsg = String
 type Setting = String
 type ProtocolVersion = Int
-type Size = Integer
+type Size = Maybe Integer
 
 supportedProtocolVersions :: [ProtocolVersion]
 supportedProtocolVersions = [1]
@@ -263,8 +263,10 @@ instance Proto.Serializable Cost where
 	deserialize = readish
 
 instance Proto.Serializable Size where
-	serialize = show
-	deserialize = readish
+	serialize (Just s) = show s
+	serialize Nothing = "UNKNOWN"
+	deserialize "UNKNOWN" = Just Nothing
+	deserialize s = maybe Nothing (Just . Just) (readish s)
 
 instance Proto.Serializable Availability where
 	serialize GloballyAvailable = "GLOBAL"
@@ -277,3 +279,12 @@ instance Proto.Serializable Availability where
 instance Proto.Serializable BytesProcessed where
 	serialize (BytesProcessed n) = show n
 	deserialize = BytesProcessed <$$> readish
+
+instance Proto.Serializable [(URLString, Size, FilePath)] where
+	serialize = unwords . map go
+	  where
+		go (url, sz, f) = url ++ " " ++ maybe "UNKNOWN" show sz ++ " " ++ f
+	deserialize = Just . go [] . words
+	  where
+		go c (url:sz:f:rest) = go ((url, readish sz, f):c) rest
+		go c _ = reverse c
diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs
index 6bf99c135..2f2ddc9f3 100644
--- a/Remote/GCrypt.hs
+++ b/Remote/GCrypt.hs
@@ -123,7 +123,7 @@ gen' r u c gc = do
 		, mkUnavailable = return Nothing
 		, getInfo = return $ gitRepoInfo r
 		, claimUrl = Nothing
-		, checkUrl = const $ return Nothing
+		, checkUrl = Nothing
 	}
 	return $ Just $ specialRemote' specialcfg c
 		(simplyPrepare $ store this rsyncopts)
diff --git a/Remote/Git.hs b/Remote/Git.hs
index 74fb81965..04823949c 100644
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -161,7 +161,7 @@ gen r u c gc
 			, mkUnavailable = unavailable r u c gc
 			, getInfo = return $ gitRepoInfo r
 			, claimUrl = Nothing
-			, checkUrl = const $ return Nothing
+			, checkUrl = Nothing
 			}
 
 unavailable :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs
index 17f755000..80329b9a9 100644
--- a/Remote/Glacier.hs
+++ b/Remote/Glacier.hs
@@ -70,7 +70,7 @@ gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost
 			getInfo = includeCredsInfo c (AWS.creds u) $
 				[ ("glacier vault", getVault c) ],
 			claimUrl = Nothing,
-			checkUrl = const $ return Nothing
+			checkUrl = Nothing
 		}
 	specialcfg = (specialRemoteCfg c)
 		-- Disabled until jobList gets support for chunks.
diff --git a/Remote/Hook.hs b/Remote/Hook.hs
index 09297a6e2..d0b5f7932 100644
--- a/Remote/Hook.hs
+++ b/Remote/Hook.hs
@@ -63,7 +63,7 @@ gen r u c gc = do
 				gc { remoteAnnexHookType = Just "!dne!" },
 			getInfo = return [("hooktype", hooktype)],
 			claimUrl = Nothing,
-			checkUrl = const $ return Nothing
+			checkUrl = Nothing
 		}
   where
 	hooktype = fromMaybe (error "missing hooktype") $ remoteAnnexHookType gc
diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs
index 7a7f68165..ad5b77d38 100644
--- a/Remote/Rsync.hs
+++ b/Remote/Rsync.hs
@@ -85,7 +85,7 @@ gen r u c gc = do
 			, mkUnavailable = return Nothing
 			, getInfo = return [("url", url)]
 			, claimUrl = Nothing
-			, checkUrl = const $ return Nothing
+			, checkUrl = Nothing
 			}
   where
 	specialcfg = (specialRemoteCfg c)
diff --git a/Remote/S3.hs b/Remote/S3.hs
index f56904729..e0d441292 100644
--- a/Remote/S3.hs
+++ b/Remote/S3.hs
@@ -94,7 +94,7 @@ gen r u c gc = do
 				, Just ("partsize", maybe "unlimited" (roughSize storageUnits False) (getPartSize c))
 				],
 			claimUrl = Nothing,
-			checkUrl = const $ return Nothing
+			checkUrl = Nothing
 		}
 
 s3Setup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
diff --git a/Remote/Tahoe.hs b/Remote/Tahoe.hs
index 8b56bbd50..ac7088bea 100644
--- a/Remote/Tahoe.hs
+++ b/Remote/Tahoe.hs
@@ -87,7 +87,7 @@ gen r u c gc = do
 		mkUnavailable = return Nothing,
 		getInfo = return [],
 		claimUrl = Nothing,
-		checkUrl = const $ return Nothing
+		checkUrl = Nothing
 	}
 
 tahoeSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
diff --git a/Remote/Web.hs b/Remote/Web.hs
index 3845dddf5..639eb7e3b 100644
--- a/Remote/Web.hs
+++ b/Remote/Web.hs
@@ -65,7 +65,7 @@ gen r _ c gc =
 		mkUnavailable = return Nothing,
 		getInfo = return [],
 		claimUrl = Nothing, -- implicitly claims all urls
-		checkUrl = const $ return Nothing
+		checkUrl = Nothing
 	}
 
 downloadKey :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool
diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs
index 57e1dd785..27a87a89c 100644
--- a/Remote/WebDAV.hs
+++ b/Remote/WebDAV.hs
@@ -75,7 +75,7 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
 			getInfo = includeCredsInfo c (davCreds u) $
 				[("url", fromMaybe "unknown" (M.lookup "url" c))],
 			claimUrl = Nothing,
-			checkUrl = const $ return Nothing
+			checkUrl = Nothing
 		}
 		chunkconfig = getChunkConfig c