summaryrefslogtreecommitdiff
path: root/src/Propellor/Types
diff options
context:
space:
mode:
Diffstat (limited to 'src/Propellor/Types')
-rw-r--r--src/Propellor/Types/Attr.hs37
-rw-r--r--src/Propellor/Types/Dns.hs20
2 files changed, 43 insertions, 14 deletions
diff --git a/src/Propellor/Types/Attr.hs b/src/Propellor/Types/Attr.hs
index 8b7d3b09..4c891a46 100644
--- a/src/Propellor/Types/Attr.hs
+++ b/src/Propellor/Types/Attr.hs
@@ -4,15 +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. For example, its hostname.
+-- | The attributes of a host.
data Attr = Attr
- { _hostname :: HostName
- , _os :: Maybe System
+ { _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]
@@ -20,8 +19,7 @@ data Attr = Attr
instance Eq Attr where
x == y = and
- [ _hostname x == _hostname y
- , _os x == _os y
+ [ _os x == _os y
, _dns x == _dns y
, _namedconf x == _namedconf y
, _sshPubKey x == _sshPubKey y
@@ -31,18 +29,29 @@ 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
- [ "hostname " ++ _hostname a
- , "OS " ++ show (_os a)
+ [ "OS " ++ show (_os a)
, "sshPubKey " ++ show (_sshPubKey a)
, "dns " ++ show (_dns a)
, "namedconf " ++ show (_namedconf a)
, "docker image " ++ show (_dockerImage a)
, "docker run params " ++ show (map (\mk -> mk "") (_dockerRunParams a))
]
-
-newAttr :: HostName -> Attr
-newAttr hn = Attr hn 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