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