From 4f70fceb3a79f2c2b746407768faf363d11c11a4 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 31 May 2014 20:39:56 -0400 Subject: got rid of the Attr -> Attr SetAttr hack, and use monoids for Attr The SetAttr hack used to be needed because the hostname was part of the Attr, and was required to be present. Now that it's moved to Host, let's get rid of that, since it tended to waste CPU. --- src/Propellor/Types/Attr.hs | 26 +++++++++++++++++++------- src/Propellor/Types/Dns.hs | 20 ++++++++++++++++++++ 2 files changed, 39 insertions(+), 7 deletions(-) (limited to 'src/Propellor/Types') diff --git a/src/Propellor/Types/Attr.hs b/src/Propellor/Types/Attr.hs index 7f0add10..4c891a46 100644 --- a/src/Propellor/Types/Attr.hs +++ b/src/Propellor/Types/Attr.hs @@ -4,14 +4,14 @@ import Propellor.Types.OS import qualified Propellor.Types.Dns as Dns import qualified Data.Set as S -import qualified Data.Map as M +import Data.Monoid -- | The attributes of a host. data Attr = Attr { _os :: Maybe System , _sshPubKey :: Maybe String , _dns :: S.Set Dns.Record - , _namedconf :: M.Map Dns.Domain Dns.NamedConf + , _namedconf :: Dns.NamedConfMap , _dockerImage :: Maybe String , _dockerRunParams :: [HostName -> String] @@ -29,6 +29,23 @@ instance Eq Attr where in simpl x == simpl y ] +instance Monoid Attr where + mempty = Attr Nothing Nothing mempty mempty Nothing mempty + mappend old new = Attr + { _os = case _os new of + Just v -> Just v + Nothing -> _os old + , _sshPubKey = case _sshPubKey new of + Just v -> Just v + Nothing -> _sshPubKey old + , _dns = _dns new <> _dns old + , _namedconf = _namedconf new <> _namedconf old + , _dockerImage = case _dockerImage new of + Just v -> Just v + Nothing -> _dockerImage old + , _dockerRunParams = _dockerRunParams old <> _dockerRunParams new + } + instance Show Attr where show a = unlines [ "OS " ++ show (_os a) @@ -38,8 +55,3 @@ instance Show Attr where , "docker image " ++ show (_dockerImage a) , "docker run params " ++ show (map (\mk -> mk "") (_dockerRunParams a)) ] - -newAttr :: Attr -newAttr = Attr Nothing Nothing S.empty M.empty Nothing [] - -type SetAttr = Attr -> Attr diff --git a/src/Propellor/Types/Dns.hs b/src/Propellor/Types/Dns.hs index ba6a92dd..66fbd1a4 100644 --- a/src/Propellor/Types/Dns.hs +++ b/src/Propellor/Types/Dns.hs @@ -3,6 +3,8 @@ module Propellor.Types.Dns where import Propellor.Types.OS (HostName) import Data.Word +import Data.Monoid +import qualified Data.Map as M type Domain = String @@ -90,3 +92,21 @@ domainHostName :: BindDomain -> Maybe HostName domainHostName (RelDomain d) = Just d domainHostName (AbsDomain d) = Just d domainHostName RootDomain = Nothing + +newtype NamedConfMap = NamedConfMap (M.Map Domain NamedConf) + deriving (Eq, Ord, Show) + +-- | Adding a Master NamedConf stanza for a particulr domain always +-- overrides an existing Secondary stanza for that domain, while a +-- Secondary stanza is only added when there is no existing Master stanza. +instance Monoid NamedConfMap where + mempty = NamedConfMap M.empty + mappend (NamedConfMap old) (NamedConfMap new) = NamedConfMap $ + M.unionWith combiner new old + where + combiner n o = case (confDnsServerType n, confDnsServerType o) of + (Secondary, Master) -> o + _ -> n + +fromNamedConfMap :: NamedConfMap -> M.Map Domain NamedConf +fromNamedConfMap (NamedConfMap m) = m -- cgit v1.2.3