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.
This commit is contained in:
parent
f0a6de1ca2
commit
8e3032df2d
6 changed files with 61 additions and 19 deletions
|
@ -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
|
||||
|
|
31
Logs/PreferredContent/Raw.hs
Normal file
31
Logs/PreferredContent/Raw.hs
Normal file
|
@ -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
|
|
@ -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")
|
||||
|
|
5
Remote/External/Types.hs
vendored
5
Remote/External/Types.hs
vendored
|
@ -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.
|
||||
|
|
2
debian/changelog
vendored
2
debian/changelog
vendored
|
@ -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,
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue