Move more bind config into domtool, remove hardcoded /var/domtool references
[hcoop/domtool2.git] / src / plugins / bind.sml
1 (* HCoop Domtool (http://hcoop.sourceforge.net/)
2 * Copyright (c) 2006, Adam Chlipala
3 *
4 * This program is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU General Public License
6 * as published by the Free Software Foundation; either version 2
7 * of the License, or (at your option) any later version.
8 *
9 * This program is distributed in the hope that it will be useful,
10 * but WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 * GNU General Public License for more details.
13 *
14 * You should have received a copy of the GNU General Public License
15 * along with this program; if not, write to the Free Software
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
17 *)
18
19 (* BIND DNS *)
20
21 structure Bind :> BIND = struct
22
23 open Ast
24
25 val namedChanged = ref false
26 val zoneChanged = ref false
27
28 val didDomain = ref ""
29
30 val () = Slave.registerPreHandler (fn () => (namedChanged := false;
31 zoneChanged := false;
32 didDomain := ""))
33
34 val dns : Domain.files option ref = ref NONE
35
36 val _ = Domain.registerBefore
37 (fn _ => dns := Option.map (fn node => Domain.domainsFile {node = node,
38 name = "dns.conf"})
39 (Domain.dnsMaster ()))
40
41 val _ = Domain.registerAfter
42 (fn _ => (Option.app (fn files => #close files ()) (!dns);
43 dns := NONE))
44
45 val dl = ErrorMsg.dummyLoc
46
47 datatype host =
48 Literal of string
49 | Wildcard
50 | Default
51
52 datatype dns_record =
53 A of host * string
54 | CNAME of host * string
55 | MX of int * string
56 | NS of string
57 | AAAA of host * string
58 | TXT of host * string
59 | AFSDB of string
60 | SRV of host * int * int * int * string
61
62 fun hostS (Literal s) = s ^ "."
63 | hostS Wildcard = "*."
64 | hostS Default = ""
65
66 val host = fn (EApp ((EVar "literal", _), e), _) =>
67 Option.map Literal (Env.string e)
68 | (EVar "wildcard", _) =>
69 SOME Wildcard
70 | (EVar "default", _) =>
71 SOME Default
72 | _ => NONE
73
74 val srv_host = fn (EApp ((EVar "srv_literal", _), e), _) =>
75 Option.map Literal (Env.string e)
76 | (EVar "srv_wildcard", _) =>
77 SOME Wildcard
78 | (EVar "srv_default", _) =>
79 SOME Default
80 | _ => NONE
81
82 val record = fn (EApp ((EApp ((EVar "dnsA", _), e1), _), e2), _) =>
83 (case (host e1, Domain.ip e2) of
84 (SOME v1, SOME v2) => SOME (A (v1, v2))
85 | _ => NONE)
86 | (EApp ((EApp ((EVar "dnsCNAME", _), e1), _), e2), _) =>
87 (case (host e1, Env.string e2) of
88 (SOME v1, SOME v2) => SOME (CNAME (v1, v2))
89 | _ => NONE)
90 | (EApp ((EApp ((EVar "dnsMX", _), e1), _), e2), _) =>
91 (case (Env.int e1, Env.string e2) of
92 (SOME v1, SOME v2) => SOME (MX (v1, v2))
93 | _ => NONE)
94 | (EApp ((EVar "dnsNS", _), e), _) =>
95 Option.map NS (Env.string e)
96 | (EApp ((EApp ((EVar "dnsAAAA", _), e1), _), e2), _) =>
97 (case (host e1, Env.string e2) of
98 (SOME v1, SOME v2) => SOME (AAAA (v1, v2))
99 | _ => NONE)
100 | (EApp ((EApp ((EVar "dnsTXT", _), e1), _), e2), _) =>
101 (case (srv_host e1, Env.string e2) of
102 (SOME v1, SOME v2) => SOME (TXT (v1, v2))
103 | _ => NONE)
104 | (EApp ((EVar "dnsAFSDB", _), e), _) =>
105 Option.map AFSDB (Env.string e)
106 | (EApp ((EApp ((EApp ((EApp ((EApp ((EVar "dnsSRV", _), e1), _), e2), _), e3), _), e4), _), e5), _) =>
107 (case (srv_host e1, Env.int e2, Env.int e3, Env.int e4, Env.string e5) of
108 (SOME v1, SOME v2, SOME v3, SOME v4, SOME v5) => SOME (SRV (v1, v2, v3, v4, v5))
109 | _ => NONE)
110 | _ => NONE
111
112 fun writeRecord (evs, r) =
113 case !dns of
114 NONE => () (* print ("Warning: DNS directive for " ^ Domain.currentDomain ()
115 ^ " ignored because no master DNS server is configured for this domain\n") *)
116 | SOME files =>
117 let
118 fun write s = #write files s
119 fun writeDom () = #writeDom files ()
120 val ttl = Env.env Env.int (evs, "TTL")
121 in
122 case r of
123 A (from, to) => (write (hostS from);
124 writeDom ();
125 write ".\t";
126 write (Int.toString ttl);
127 write "\tIN\tA\t";
128 write to;
129 write "\n")
130 | CNAME (from, to) => (write (hostS from);
131 writeDom ();
132 write ".\t";
133 write (Int.toString ttl);
134 write "\tIN\tCNAME\t";
135 write to;
136 write ".\n")
137 | MX (num, host) => (writeDom ();
138 write ".\t";
139 write (Int.toString ttl);
140 write "\tIN\tMX\t";
141 write (Int.toString num);
142 write "\t";
143 write host;
144 write ".\n")
145 | NS host => (writeDom ();
146 write ".\t";
147 write (Int.toString ttl);
148 write "\tIN\tNS\t";
149 write host;
150 write ".\n")
151 | AAAA (from, to) => (write (hostS from);
152 writeDom ();
153 write ".\t";
154 write (Int.toString ttl);
155 write "\tIN\tAAAA\t";
156 write to;
157 write "\n")
158 | TXT (from, to) => (write (hostS from);
159 writeDom ();
160 write ".\t";
161 write (Int.toString ttl);
162 write "\tIN\tTXT\t\"";
163 write (String.translate (fn #"\"" => "\\\"" | ch => str ch) to);
164 write "\"\n")
165 | AFSDB host => (writeDom ();
166 write ".\t";
167 write (Int.toString ttl);
168 write "\tIN\tAFSDB\t";
169 write "1";
170 write "\t";
171 write host;
172 write ".\n")
173 | SRV (from, priority, weight, port, to) => (write (hostS from);
174 writeDom ();
175 write ".\t";
176 write (Int.toString ttl);
177 write "\tIN\tSRV\t";
178 write (Int.toString priority);
179 write "\t";
180 write (Int.toString weight);
181 write "\t";
182 write (Int.toString port);
183 write "\t";
184 write to;
185 write ".\n")
186 end
187
188 val () = Env.actionV_one "dns"
189 ("record", record)
190 writeRecord
191
192 fun readLine inf =
193 case TextIO.inputLine inf of
194 NONE => raise Fail "Expected a line for BIND"
195 | SOME s => String.substring (s, 0, size s - 1)
196
197 fun readILine inf = valOf (Int.fromString (readLine inf))
198
199 val monthToInt = fn Date.Jan => 1
200 | Date.Feb => 2
201 | Date.Mar => 3
202 | Date.Apr => 4
203 | Date.May => 5
204 | Date.Jun => 6
205 | Date.Jul => 7
206 | Date.Aug => 8
207 | Date.Sep => 9
208 | Date.Oct => 10
209 | Date.Nov => 11
210 | Date.Dec => 12
211
212 fun padBy ch amt s =
213 if size s < amt then
214 CharVector.tabulate (amt - size s, fn _ => ch) ^ s
215 else
216 s
217
218 fun dateString () =
219 let
220 val date = Date.fromTimeUniv (Time.now ())
221 in
222 padBy #"0" 4 (Int.toString (Date.year date))
223 ^ padBy #"0" 2 (Int.toString (monthToInt (Date.month date)))
224 ^ padBy #"0" 2 (Int.toString (Date.day date))
225 end
226
227 val () = Slave.registerFileHandler (fn fs =>
228 let
229 val {dir, file} = OS.Path.splitDirFile (#file fs)
230
231 fun dnsChanged () =
232 if #domain fs = !didDomain then
233 ()
234 else if Slave.isDelete (#action fs) then
235 let
236 val fname = OS.Path.joinBaseExt {base = #domain fs,
237 ext = SOME "zone"}
238 val fname = OS.Path.joinDirFile {dir = Config.Bind.zonePath,
239 file = fname}
240 in
241 Slave.shellF ([Config.rm, " -f ", fname],
242 fn cl => "Error deleting file: " ^ cl)
243 end
244 else
245 let
246 val inf = TextIO.openIn (OS.Path.joinDirFile {dir = #dir fs,
247 file = "soa.conf"})
248 val kind = readLine inf
249 val ttl = readILine inf
250 val ns = readLine inf
251 val serial = case readLine inf of
252 "" => NONE
253 | s => Int.fromString s
254 val rf = readILine inf
255 val ret = readILine inf
256 val exp = readILine inf
257 val min = readILine inf
258 val () = TextIO.closeIn inf
259
260 val serialPath = OS.Path.joinDirFile {dir = Config.Bind.serialDir,
261 file = #domain fs}
262
263 val oldSerial = let
264 val inf = TextIO.openIn serialPath
265 in
266 SOME (readLine inf)
267 before TextIO.closeIn inf
268 end handle IO.Io {name, ...} => NONE
269
270 val newSerial =
271 case serial of
272 SOME n => Int.toString n
273 | NONE =>
274 let
275 val prefix = dateString ()
276 in
277 prefix
278 ^ (case oldSerial of
279 NONE => "00"
280 | SOME old =>
281 if size old >= 8 andalso
282 String.substring (old, 0, 8) = prefix then
283 case Int.fromString (String.extract (old, 8, NONE)) of
284 NONE => "00"
285 | SOME old => padBy #"0" 2 (Int.toString (old+1))
286 else
287 "00")
288 end
289
290 val outf = TextIO.openOut serialPath
291 val _ = TextIO.output (outf, newSerial)
292 val _ = TextIO.closeOut outf
293
294 val dns = OS.Path.joinDirFile {dir = #dir fs,
295 file = "dns.conf"}
296
297 val fname = OS.Path.joinBaseExt {base = #domain fs,
298 ext = SOME "zone"}
299 val fname = OS.Path.joinDirFile {dir = Config.Bind.zonePath,
300 file = fname}
301
302 val outf = TextIO.openOut fname
303 in
304 zoneChanged := true;
305 TextIO.output (outf, "$TTL ");
306 TextIO.output (outf, Int.toString ttl);
307 TextIO.output (outf, "\n\n@\tIN\tSOA\t");
308 TextIO.output (outf, ns);
309 TextIO.output (outf, ".\thostmaster.");
310 TextIO.output (outf, #domain fs);
311 TextIO.output (outf, ". ( ");
312 TextIO.output (outf, newSerial);
313 TextIO.output (outf, " ");
314 TextIO.output (outf, Int.toString rf);
315 TextIO.output (outf, " ");
316 TextIO.output (outf, Int.toString ret);
317 TextIO.output (outf, " ");
318 TextIO.output (outf, Int.toString exp);
319 TextIO.output (outf, " ");
320 TextIO.output (outf, Int.toString min);
321 TextIO.output (outf, " )\n\n");
322 TextIO.closeOut outf;
323 if Posix.FileSys.access (dns, []) then
324 Slave.shellF ([Config.cat, " ", dns, " >>", fname],
325 fn cl => "Error concatenating file: " ^ cl)
326 else
327 ();
328 didDomain := #domain fs
329 end
330 in
331 case file of
332 "soa.conf" => dnsChanged ()
333 | "dns.conf" => dnsChanged ()
334 | "named.conf" => namedChanged := true
335 | _ => ()
336 end)
337
338 val () = Slave.registerPostHandler
339 (fn () =>
340 (if !namedChanged then
341 Slave.concatTo (fn s => s = "named.conf") Config.Bind.namedConf
342 else
343 ();
344 if !namedChanged orelse !zoneChanged then
345 Slave.shellF ([Config.Bind.reload],
346 fn cl => "Error reloading bind with " ^ cl)
347 else
348 ()))
349
350 val () = Domain.registerResetLocal (fn () =>
351 ignore (OS.Process.system (Config.rm ^ " -rf " ^ Config.Bind.zonePath ^ "/*")))
352
353 val () = Domain.registerDescriber (Domain.considerAll
354 [Domain.Filename {filename = "named.conf",
355 heading = "named.conf addition:",
356 showEmpty = false},
357 Domain.Filename {filename = "dns.conf",
358 heading = "DNS zonefile contents:",
359 showEmpty = false}])
360
361 fun validSrvHost s =
362 size s > 0 andalso size s < 20
363 andalso CharVector.all (fn ch => Domain.isIdent ch orelse ch = #"-" orelse ch = #"_") s
364
365 fun validSrvDomain s =
366 size s > 0 andalso size s < 100
367 andalso List.all validSrvHost (String.fields (fn ch => ch = #".") s)
368
369 val _ = Env.type_one "srv_host"
370 Env.string
371 validSrvHost
372
373 val _ = Env.type_one "srv_domain"
374 Env.string
375 validSrvDomain
376
377 end