summaryrefslogtreecommitdiff
path: root/Remote
diff options
context:
space:
mode:
authorGravatar Joey Hess <joeyh@joeyh.name>2015-08-17 11:22:22 -0400
committerGravatar Joey Hess <joeyh@joeyh.name>2015-08-17 11:22:22 -0400
commitefaffb47e901357fc8ffeb224d240c1f9238fbeb (patch)
treede0044a3c5ebe7f7dae48c64a9d37822c987a9f9 /Remote
parenta5cb01cd4f6e90786ef738e7d666ff363e5b6828 (diff)
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.
Diffstat (limited to 'Remote')
-rw-r--r--Remote/External.hs94
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