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