diff options
| -rw-r--r-- | Logs/PreferredContent.hs | 15 | ||||
| -rw-r--r-- | Logs/PreferredContent/Raw.hs | 31 | ||||
| -rw-r--r-- | Remote/External.hs | 17 | ||||
| -rw-r--r-- | Remote/External/Types.hs | 5 | ||||
| -rw-r--r-- | debian/changelog | 2 | ||||
| -rw-r--r-- | doc/design/external_special_remote_protocol.mdwn | 10 |
6 files changed, 61 insertions, 19 deletions
diff --git a/Logs/PreferredContent.hs b/Logs/PreferredContent.hs index 26eaaaece..2a9aed36b 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 000000000..63f6118e4 --- /dev/null +++ b/Logs/PreferredContent/Raw.hs @@ -0,0 +1,31 @@ +{- unparsed preferred content expressions + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + - + - 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 3a567d834..f682d242d 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 40bd8d52e..e925f0e91 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 b1c159a1a..69b4f98a8 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 8214a48a8..138d9dd18 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 |