summaryrefslogtreecommitdiff
path: root/src/Propellor/Info.hs
blob: f36271743098e7a8aa80110d77521f82ed51f8f7 (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
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
{-# LANGUAGE PackageImports, TypeFamilies, DataKinds, PolyKinds #-}

module Propellor.Info (
	osDebian,
	osBuntish,
	osArchLinux,
	osFreeBSD,
	setInfoProperty,
	addInfoProperty,
	pureInfoProperty,
	pureInfoProperty',
	askInfo,
	getOS,
	hasContainerCapability,
	ipv4,
	ipv6,
	alias,
	addDNS,
	hostMap,
	aliasMap,
	findHost,
	findHostNoAlias,
	getAddresses,
	hostAddresses,
) where

import Propellor.Types
import Propellor.Types.Info
import Propellor.Types.MetaTypes
import Propellor.Types.Container

import "mtl" Control.Monad.Reader
import qualified Data.Set as S
import qualified Data.Map as M
import Data.Maybe
import Data.Monoid
import Control.Applicative
import Prelude

-- | Adds info to a Property.
--
-- The new Property will include HasInfo in its metatypes.
setInfoProperty
	-- -Wredundant-constraints is turned off because
	-- this constraint appears redundant, but is actually
	-- crucial.
	:: (MetaTypes metatypes' ~ (+) HasInfo metatypes, SingI metatypes')
	=> Property metatypes
	-> Info
	-> Property (MetaTypes metatypes')
setInfoProperty (Property _ d a oldi c) newi =
	Property sing d a (oldi <> newi) c

-- | Adds more info to a Property that already HasInfo.
addInfoProperty
	-- -Wredundant-constraints is turned off because
	-- this constraint appears redundant, but is actually
	-- crucial.
	:: (IncludesInfo metatypes ~ 'True)
	=> Property metatypes
	-> Info
	-> Property metatypes
addInfoProperty (Property t d a oldi c) newi =
	Property t d a (oldi <> newi) c

-- | Makes a property that does nothing but set some `Info`.
pureInfoProperty :: (IsInfo v) => Desc -> v -> Property (HasInfo + UnixLike)
pureInfoProperty desc v = pureInfoProperty' desc (toInfo v)

pureInfoProperty' :: Desc -> Info -> Property (HasInfo + UnixLike)
pureInfoProperty' desc i = setInfoProperty p i
  where
	p :: Property UnixLike
	p = property ("has " ++ desc) (return NoChange)

-- | Gets a value from the host's Info.
askInfo :: (IsInfo v) => Propellor v
askInfo = asks (fromInfo . hostInfo)

-- | Checks if a ContainerCapability is set in the current Info.
hasContainerCapability :: ContainerCapability -> Propellor Bool
hasContainerCapability c = elem c
	<$> (askInfo ::  Propellor [ContainerCapability])

-- | Specifies that a host's operating system is Debian,
-- and further indicates the suite and architecture.
-- 
-- This provides info for other Properties, so they can act
-- conditionally on the details of the OS.
--
-- It also lets the type checker know that all the properties of the
-- host must support Debian.
--
-- >	& osDebian (Stable "buster") X86_64
osDebian :: DebianSuite -> Architecture -> Property (HasInfo + Debian)
osDebian = osDebian' Linux

-- Use to specify a different `DebianKernel` than the default `Linux`
--
-- >	& osDebian' KFreeBSD (Stable "buster") X86_64
osDebian' :: DebianKernel -> DebianSuite -> Architecture -> Property (HasInfo + Debian)
osDebian' kernel suite arch = tightenTargets $ os (System (Debian kernel suite) arch)

-- | Specifies that a host's operating system is a well-known Debian
-- derivative founded by a space tourist.
--
-- (The actual name of this distribution is not used in Propellor per
-- <http://joeyh.name/blog/entry/trademark_nonsense/>)
osBuntish :: Release -> Architecture -> Property (HasInfo + Buntish)
osBuntish release arch = tightenTargets $ os (System (Buntish release) arch)

-- | Specifies that a host's operating system is FreeBSD
-- and further indicates the release and architecture.
osFreeBSD :: FreeBSDRelease -> Architecture -> Property (HasInfo + FreeBSD)
osFreeBSD release arch = tightenTargets $ os (System (FreeBSD release) arch)

-- | Specifies that a host's operating system is Arch Linux
osArchLinux :: Architecture -> Property (HasInfo + ArchLinux)
osArchLinux arch = tightenTargets $ os (System (ArchLinux) arch)

os :: System -> Property (HasInfo + UnixLike)
os system = pureInfoProperty ("Operating " ++ show system) (InfoVal system)

--  Gets the operating system of a host, if it has been specified.
getOS :: Propellor (Maybe System)
getOS = fromInfoVal <$> askInfo

-- | Indicate that a host has an A record in the DNS.
--
-- When propellor is used to deploy a DNS server for a domain,
-- the hosts in the domain are found by looking for these
-- and similar properites.
--
-- When propellor --spin is used to deploy a host, it checks
-- 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 False . Address . IPv4

-- | Indicate that a host has an AAAA record in the DNS.
ipv6 :: String -> Property (HasInfo + UnixLike)
ipv6 = addDNS False . Address . IPv6

-- | Indicates another name for the host in the DNS.
--
-- When the host's ipv4/ipv6 addresses are known, the alias is set up
-- to use their address, rather than using a CNAME. This avoids various
-- problems with CNAMEs, and also means that when multiple hosts have the
-- same alias, a DNS round-robin is automatically set up.
alias :: Domain -> Property (HasInfo + UnixLike)
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` (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]
	rdesc (MX n d) = unwords ["MX", show n, ddesc d]
	rdesc (NS d) = unwords ["NS", ddesc d]
	rdesc (TXT t) = unwords ["TXT", t]
	rdesc (SRV x y z d) = unwords ["SRV", show x, show y, show z, ddesc d]
	rdesc (SSHFP x y t) = unwords ["SSHFP", show x, show y, t]
	rdesc (INCLUDE f) = unwords ["$INCLUDE", f]
	rdesc (PTR x) = unwords ["PTR", x]

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

hostMap :: [Host] -> M.Map HostName Host
hostMap l = M.fromList $ zip (map hostName l) l

aliasMap :: [Host] -> M.Map HostName Host
aliasMap = M.fromList . concat .
	map (\h -> map (\aka -> (aka, h)) $ fromAliasesInfo $ fromInfo $ hostInfo h)

findHost :: [Host] -> HostName -> Maybe Host
findHost l hn = (findHostNoAlias l hn) <|> (findAlias l hn)

findHostNoAlias :: [Host] -> HostName -> Maybe Host
findHostNoAlias l hn = M.lookup hn (hostMap l)

findAlias :: [Host] -> HostName -> Maybe Host
findAlias l hn = M.lookup hn (aliasMap l)

getAddresses :: Info -> [IPAddr]
getAddresses = mapMaybe getIPAddr . S.toList . getDnsInfo

hostAddresses :: HostName -> [Host] -> [IPAddr]
hostAddresses hn hosts = maybe [] (getAddresses . hostInfo) (findHost hosts hn)