External special remotes can now be built that can be used in readonly mode, where git-annex downloads content from the remote using regular http.

Note that, if an url is added to the web log for such a remote, it's not
distinguishable from another url that might be added for the web remote.
(Because the web log doesn't distinguish which remote owns a plain url.
Urls with a downloader set are distinguishable, but we're not using them
here.)

This seems ok-ish.. In such a case, both remotes will try to use both
urls, and both remotes should be able to.

The only issue I see is that dropping a file from the web remote will
remove both urls in this case. This is not often done, and could even
be considered a feature, I suppose.

1 files changed, 72 insertions, 22 deletions

diff --git a/Remote/External.hs b/Remote/External.hs
index cd062e0c2..9f8bd4ccf 100644
--- a/Remote/External.hs
+++ b/Remote/External.hs
@@ -1,6 +1,6 @@
 {- External special remote interface.
  -
- - Copyright 2013 Joey Hess <id@joeyh.name>
+ - Copyright 2013-2015 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -13,9 +13,13 @@ import Common.Annex
 import Types.Remote
 import Types.CleanupActions
 import Types.UrlContents
+import Types.Key
 import qualified Git
 import Config
+import Git.Config (isTrue, boolConfig)
 import Remote.Helper.Special
+import Remote.Helper.ReadOnly
+import Remote.Helper.Messages
 import Utility.Metered
 import Messages.Progress
 import Logs.Transfer
@@ -23,6 +27,8 @@ import Logs.PreferredContent.Raw
 import Logs.RemoteState
 import Logs.Web
 import Config.Cost
+import Annex.Content
+import Annex.Url
 import Annex.UUID
 import Creds
 
@@ -40,17 +46,34 @@ remote = RemoteType {
 }
 
 gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
-gen r u c gc = do
-	external <- newExternal externaltype u c
-	Annex.addCleanup (RemoteCleanup u) $ stopExternal external
-	cst <- getCost external r gc
-	avail <- getAvailability external r gc
-	return $ Just $ specialRemote c
-		(simplyPrepare $ store external)
-		(simplyPrepare $ retrieve external)
-		(simplyPrepare $ remove external)
-		(simplyPrepare $ checkKey external)
-		Remote
+gen r u c gc
+	-- readonly mode only downloads urls; does not use external program
+	| remoteAnnexReadOnly gc = do
+		cst <- remoteCost gc expensiveRemoteCost
+		mk cst GloballyAvailable
+			readonlyStorer
+			retrieveUrl
+			readonlyRemoveKey
+			(checkKeyUrl r)
+			Nothing
+			Nothing
+			Nothing
+	| otherwise = do
+		external <- newExternal externaltype u c
+		Annex.addCleanup (RemoteCleanup u) $ stopExternal external
+		cst <- getCost external r gc
+		avail <- getAvailability external r gc
+		mk cst avail
+			(store external)
+			(retrieve external)
+			(remove external)
+			(checkKey external)
+			(Just (whereis external))
+			(Just (claimurl external))
+			(Just (checkurl external))
+  where
+	mk cst avail tostore toretrieve toremove tocheckkey towhereis toclaimurl tocheckurl = do
+		let rmt = Remote
 			{ uuid = u
 			, cost = cst
 			, name = Git.repoDescribe r
@@ -60,7 +83,7 @@ gen r u c gc = do
 			, removeKey = removeKeyDummy
 			, checkPresent = checkPresentDummy
 			, checkPresentCheap = False
-			, whereisKey = Just $ whereis external
+			, whereisKey = towhereis
 			, remoteFsck = Nothing
 			, repairRepo = Nothing
 			, config = c
@@ -73,10 +96,15 @@ gen r u c gc = do
 			, mkUnavailable = gen r u c $
 				gc { remoteAnnexExternalType = Just "!dne!" }
 			, getInfo = return [("externaltype", externaltype)]
-			, claimUrl = Just (claimurl external)
-			, checkUrl = Just (checkurl external)
+			, claimUrl = toclaimurl
+			, checkUrl = tocheckurl
 			}
-  where
+		return $ Just $ specialRemote c
+			(simplyPrepare tostore)
+			(simplyPrepare toretrieve)
+			(simplyPrepare toremove)
+			(simplyPrepare tocheckkey)
+			rmt
 	externaltype = fromMaybe (error "missing externaltype") (remoteAnnexExternalType gc)
 
 externalSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
@@ -86,12 +114,17 @@ externalSetup mu _ c = do
 		M.lookup "externaltype" c
 	(c', _encsetup) <- encryptionSetup c
 
-	external <- newExternal externaltype u c'
-	handleRequest external INITREMOTE Nothing $ \resp -> case resp of
-		INITREMOTE_SUCCESS -> Just noop
-		INITREMOTE_FAILURE errmsg -> Just $ error errmsg
-		_ -> Nothing
-	c'' <- liftIO $ atomically $ readTMVar $ externalConfig external
+	c'' <- case M.lookup "readonly" c of
+		Just v | isTrue v == Just True -> do
+			setConfig (remoteConfig (fromJust (M.lookup "name" c)) "readonly") (boolConfig True)
+			return c'
+		_ -> do
+			external <- newExternal externaltype u c'
+			handleRequest external INITREMOTE Nothing $ \resp -> case resp of
+				INITREMOTE_SUCCESS -> Just noop
+				INITREMOTE_FAILURE errmsg -> Just $ error errmsg
+				_ -> Nothing
+			liftIO $ atomically $ readTMVar $ externalConfig external
 
 	gitConfigSpecialRemote u c'' "externaltype" externaltype
 	return (c'', u)
@@ -467,3 +500,20 @@ checkurl external url =
 		_ -> Nothing
   where
 	mkmulti (u, s, f) = (u, s, mkSafeFilePath f)
+
+retrieveUrl :: Retriever
+retrieveUrl = fileRetriever $ \f k _p -> do
+	us <- getWebUrls k
+	unlessM (downloadUrl us f) $
+		error "failed to download content"
+
+checkKeyUrl :: Git.Repo -> CheckPresent
+checkKeyUrl r k = do
+	showChecking r
+	us <- getWebUrls k
+	anyM (\u -> withUrlOptions $ checkBoth u (keySize k)) us
+
+getWebUrls :: Key -> Annex [URLString]
+getWebUrls key = filter supported <$> getUrls key
+  where
+	supported u = snd (getDownloader u) == WebDownloader