diff --git a/Annex/SpecialRemote.hs b/Annex/SpecialRemote.hs index 3a19bb4073..23db7f0720 100644 --- a/Annex/SpecialRemote.hs +++ b/Annex/SpecialRemote.hs @@ -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 diff --git a/Annex/SpecialRemote/Config.hs b/Annex/SpecialRemote/Config.hs index 921d7744b8..124addc0b2 100644 --- a/Annex/SpecialRemote/Config.hs +++ b/Annex/SpecialRemote/Config.hs @@ -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 diff --git a/Assistant/MakeRemote.hs b/Assistant/MakeRemote.hs index a58ed212c4..03a2fa2dd0 100644 --- a/Assistant/MakeRemote.hs +++ b/Assistant/MakeRemote.hs @@ -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. -} diff --git a/Command/InitRemote.hs b/Command/InitRemote.hs index 04873b5f39..aa5c07883a 100644 --- a/Command/InitRemote.hs +++ b/Command/InitRemote.hs @@ -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 diff --git a/Logs/Remote.hs b/Logs/Remote.hs index c99df1bab9..2b767c2f4a 100644 --- a/Logs/Remote.hs +++ b/Logs/Remote.hs @@ -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