summaryrefslogtreecommitdiff
path: root/src/Propellor/Attr.hs
blob: e2b64bf0f5af0d448bec93e660fc16e0d4c6e454 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
{-# LANGUAGE PackageImports #-}

module Propellor.Attr where

import Propellor.Types
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 -> SetAttr -> Property 
pureAttrProperty desc = Property ("has " ++ desc) (return NoChange)

hostname :: HostName -> Property
hostname name = pureAttrProperty ("hostname " ++ name) $
	\d -> d { _hostname = name }

getHostName :: Propellor HostName
getHostName = asks _hostname

os :: System -> Property
os system = pureAttrProperty ("Operating " ++ show system) $
	\d -> d { _os = Just system }

getOS :: Propellor (Maybe System)
getOS = asks _os

-- | 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 = addDNS . Address . IPv4

-- | Indidate that a host has an AAAA record in the DNS.
ipv6 :: String -> Property
ipv6 = addDNS . Address . IPv6

-- | Indicates another name for the host in the DNS.
alias :: Domain -> Property
alias = addDNS . CNAME . AbsDomain

addDNS :: Record -> Property
addDNS r = pureAttrProperty (rdesc r) $
	\d -> d { _dns = S.insert r (_dns d) }
  where
	rdesc (CNAME d) = unwords ["alias", ddesc d]
	rdesc (Address (IPv4 addr)) = unwords ["ipv4", addr]
	rdesc (Address (IPv6 addr)) = unwords ["ipv6", addr]
	rdesc (MX n d) = unwords ["MX", show n, ddesc d]
	rdesc (NS d) = unwords ["NS", ddesc d]
	rdesc (TXT s) = unwords ["TXT", s]
	rdesc (SRV x y z d) = unwords ["SRV", show x, show y, show z, ddesc d]

	ddesc (AbsDomain domain) = domain
	ddesc (RelDomain domain) = domain
	ddesc RootDomain = "@"

-- | 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 (confDnsServerType conf, confDnsServerType <$> 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 }

getSshPubKey :: Propellor (Maybe String)
getSshPubKey = asks _sshPubKey

hostnameless :: Attr
hostnameless = newAttr (error "hostname Attr not specified")

hostAttr :: Host -> Attr
hostAttr (Host _ mkattrs) = mkattrs hostnameless

hostProperties :: Host -> [Property]
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`
fromHost :: [Host] -> HostName -> Propellor a -> Propellor (Maybe a)
fromHost l hn getter = case findHost l hn of
	Nothing -> return Nothing
	Just h -> liftIO $ Just <$>
		runReaderT (runWithAttr getter) (hostAttr h)