implement GETCONFIG and SETCONFIG
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:
parent
d8741e571d
commit
a7f3724e21
3 changed files with 34 additions and 19 deletions
|
@ -39,7 +39,7 @@ remote = RemoteType {
|
||||||
|
|
||||||
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
|
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
|
||||||
gen r u c gc = do
|
gen r u c gc = do
|
||||||
external <- newExternal externaltype
|
external <- newExternal externaltype c
|
||||||
Annex.addCleanup (fromUUID u) $ stopExternal external
|
Annex.addCleanup (fromUUID u) $ stopExternal external
|
||||||
cst <- getCost external r gc
|
cst <- getCost external r gc
|
||||||
return $ Just $ encryptableRemote c
|
return $ Just $ encryptableRemote c
|
||||||
|
@ -76,14 +76,15 @@ externalSetup mu c = do
|
||||||
M.lookup "externaltype" c
|
M.lookup "externaltype" c
|
||||||
c' <- encryptionSetup c
|
c' <- encryptionSetup c
|
||||||
|
|
||||||
external <- newExternal externaltype
|
external <- newExternal externaltype c'
|
||||||
handleRequest external INITREMOTE Nothing $ \resp -> case resp of
|
handleRequest external INITREMOTE Nothing $ \resp -> case resp of
|
||||||
INITREMOTE_SUCCESS -> Just noop
|
INITREMOTE_SUCCESS -> Just noop
|
||||||
INITREMOTE_FAILURE errmsg -> Just $ error errmsg
|
INITREMOTE_FAILURE errmsg -> Just $ error errmsg
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
|
c'' <- liftIO $ atomically $ readTMVar $ externalConfig external
|
||||||
|
|
||||||
gitConfigSpecialRemote u c' "externaltype" externaltype
|
gitConfigSpecialRemote u c'' "externaltype" externaltype
|
||||||
return (c', u)
|
return (c'', u)
|
||||||
|
|
||||||
store :: External -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
|
store :: External -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
|
||||||
store external k _f p = sendAnnex k rollback $ \f ->
|
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
|
maybe noop (\a -> liftIO $ a bytesprocessed) mp
|
||||||
handleRemoteRequest (DIRHASH k) =
|
handleRemoteRequest (DIRHASH k) =
|
||||||
sendMessage lck external (VALUE $ hashDirMixed k)
|
sendMessage lck external (VALUE $ hashDirMixed k)
|
||||||
handleRemoteRequest (SETCONFIG setting value) = error "TODO"
|
handleRemoteRequest (SETCONFIG setting value) =
|
||||||
handleRemoteRequest (GETCONFIG setting) = error "TODO"
|
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 (SETSTATE k value) = error "TODO"
|
||||||
handleRemoteRequest (GETSTATE k) = error "TODO"
|
handleRemoteRequest (GETSTATE k) = error "TODO"
|
||||||
handleRemoteRequest (VERSION _) =
|
handleRemoteRequest (VERSION _) =
|
||||||
|
|
16
Remote/External/Types.hs
vendored
16
Remote/External/Types.hs
vendored
|
@ -30,11 +30,12 @@ module Remote.External.Types (
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Common.Annex
|
import Common.Annex
|
||||||
import Types.Key
|
|
||||||
import Utility.Metered
|
|
||||||
import Logs.Transfer
|
|
||||||
import Config.Cost
|
|
||||||
import Annex.Exception
|
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 Data.Char
|
||||||
import Control.Concurrent.STM
|
import Control.Concurrent.STM
|
||||||
|
@ -47,13 +48,16 @@ data External = External
|
||||||
, externalState :: TMVar ExternalState
|
, externalState :: TMVar ExternalState
|
||||||
-- Empty when a remote is in use.
|
-- Empty when a remote is in use.
|
||||||
, externalLock :: TMVar ExternalLock
|
, externalLock :: TMVar ExternalLock
|
||||||
|
-- Never left empty.
|
||||||
|
, externalConfig :: TMVar RemoteConfig
|
||||||
}
|
}
|
||||||
|
|
||||||
newExternal :: ExternalType -> Annex External
|
newExternal :: ExternalType -> RemoteConfig -> Annex External
|
||||||
newExternal externaltype = liftIO $ External
|
newExternal externaltype c = liftIO $ External
|
||||||
<$> pure externaltype
|
<$> pure externaltype
|
||||||
<*> atomically newEmptyTMVar
|
<*> atomically newEmptyTMVar
|
||||||
<*> atomically (newTMVar ExternalLock)
|
<*> atomically (newTMVar ExternalLock)
|
||||||
|
<*> atomically (newTMVar c)
|
||||||
|
|
||||||
type ExternalType = String
|
type ExternalType = String
|
||||||
|
|
||||||
|
|
|
@ -177,14 +177,17 @@ in control.
|
||||||
creating hash directory structures to store Keys in.
|
creating hash directory structures to store Keys in.
|
||||||
(git-annex replies with VALUE followed by the value.)
|
(git-annex replies with VALUE followed by the value.)
|
||||||
* `SETCONFIG Setting`
|
* `SETCONFIG Setting`
|
||||||
Sets one of the special remote's configuration settings. These settings
|
Sets one of the special remote's configuration settings.
|
||||||
are stored in the git-annex branch, so will be available if the same
|
Normally this is sent during INITREMOTE, which allows these settings
|
||||||
special remote is used elsewhere.
|
to be stored in the git-annex branch, so will be available if the same
|
||||||
(Typically only done during INITREMOTE, although it is accepted at other
|
special remote is used elsewhere. (If sent after INITREMOTE, the changed
|
||||||
times.)
|
configuration will only be available while the remote is running.)
|
||||||
* `GETCONFIG Setting`
|
* `GETCONFIG Setting`
|
||||||
Gets one of the special remote's configuration settings.
|
Gets one of the special remote's configuration settings, which can have
|
||||||
(git-annex replies with VALUE followed by the value.)
|
been passed by the user when running `git annex initremote`, or
|
||||||
|
can have been set by a previous SETCONFIG. Can be run at any time.
|
||||||
|
(git-annex replies with VALUE followed by the value. If the setting is
|
||||||
|
not set, the value will be empty.)
|
||||||
* `SETSTATE Key Value`
|
* `SETSTATE Key Value`
|
||||||
git-annex can store state in the git-annex branch on a
|
git-annex can store state in the git-annex branch on a
|
||||||
per-special-remote, per-key basis. This sets that state.
|
per-special-remote, per-key basis. This sets that state.
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue