summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Propellor/Info.hs24
-rw-r--r--src/Propellor/Property/Dns.hs6
-rw-r--r--src/Propellor/Spin.hs2
-rw-r--r--src/Propellor/Types/Dns.hs33
4 files changed, 48 insertions, 17 deletions
diff --git a/src/Propellor/Info.hs b/src/Propellor/Info.hs
index ed6c2d85..fd295aa3 100644
--- a/src/Propellor/Info.hs
+++ b/src/Propellor/Info.hs
@@ -128,11 +128,11 @@ getOS = fromInfoVal <$> askInfo
-- if the host's IP Property matches the DNS. If the DNS is missing or
-- out of date, the host will instead be contacted directly by IP address.
ipv4 :: String -> Property (HasInfo + UnixLike)
-ipv4 = addDNS . Address . IPv4
+ipv4 = addDNS False . Address . IPv4
-- | Indicate that a host has an AAAA record in the DNS.
ipv6 :: String -> Property (HasInfo + UnixLike)
-ipv6 = addDNS . Address . IPv6
+ipv6 = addDNS False . Address . IPv6
-- | Indicates another name for the host in the DNS.
--
@@ -145,11 +145,21 @@ alias d = pureInfoProperty' ("alias " ++ d) $ mempty
`addInfo` toAliasesInfo [d]
-- A CNAME is added here, but the DNS setup code converts it to an
-- IP address when that makes sense.
- `addInfo` (toDnsInfo $ S.singleton $ CNAME $ AbsDomain d)
-
-addDNS :: Record -> Property (HasInfo + UnixLike)
-addDNS r = pureInfoProperty (rdesc r) (toDnsInfo (S.singleton r))
+ `addInfo` (toDnsInfoPropagated $ S.singleton $ CNAME $ AbsDomain d)
+
+-- | Add a DNS Record.
+addDNS
+ :: Bool
+ -- ^ When used in a container, the DNS info will only
+ -- propagate out the the Host when this is True.
+ -> Record
+ -> Property (HasInfo + UnixLike)
+addDNS prop r
+ | prop = pureInfoProperty (rdesc r) (toDnsInfoPropagated s)
+ | otherwise = pureInfoProperty (rdesc r) (toDnsInfoUnpropagated s)
where
+ s = S.singleton r
+
rdesc (CNAME d) = unwords ["alias", ddesc d]
rdesc (Address (IPv4 addr)) = unwords ["ipv4", addr]
rdesc (Address (IPv6 addr)) = unwords ["ipv6", addr]
@@ -182,7 +192,7 @@ findAlias :: [Host] -> HostName -> Maybe Host
findAlias l hn = M.lookup hn (aliasMap l)
getAddresses :: Info -> [IPAddr]
-getAddresses = mapMaybe getIPAddr . S.toList . fromDnsInfo . fromInfo
+getAddresses = mapMaybe getIPAddr . S.toList . getDnsInfo
hostAddresses :: HostName -> [Host] -> [IPAddr]
hostAddresses hn hosts = maybe [] (getAddresses . hostInfo) (findHost hosts hn)
diff --git a/src/Propellor/Property/Dns.hs b/src/Propellor/Property/Dns.hs
index 889aece5..d99a76b0 100644
--- a/src/Propellor/Property/Dns.hs
+++ b/src/Propellor/Property/Dns.hs
@@ -468,7 +468,7 @@ genZone inzdomain hostmap zdomain soa =
-- So we can just use the IPAddrs.
addcnames :: Host -> [Either WarningMessage (BindDomain, Record)]
addcnames h = concatMap gen $ filter (inDomain zdomain) $
- mapMaybe getCNAME $ S.toList $ fromDnsInfo $ fromInfo info
+ mapMaybe getCNAME $ S.toList $ getDnsInfo info
where
info = hostInfo h
gen c = case getAddresses info of
@@ -483,7 +483,7 @@ genZone inzdomain hostmap zdomain soa =
where
info = hostInfo h
l = zip (repeat $ AbsDomain $ hostName h)
- (S.toList $ S.filter (\r -> isNothing (getIPAddr r) && isNothing (getCNAME r)) (fromDnsInfo $ fromInfo info))
+ (S.toList $ S.filter (\r -> isNothing (getIPAddr r) && isNothing (getCNAME r)) (getDnsInfo info))
-- Simplifies the list of hosts. Remove duplicate entries.
-- Also, filter out any CHAMES where the same domain has an
@@ -531,7 +531,7 @@ genSSHFP domain h = concatMap mk . concat <$> (gen =<< get)
gen = liftIO . mapM genSSHFP' . M.elems . fromMaybe M.empty
mk r = mapMaybe (\d -> if inDomain domain d then Just (d, r) else Nothing)
(AbsDomain hostname : cnames)
- cnames = mapMaybe getCNAME $ S.toList $ fromDnsInfo $ fromInfo info
+ cnames = mapMaybe getCNAME $ S.toList $ getDnsInfo info
hostname = hostName h
info = hostInfo h
diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs
index aeaa4643..88d2b473 100644
--- a/src/Propellor/Spin.hs
+++ b/src/Propellor/Spin.hs
@@ -173,7 +173,7 @@ getSshTarget target hst
return ip
configips = map val $ mapMaybe getIPAddr $
- S.toList $ fromDnsInfo $ fromInfo $ hostInfo hst
+ S.toList $ getDnsInfo $ hostInfo hst
-- Update the privdata, repo url, and git repo over the ssh
-- connection, talking to the user's local propellor instance which is
diff --git a/src/Propellor/Types/Dns.hs b/src/Propellor/Types/Dns.hs
index 87756d81..513f162a 100644
--- a/src/Propellor/Types/Dns.hs
+++ b/src/Propellor/Types/Dns.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE FlexibleInstances #-}
module Propellor.Types.Dns where
@@ -36,17 +37,37 @@ toAliasesInfo l = AliasesInfo (S.fromList l)
fromAliasesInfo :: AliasesInfo -> [HostName]
fromAliasesInfo (AliasesInfo s) = S.toList s
-newtype DnsInfo = DnsInfo { fromDnsInfo :: S.Set Record }
+-- | Use this for DNS Info that should propagate from a container to a
+-- host. For example, this can be used for CNAME to make aliases
+-- of the containers in the host be reflected in the DNS.
+newtype DnsInfoPropagated = DnsInfoPropagated
+ { fromDnsInfoPropagated :: S.Set Record }
deriving (Show, Eq, Ord, Monoid, Typeable)
-toDnsInfo :: S.Set Record -> DnsInfo
-toDnsInfo = DnsInfo
+toDnsInfoPropagated :: S.Set Record -> DnsInfoPropagated
+toDnsInfoPropagated = DnsInfoPropagated
--- | DNS Info is propagated, so that eg, aliases of a container
--- are reflected in the dns for the host where it runs.
-instance IsInfo DnsInfo where
+instance IsInfo DnsInfoPropagated where
propagateInfo _ = PropagateInfo True
+-- | Use this for DNS Info that should not propagate from a container to a
+-- host. For example, an IP address of a container should not influence
+-- the host.
+newtype DnsInfoUnpropagated = DnsInfoUnpropagated
+ { fromDnsInfoUnpropagated :: S.Set Record }
+ deriving (Show, Eq, Ord, Monoid, Typeable)
+
+toDnsInfoUnpropagated :: S.Set Record -> DnsInfoUnpropagated
+toDnsInfoUnpropagated = DnsInfoUnpropagated
+
+-- | Get all DNS Info.
+getDnsInfo :: Info -> S.Set Record
+getDnsInfo i = fromDnsInfoUnpropagated (fromInfo i)
+ `S.union` fromDnsInfoPropagated (fromInfo i)
+
+instance IsInfo DnsInfoUnpropagated where
+ propagateInfo _ = PropagateInfo False
+
-- | Represents a bind 9 named.conf file.
data NamedConf = NamedConf
{ confDomain :: Domain