mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

implement GETCONFIG and SETCONFIG

Browse source 
Changed protocol spec to make SETCONFIG only store it persistently when run
during INITREMOTE. I see no reason to support storing it persistently at
other times, and doing so would unnecessarily complicate the code.

Also, letting that be done would probably result in use for storing data that
doesn't really belong there, and special remote authors who don't
understand how the union merging works would probably be surprised the
results.
This commit is contained in:
Joey Hess 2013-12-27 12:37:23 -04:00
parent d8741e571d
commit a7f3724e21
3 changed files with 34 additions and 19 deletions
Download patch file Download diff file Expand all files Collapse all files

20
Remote/External.hs
View file

@ -39,7 +39,7 @@ remote = RemoteType {
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
gen r u c gc = do
external <- newExternal externaltype
external <- newExternal externaltype c
Annex.addCleanup (fromUUID u) $ stopExternal external
cst <- getCost external r gc
return $ Just $ encryptableRemote c
@ -76,14 +76,15 @@ externalSetup mu c = do
M.lookup "externaltype" c
c' <- encryptionSetup c
external <- newExternal externaltype
external <- newExternal externaltype 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
gitConfigSpecialRemote u c' "externaltype" externaltype
return (c', u)
gitConfigSpecialRemote u c'' "externaltype" externaltype
return (c'', u)
store :: External -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
store external k _f p = sendAnnex k rollback $ \f ->
@ -201,8 +202,15 @@ handleRequest' lck external req mp responsehandler = do
maybe noop (\a -> liftIO $ a bytesprocessed) mp
handleRemoteRequest (DIRHASH k) =
sendMessage lck external (VALUE $ hashDirMixed k)
handleRemoteRequest (SETCONFIG setting value) = error "TODO"
handleRemoteRequest (GETCONFIG setting) = error "TODO"
handleRemoteRequest (SETCONFIG setting value) =
liftIO $ atomically $ do
let v = externalConfig external
m <- takeTMVar v
putTMVar v $ M.insert setting value m
handleRemoteRequest (GETCONFIG setting) = do
value <- fromMaybe "" . M.lookup setting
<$> liftIO (atomically $ readTMVar $ externalConfig external)
sendMessage lck external (VALUE value)
handleRemoteRequest (SETSTATE k value) = error "TODO"
handleRemoteRequest (GETSTATE k) = error "TODO"
handleRemoteRequest (VERSION _) =

16
Remote/External/Types.hs vendored
View file

@ -30,11 +30,12 @@ module Remote.External.Types (
) where
import Common.Annex
import Types.Key
import Utility.Metered
import Logs.Transfer
import Config.Cost
import Annex.Exception
import Types.Key (file2key, key2file)
import Utility.Metered (BytesProcessed(..))
import Logs.Transfer (Direction(..))
import Config.Cost (Cost)
import Types.Remote (RemoteConfig)
import Data.Char
import Control.Concurrent.STM
@ -47,13 +48,16 @@ data External = External
, externalState :: TMVar ExternalState
-- Empty when a remote is in use.
, externalLock :: TMVar ExternalLock
-- Never left empty.
, externalConfig :: TMVar RemoteConfig
}
newExternal :: ExternalType -> Annex External
newExternal externaltype = liftIO $ External
newExternal :: ExternalType -> RemoteConfig -> Annex External
newExternal externaltype c = liftIO $ External
<$> pure externaltype
<*> atomically newEmptyTMVar
<*> atomically (newTMVar ExternalLock)
<*> atomically (newTMVar c)
type ExternalType = String