add sameas inherited configs to newConfig
This makes initremote --sameas work with encryption inherited.
This commit is contained in:
parent
2bd6e81bb0
commit
91eed85fd4
5 changed files with 46 additions and 35 deletions
|
@ -33,12 +33,21 @@ findExisting name = do
|
|||
. findByName name
|
||||
<$> Logs.Remote.readRemoteLog
|
||||
|
||||
newConfig :: RemoteName -> Maybe (Sameas UUID) -> RemoteConfig
|
||||
newConfig name Nothing = M.singleton nameField name
|
||||
newConfig name (Just (Sameas u)) = M.fromList
|
||||
[ (sameasNameField, name)
|
||||
, (sameasUUIDField, fromUUID u)
|
||||
]
|
||||
newConfig
|
||||
:: RemoteName
|
||||
-> Maybe (Sameas UUID)
|
||||
-> RemoteConfig
|
||||
-- ^ configuration provided by the user
|
||||
-> M.Map UUID RemoteConfig
|
||||
-- ^ configuration of other special remotes, to inherit from
|
||||
-- when sameas is used
|
||||
-> RemoteConfig
|
||||
newConfig name sameas fromuser m = case sameas of
|
||||
Nothing -> M.insert nameField name fromuser
|
||||
Just (Sameas u) -> addSameasInherited m $ M.fromList
|
||||
[ (sameasNameField, name)
|
||||
, (sameasUUIDField, fromUUID u)
|
||||
] `M.union` fromuser
|
||||
|
||||
findByName :: RemoteName -> M.Map UUID RemoteConfig -> [(UUID, RemoteConfig)]
|
||||
findByName n = filter (matching . snd) . M.toList
|
||||
|
|
|
@ -9,6 +9,7 @@ module Annex.SpecialRemote.Config where
|
|||
|
||||
import Common
|
||||
import Types.Remote (RemoteConfigField, RemoteConfig)
|
||||
import Types.UUID
|
||||
|
||||
import qualified Data.Map as M
|
||||
import qualified Data.Set as S
|
||||
|
@ -70,3 +71,24 @@ sameasInherits = S.fromList
|
|||
-- (new-style chunking does not have that limitation)
|
||||
, chunksizeField
|
||||
]
|
||||
|
||||
{- Each RemoteConfig that has a sameas-uuid inherits some fields
|
||||
- from it. Such fields can only be set by inheritance; the RemoteConfig
|
||||
- cannot provide values from them. -}
|
||||
addSameasInherited :: M.Map UUID RemoteConfig -> RemoteConfig -> RemoteConfig
|
||||
addSameasInherited m c = case toUUID <$> M.lookup sameasUUIDField c of
|
||||
Nothing -> c
|
||||
Just sameasuuid -> case M.lookup sameasuuid m of
|
||||
Nothing -> c
|
||||
Just parentc ->
|
||||
M.withoutKeys c sameasInherits
|
||||
`M.union`
|
||||
M.restrictKeys parentc sameasInherits
|
||||
|
||||
{- Remove any fields inherited from a sameas-uuid. When storing a
|
||||
- RemoteConfig, those fields don't get stored, since they were already
|
||||
- inherited. -}
|
||||
removeSameasInherited :: RemoteConfig -> RemoteConfig
|
||||
removeSameasInherited c = case M.lookup sameasUUIDField c of
|
||||
Nothing -> c
|
||||
Just _ -> M.restrictKeys c sameasInherits
|
||||
|
|
|
@ -52,7 +52,7 @@ makeRsyncRemote name location = makeRemote name location $ const $ void $
|
|||
go =<< Annex.SpecialRemote.findExisting name
|
||||
where
|
||||
go Nothing = setupSpecialRemote name Rsync.remote config Nothing
|
||||
(Nothing, R.Init, Annex.SpecialRemote.newConfig name Nothing)
|
||||
(Nothing, R.Init, Annex.SpecialRemote.newConfig name Nothing mempty mempty)
|
||||
go (Just (u, c)) = setupSpecialRemote name Rsync.remote config Nothing
|
||||
(Just u, R.Enable c, c)
|
||||
config = M.fromList
|
||||
|
@ -83,7 +83,7 @@ initSpecialRemote name remotetype mcreds config = go 0
|
|||
let fullname = if n == 0 then name else name ++ show n
|
||||
Annex.SpecialRemote.findExisting fullname >>= \case
|
||||
Nothing -> setupSpecialRemote fullname remotetype config mcreds
|
||||
(Nothing, R.Init, Annex.SpecialRemote.newConfig fullname Nothing)
|
||||
(Nothing, R.Init, Annex.SpecialRemote.newConfig fullname Nothing mempty mempty)
|
||||
Just _ -> go (n + 1)
|
||||
|
||||
{- Enables an existing special remote. -}
|
||||
|
|
|
@ -15,6 +15,7 @@ import qualified Remote
|
|||
import qualified Logs.Remote
|
||||
import qualified Types.Remote as R
|
||||
import Logs.UUID
|
||||
import Logs.Remote
|
||||
import Types.GitConfig
|
||||
|
||||
cmd :: Command
|
||||
|
@ -57,14 +58,14 @@ start o (name:ws) = ifM (isJust <$> findExisting name)
|
|||
(pure Nothing)
|
||||
(Just . Sameas <$$> getParsed)
|
||||
(sameas o)
|
||||
let c = newConfig name sameasuuid
|
||||
t <- either giveup return (findType config)
|
||||
c <- newConfig name sameasuuid
|
||||
(Logs.Remote.keyValToConfig ws)
|
||||
<$> readRemoteLog
|
||||
t <- either giveup return (findType c)
|
||||
starting "initremote" (ActionItemOther (Just name)) $
|
||||
perform t name $ M.union config c
|
||||
perform t name c
|
||||
)
|
||||
)
|
||||
where
|
||||
config = Logs.Remote.keyValToConfig ws
|
||||
|
||||
perform :: RemoteType -> String -> R.RemoteConfig -> CommandPerform
|
||||
perform t name c = do
|
||||
|
|
|
@ -40,32 +40,11 @@ configSet u cfg = do
|
|||
|
||||
{- Map of remotes by uuid containing key/value config maps. -}
|
||||
readRemoteLog :: Annex (M.Map UUID RemoteConfig)
|
||||
readRemoteLog = addSameasInherited
|
||||
readRemoteLog = (\m -> M.map (addSameasInherited m) m)
|
||||
. simpleMap
|
||||
. parseLogOld remoteConfigParser
|
||||
<$> Annex.Branch.get remoteLog
|
||||
|
||||
{- Each RemoteConfig that has a sameas-uuid inherits some fields
|
||||
- from it. Such fields can only be set by inheritance; the RemoteConfig
|
||||
- cannot provide values from them. -}
|
||||
addSameasInherited :: M.Map UUID RemoteConfig -> M.Map UUID RemoteConfig
|
||||
addSameasInherited m = M.map go m
|
||||
where
|
||||
go c = case toUUID <$> M.lookup sameasUUIDField c of
|
||||
Nothing -> c
|
||||
Just sameasuuid -> case M.lookup sameasuuid m of
|
||||
Nothing -> c
|
||||
Just parentc ->
|
||||
M.withoutKeys c sameasInherits
|
||||
`M.union`
|
||||
M.restrictKeys parentc sameasInherits
|
||||
|
||||
{- Remove any fields inherited from a sameas-uuid. -}
|
||||
removeSameasInherited :: RemoteConfig -> RemoteConfig
|
||||
removeSameasInherited c = case M.lookup sameasUUIDField c of
|
||||
Nothing -> c
|
||||
Just _ -> M.restrictKeys c sameasInherits
|
||||
|
||||
remoteConfigParser :: A.Parser RemoteConfig
|
||||
remoteConfigParser = keyValToConfig . words . decodeBS <$> A.takeByteString
|
||||
|
||||
|
|
Loading…
Reference in a new issue