summaryrefslogtreecommitdiff
path: root/Propellor/Property/Dns.hs
blob: 99a6014534d95366aaa4f1433cb557c7b310445d (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
206
207
208
209
210
211
212
module Propellor.Property.Dns (
	module Propellor.Types.Dns,
	secondary,
	servingZones,
	mkSOA,
	nextSerialNumber,
	incrSerialNumber,
	currentSerialNumber,
	writeZoneFile,
	genZoneFile,
	genSOA,
) where

import Propellor
import Propellor.Types.Dns
import Propellor.Property.File
import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.Service as Service
import Utility.Applicative

import Data.List
import Data.Time.Clock.POSIX

namedconf :: FilePath
namedconf = "/etc/bind/named.conf.local"

zoneDesc :: NamedConf -> String
zoneDesc z = confDomain z ++ " (" ++ show (confType z) ++ ")"

secondary :: Domain -> [IPAddr] -> NamedConf
secondary domain masters = NamedConf
	{ confDomain = domain
	, confType = Secondary
	, confFile = "db." ++ domain
	, confMasters = masters
	, confLines = ["allow-transfer { }"]
	}

confStanza :: NamedConf -> [Line]
confStanza c =
	[ "// automatically generated by propellor"
	, "zone \"" ++ confDomain c ++ "\" {"
	, cfgline "type" (if confType c == Master then "master" else "slave")
	, cfgline "file" ("\"" ++ confFile c ++ "\"")
	] ++
	(if null (confMasters c) then [] else mastersblock) ++
	(map (\l -> "\t" ++ l ++ ";") (confLines c)) ++
	[ "};"
	, ""
	]
  where
	cfgline f v = "\t" ++ f ++ " " ++ v ++ ";"
	mastersblock =
		[ "\tmasters {" ] ++
		(map (\ip -> "\t\t" ++ fromIPAddr ip ++ ";") (confMasters c)) ++
		[ "\t};" ]

-- | Rewrites the whole named.conf.local file to serve the specificed
-- zones.
servingZones :: [NamedConf] -> Property
servingZones zs = hasContent namedconf (concatMap confStanza zs)
	`describe` ("dns server for zones: " ++ unwords (map zoneDesc zs))
	`requires` Apt.serviceInstalledRunning "bind9"
	`onChange` Service.reloaded "bind9"

-- |  Generates a SOA with some fairly sane numbers in it.
mkSOA :: Domain -> [Record] -> SOA
mkSOA d rs = SOA
	{ sDomain = AbsDomain d
	, sSerial = 1
	, sRefresh = hours 4
	, sRetry = hours 1
	, sExpire = 2419200 -- 4 weeks
	, sTTL = hours 8
	, sRecord = rs
	}
  where
	hours n = n * 60 * 60

dValue :: BindDomain -> String
dValue (RelDomain d) = d
dValue (AbsDomain d) = d ++ "."
dValue (SOADomain) = "@"

rField :: Record -> String
rField (Address (IPv4 _)) = "A"
rField (Address (IPv6 _)) = "AAAA"
rField (CNAME _) = "CNAME"
rField (MX _ _) = "MX"
rField (NS _) = "NS"
rField (TXT _) = "TXT"

rValue :: Record -> String
rValue (Address (IPv4 addr)) = addr
rValue (Address (IPv6 addr)) = addr
rValue (CNAME d) = dValue d
rValue (MX pri d) = show pri ++ " " ++ dValue d
rValue (NS d) = dValue d
rValue (TXT s) = [q] ++ filter (/= q) s ++ [q]
  where
	q = '"'

-- | Adjusts the serial number of the zone to 
--
-- * Always be larger than the passed SerialNumber
-- * Always be larger than the serial number in the Zone record.
nextSerialNumber :: Zone -> SerialNumber -> Zone
nextSerialNumber (Zone soa l) oldserial = Zone soa' l
  where
	soa' = soa { sSerial = succ $ max (sSerial soa) oldserial }

incrSerialNumber :: Zone -> Zone
incrSerialNumber (Zone soa l) = Zone soa' l
  where
	soa' = soa { sSerial = succ (sSerial soa) }

-- | Propellor uses a serial number derived from the current date and time.
--
-- This ensures that, even if zone files are being generated on
-- multiple hosts, the serial numbers will not get out of sync between
-- them.
--
-- Since serial numbers are limited to 32 bits, the number of seconds
-- since the epoch is divided by 5. This will work until the year 2650,
-- at which point this stupid limit had better have been increased to
-- 128 bits. If we didn't divide by 5, it would only work up to 2106!
--
-- Dividing by 5 means that this number only changes once every 5 seconds.
-- If propellor is running more often than once every 5 seconds, you're
-- doing something wrong.
currentSerialNumber :: IO SerialNumber
currentSerialNumber = calc <$> getPOSIXTime
  where
	calc t = floor (t / 5)

-- | Write a Zone out to a to a file.
--
-- The serial number that is written to the file comes from larger of the
-- Zone's SOA serial number, and the last serial number used in the file.
-- This ensures that serial number always increases, while also letting
-- a Zone contain an existing serial number, which may be quite large.
writeZoneFile :: Zone -> FilePath -> IO ()
writeZoneFile z f = do
	oldserial <- nextZoneFileSerialNumber f
	let z' = nextSerialNumber z oldserial
	writeFile f (genZoneFile z')
	writeZonePropellorFile f z'

-- | Next to the zone file, is a ".propellor" file, which contains
-- the serialized Zone. This saves the bother of parsing
-- the horrible bind zone file format.
zonePropellorFile :: FilePath -> FilePath
zonePropellorFile f = f ++ ".serial"

nextZoneFileSerialNumber :: FilePath -> IO SerialNumber
nextZoneFileSerialNumber = maybe 1 (sSerial . zSOA . incrSerialNumber)
	<$$> readZonePropellorFile

writeZonePropellorFile :: FilePath -> Zone -> IO ()
writeZonePropellorFile f z = writeFile (zonePropellorFile f) (show z)

readZonePropellorFile :: FilePath -> IO (Maybe Zone)
readZonePropellorFile f = catchDefaultIO Nothing $
	readish <$> readFile (zonePropellorFile f)

-- | Generating a zone file.
genZoneFile :: Zone -> String
genZoneFile (Zone soa rs) = unlines $
	header : genSOA soa : map genr rs
  where
	header = com "BIND zone file. Generated by propellor, do not edit."

	genr (d, r) = genRecord (Just d, r)

genRecord :: (Maybe Domain, Record) -> String
genRecord (mdomain, record) = intercalate "\t"
	[ dname
	, "IN"
	, rField record
	, rValue record
	]
  where
	dname = fromMaybe "" mdomain

genSOA :: SOA -> String
genSOA soa = unlines $
	header : map genRecord (zip (repeat Nothing) (sRecord soa))
  where
	header = unlines
		-- @ IN SOA root. root (
		[ intercalate "\t"
			[ dValue SOADomain 
			, "IN"
			, "SOA"
			, dValue (sDomain soa)
			, "root"
			, "("
			]
		, headerline sSerial "Serial"
		, headerline sRefresh "Refresh"
		, headerline sRetry "Retry"
		, headerline sExpire "Expire"
		, headerline sTTL "Default TTL"
		, inheader ")"
		]
	headerline r comment = inheader $ show (r soa) ++ "\t\t" ++ com comment
	inheader l = "\t\t\t" ++ l

-- | Comment line in a zone file.
com :: String -> String
com s = "; " ++ s