summaryrefslogtreecommitdiff
path: root/Propellor/Attr.hs
diff options
context:
space:
mode:
authorJoey Hess2014-04-19 02:10:56 -0400
committerJoey Hess2014-04-19 02:10:56 -0400
commit5dd316a0ad4abce5e81ea19e52caf7b57081cda3 (patch)
tree92070fc17e1a57245e1d0f89d5d3bf8599406d85 /Propellor/Attr.hs
parent5b4f3d109ee7393b1e44cac60b43def2ce4c8b24 (diff)
parent6aeeaaab9073675e8c043d009c97ff62d809975b (diff)
Merge branch 'joeyconfig'
Diffstat (limited to 'Propellor/Attr.hs')
-rw-r--r--Propellor/Attr.hs74
1 files changed, 57 insertions, 17 deletions
diff --git a/Propellor/Attr.hs b/Propellor/Attr.hs
index 94376b0d..05ea3ff5 100644
--- a/Propellor/Attr.hs
+++ b/Propellor/Attr.hs
@@ -8,38 +8,65 @@ import Propellor.Types.Attr
import "mtl" Control.Monad.Reader
import qualified Data.Set as S
import qualified Data.Map as M
+import Data.Maybe
import Control.Applicative
-pureAttrProperty :: Desc -> (Attr -> Attr) -> AttrProperty
-pureAttrProperty desc = AttrProperty $ Property ("has " ++ desc)
- (return NoChange)
+pureAttrProperty :: Desc -> SetAttr -> Property
+pureAttrProperty desc = Property ("has " ++ desc) (return NoChange)
-hostname :: HostName -> AttrProperty
+hostname :: HostName -> Property
hostname name = pureAttrProperty ("hostname " ++ name) $
\d -> d { _hostname = name }
getHostName :: Propellor HostName
getHostName = asks _hostname
-os :: System -> AttrProperty
+os :: System -> Property
os system = pureAttrProperty ("Operating " ++ show system) $
\d -> d { _os = Just system }
getOS :: Propellor (Maybe System)
getOS = asks _os
-cname :: Domain -> AttrProperty
-cname domain = pureAttrProperty ("cname " ++ domain) (addCName domain)
-
-cnameFor :: IsProp p => Domain -> (Domain -> p) -> AttrProperty
-cnameFor domain mkp =
- let p = mkp domain
- in AttrProperty p (addCName domain)
-
-addCName :: HostName -> Attr -> Attr
-addCName domain d = d { _cnames = S.insert domain (_cnames d) }
-
-sshPubKey :: String -> AttrProperty
+-- | Indidate that a host has an A record in the DNS.
+--
+-- TODO check at run time if the host really has this address.
+-- (Can't change the host's address, but as a sanity check.)
+ipv4 :: String -> Property
+ipv4 addr = pureAttrProperty ("ipv4 " ++ addr)
+ (addDNS $ Address $ IPv4 addr)
+
+-- | Indidate that a host has an AAAA record in the DNS.
+ipv6 :: String -> Property
+ipv6 addr = pureAttrProperty ("ipv6 " ++ addr)
+ (addDNS $ Address $ IPv6 addr)
+
+-- | Indicates another name for the host in the DNS.
+alias :: Domain -> Property
+alias domain = pureAttrProperty ("aka " ++ domain)
+ (addDNS $ CNAME $ AbsDomain domain)
+
+addDNS :: Record -> SetAttr
+addDNS record d = d { _dns = S.insert record (_dns d) }
+
+-- | Adds a DNS NamedConf stanza.
+--
+-- Note that adding a Master stanza for a domain always overrides an
+-- existing Secondary stanza, while a Secondary stanza is only added
+-- when there is no existing Master stanza.
+addNamedConf :: NamedConf -> SetAttr
+addNamedConf conf d = d { _namedconf = new }
+ where
+ m = _namedconf d
+ domain = confDomain conf
+ new = case (confType conf, confType <$> M.lookup domain m) of
+ (Secondary, Just Master) -> m
+ _ -> M.insert domain conf m
+
+getNamedConf :: Propellor (M.Map Domain NamedConf)
+getNamedConf = asks _namedconf
+
+sshPubKey :: String -> Property
sshPubKey k = pureAttrProperty ("ssh pubkey known") $
\d -> d { _sshPubKey = Just k }
@@ -58,9 +85,22 @@ hostProperties (Host ps _) = ps
hostMap :: [Host] -> M.Map HostName Host
hostMap l = M.fromList $ zip (map (_hostname . hostAttr) l) l
+hostAttrMap :: [Host] -> M.Map HostName Attr
+hostAttrMap l = M.fromList $ zip (map _hostname attrs) attrs
+ where
+ attrs = map hostAttr l
+
findHost :: [Host] -> HostName -> Maybe Host
findHost l hn = M.lookup hn (hostMap l)
+getAddresses :: Attr -> [IPAddr]
+getAddresses = mapMaybe getIPAddr . S.toList . _dns
+
+hostAddresses :: HostName -> [Host] -> [IPAddr]
+hostAddresses hn hosts = case hostAttr <$> findHost hosts hn of
+ Nothing -> []
+ Just attr -> mapMaybe getIPAddr $ S.toList $ _dns attr
+
-- | Lifts an action into a different host.
--
-- For example, `fromHost hosts "otherhost" getSshPubKey`