From 8e3032df2d5c6ddf07e43de4b3bb89cb578ae048 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 1 Jan 2014 20:12:20 -0400 Subject: [PATCH] added GETWANTED, SETWANTED for Tobias's flickr remote This was unexpectedly difficult because of a depdenency cycle. To parse a preferred content expression involves several things that need to operate on the list of remotes. Which needs Remote.External. The only way to avoid this cycle (I tried breaking it at several points) was to skip parsing the expression in SETWANTED. That's sorta ok, because git-annex already has to deal with unparsable preferred content expressions being stored, in order to handle eg, upgrades. But I'm still not very happy that I cannot check it. I feel this is a strong indication that I need to beware of further bloating the special remote protocol interface. --- Logs/PreferredContent.hs | 15 +-------- Logs/PreferredContent/Raw.hs | 31 +++++++++++++++++++ Remote/External.hs | 17 +++++++--- Remote/External/Types.hs | 5 +++ debian/changelog | 2 +- .../external_special_remote_protocol.mdwn | 10 ++++++ 6 files changed, 61 insertions(+), 19 deletions(-) create mode 100644 Logs/PreferredContent/Raw.hs diff --git a/Logs/PreferredContent.hs b/Logs/PreferredContent.hs index 26eaaaeceb..2a9aed36bd 100644 --- a/Logs/PreferredContent.hs +++ b/Logs/PreferredContent.hs @@ -19,9 +19,9 @@ module Logs.PreferredContent ( import qualified Data.Map as M import qualified Data.Set as S import Data.Either -import Data.Time.Clock.POSIX import Common.Annex +import Logs.PreferredContent.Raw import qualified Annex.Branch import qualified Annex import Logs @@ -36,15 +36,6 @@ import Logs.Group import Logs.Remote import Types.StandardGroups -{- Changes the preferred content configuration of a remote. -} -preferredContentSet :: UUID -> PreferredContentExpression -> Annex () -preferredContentSet uuid@(UUID _) val = do - ts <- liftIO getPOSIXTime - Annex.Branch.change preferredContentLog $ - showLog id . changeLog ts uuid val . parseLog Just - Annex.changeState $ \s -> s { Annex.preferredcontentmap = Nothing } -preferredContentSet NoUUID _ = error "unknown UUID; cannot modify" - {- Checks if a file is preferred content for the specified repository - (or the current repository if none is specified). -} isPreferredContent :: Maybe UUID -> AssumeNotPresent -> FilePath -> Bool -> Annex Bool @@ -71,10 +62,6 @@ preferredContentMapLoad = do Annex.changeState $ \s -> s { Annex.preferredcontentmap = Just m } return m -preferredContentMapRaw :: Annex (M.Map UUID PreferredContentExpression) -preferredContentMapRaw = simpleMap . parseLog Just - <$> Annex.Branch.get preferredContentLog - {- This intentionally never fails, even on unparsable expressions, - because the configuration is shared among repositories and newer - versions of git-annex may add new features. Instead, parse errors diff --git a/Logs/PreferredContent/Raw.hs b/Logs/PreferredContent/Raw.hs new file mode 100644 index 0000000000..63f6118e42 --- /dev/null +++ b/Logs/PreferredContent/Raw.hs @@ -0,0 +1,31 @@ +{- unparsed preferred content expressions + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Logs.PreferredContent.Raw where + +import qualified Data.Map as M +import Data.Time.Clock.POSIX + +import Common.Annex +import qualified Annex.Branch +import qualified Annex +import Logs +import Logs.UUIDBased +import Types.StandardGroups + +{- Changes the preferred content configuration of a remote. -} +preferredContentSet :: UUID -> PreferredContentExpression -> Annex () +preferredContentSet uuid@(UUID _) val = do + ts <- liftIO getPOSIXTime + Annex.Branch.change preferredContentLog $ + showLog id . changeLog ts uuid val . parseLog Just + Annex.changeState $ \s -> s { Annex.preferredcontentmap = Nothing } +preferredContentSet NoUUID _ = error "unknown UUID; cannot modify" + +preferredContentMapRaw :: Annex (M.Map UUID PreferredContentExpression) +preferredContentMapRaw = simpleMap . parseLog Just + <$> Annex.Branch.get preferredContentLog diff --git a/Remote/External.hs b/Remote/External.hs index 3a567d834a..f682d242d9 100644 --- a/Remote/External.hs +++ b/Remote/External.hs @@ -18,6 +18,7 @@ import Remote.Helper.Encryptable import Crypto import Utility.Metered import Logs.Transfer +import Logs.PreferredContent.Raw import Config.Cost import Annex.Content import Annex.UUID @@ -206,7 +207,7 @@ handleRequest' lck external req mp responsehandler handleRemoteRequest (PROGRESS bytesprocessed) = maybe noop (\a -> liftIO $ a bytesprocessed) mp handleRemoteRequest (DIRHASH k) = - sendMessage lck external $ VALUE $ hashDirMixed k + send $ VALUE $ hashDirMixed k handleRemoteRequest (SETCONFIG setting value) = liftIO $ atomically $ do let v = externalConfig external @@ -215,7 +216,7 @@ handleRequest' lck external req mp responsehandler handleRemoteRequest (GETCONFIG setting) = do value <- fromMaybe "" . M.lookup setting <$> liftIO (atomically $ readTMVar $ externalConfig external) - sendMessage lck external $ VALUE value + send $ VALUE value handleRemoteRequest (SETCREDS setting login password) = do c <- liftIO $ atomically $ readTMVar $ externalConfig external c' <- setRemoteCredPair' c (credstorage setting) @@ -225,14 +226,22 @@ handleRequest' lck external req mp responsehandler c <- liftIO $ atomically $ readTMVar $ externalConfig external creds <- fromMaybe ("", "") <$> getRemoteCredPair c (credstorage setting) - sendMessage lck external $ CREDS (fst creds) (snd creds) - handleRemoteRequest GETUUID = sendMessage lck external $ + send $ CREDS (fst creds) (snd creds) + handleRemoteRequest GETUUID = send $ VALUE $ fromUUID $ externalUUID external + handleRemoteRequest (SETWANTED expr) = + preferredContentSet (externalUUID external) expr + handleRemoteRequest GETWANTED = do + expr <- fromMaybe "" . M.lookup (externalUUID external) + <$> preferredContentMapRaw + send $ VALUE expr handleRemoteRequest (VERSION _) = sendMessage lck external $ ERROR "too late to send VERSION" handleAsyncMessage (ERROR err) = error $ "external special remote error: " ++ err + send = sendMessage lck external + credstorage setting = CredPairStorage { credPairFile = base , credPairEnvironment = (base ++ "login", base ++ "password") diff --git a/Remote/External/Types.hs b/Remote/External/Types.hs index 40bd8d52e8..e925f0e91e 100644 --- a/Remote/External/Types.hs +++ b/Remote/External/Types.hs @@ -33,6 +33,7 @@ module Remote.External.Types ( import Common.Annex import Annex.Exception import Types.Key (file2key, key2file) +import Types.StandardGroups (PreferredContentExpression) import Utility.Metered (BytesProcessed(..)) import Logs.Transfer (Direction(..)) import Config.Cost (Cost) @@ -167,6 +168,8 @@ data RemoteRequest | SETCREDS Setting String String | GETCREDS Setting | GETUUID + | SETWANTED PreferredContentExpression + | GETWANTED deriving (Show) instance Receivable RemoteRequest where @@ -178,6 +181,8 @@ instance Receivable RemoteRequest where parseCommand "SETCREDS" = parse3 SETCREDS parseCommand "GETCREDS" = parse1 GETCREDS parseCommand "GETUUID" = parse0 GETUUID + parseCommand "SETWANTED" = parse1 SETWANTED + parseCommand "GETWANTED" = parse0 GETWANTED parseCommand _ = parseFail -- Responses to RemoteRequest. diff --git a/debian/changelog b/debian/changelog index b1c159a1ac..69b4f98a8a 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,7 +1,7 @@ git-annex (5.20131231) UNRELEASED; urgency=medium * mirror: Support --all (and --unused). - * external special remote protocol: Added GETUUID. + * external special remote protocol: Added GETUUID, GETWANTED, SETWANTED. * Windows: Fix bug in direct mode merge code that could cause files in subdirectories to go missing. * Windows: Avoid eating stdin when running ssh to add a authorized key, diff --git a/doc/design/external_special_remote_protocol.mdwn b/doc/design/external_special_remote_protocol.mdwn index 8214a48a80..138d9dd182 100644 --- a/doc/design/external_special_remote_protocol.mdwn +++ b/doc/design/external_special_remote_protocol.mdwn @@ -212,6 +212,16 @@ in control. * `GETUUID` Queries for the UUID of the special remote being used. (git-annex replies with VALUE followed by the UUID.) +* `SETWANTED PreferredContentExpression` + Can be used to set the preferred content of a repository. Normally + this is not configured by a special remote, but it may make sense + in some situations to hint at the kind of content that should be stored + in the special remote. Note that if a unparsable expression is set, + git-annex will ignore it. +* `GETWANTED` + Gets the current preferred content setting of the repository. + (git-annex replies with VALUE followed by the preferred content + expression.) ## general messages