5f37520b664db47900940498a0060f22ebf0f7a3
[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"})
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 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
54 val record = fn (EApp ((EApp ((EVar "dnsA", _), e1), _), e2), _) =>
55 (case (Env.string e1, Domain.ip e2) of
56 (SOME v1, SOME v2) => SOME (A (v1, v2))
57 | _ => NONE)
58 | (EApp ((EApp ((EVar "dnsCNAME", _), e1), _), e2), _) =>
59 (case (Env.string e1, Env.string e2) of
60 (SOME v1, SOME v2) => SOME (CNAME (v1, v2))
61 | _ => NONE)
62 | (EApp ((EApp ((EVar "dnsMX", _), e1), _), e2), _) =>
63 (case (Env.int e1, Env.string e2) of
64 (SOME v1, SOME v2) => SOME (MX (v1, v2))
65 | _ => NONE)
66 | (EApp ((EVar "dnsNS", _), e), _) =>
67 Option.map NS (Env.string e)
68 | (EApp ((EVar "dnsDefaultA", _), e), _) =>
69 Option.map DefaultA (Env.string e)
70 | _ => NONE
71
72 fun writeRecord (evs, r) =
73 case !dns of
74 NONE => print "Warning: DNS directive ignored because no master DNS server is configured for this domain\n"
75 | SOME files =>
76 let
77 fun write s = #write files s
78 fun writeDom () = #writeDom files ()
79 val ttl = Env.env Env.int (evs, "TTL")
80 in
81 case r of
82 A (from, to) => (write from;
83 write ".";
84 writeDom ();
85 write ".\t";
86 write (Int.toString ttl);
87 write "\tIN\tA\t";
88 write to;
89 write "\n")
90 | DefaultA to => (writeDom ();
91 write ".\t";
92 write (Int.toString ttl);
93 write "\tIN\tA\t";
94 write to;
95 write "\n")
96 | CNAME (from, to) => (write from;
97 write ".";
98 writeDom ();
99 write ".\t";
100 write (Int.toString ttl);
101 write "\tIN\tCNAME\t";
102 write to;
103 write ".\n")
104 | MX (num, host) => (writeDom ();
105 write ".\t";
106 write (Int.toString ttl);
107 write "\tIN\tMX\t";
108 write (Int.toString num);
109 write "\t";
110 write host;
111 write ".\n")
112 | NS host => (writeDom ();
113 write ".\t";
114 write (Int.toString ttl);
115 write "\tIN\tNS\t";
116 write host;
117 write ".\n")
118 end
119
120 val () = Env.actionV_one "dns"
121 ("record", record)
122 writeRecord
123
124 fun readLine inf =
125 case TextIO.inputLine inf of
126 NONE => raise Fail "Expected a line for BIND"
127 | SOME s => String.substring (s, 0, size s - 1)
128
129 fun readILine inf = valOf (Int.fromString (readLine inf))
130
131 val monthToInt = fn Date.Jan => 1
132 | Date.Feb => 2
133 | Date.Mar => 3
134 | Date.Apr => 4
135 | Date.May => 5
136 | Date.Jun => 6
137 | Date.Jul => 7
138 | Date.Aug => 8
139 | Date.Sep => 9
140 | Date.Oct => 10
141 | Date.Nov => 11
142 | Date.Dec => 12
143
144 fun padBy ch amt s =
145 if size s < amt then
146 CharVector.tabulate (amt - size s, fn _ => ch) ^ s
147 else
148 s
149
150 fun dateString () =
151 let
152 val date = Date.fromTimeUniv (Time.now ())
153 in
154 padBy #"0" 4 (Int.toString (Date.year date))
155 ^ padBy #"0" 2 (Int.toString (monthToInt (Date.month date)))
156 ^ padBy #"0" 2 (Int.toString (Date.day date))
157 end
158
159 val () = Slave.registerFileHandler (fn fs =>
160 let
161 val {dir, file} = OS.Path.splitDirFile (#file fs)
162
163 fun dnsChanged () =
164 if #domain fs = !didDomain then
165 ()
166 else if #action fs = Slave.Delete then
167 let
168 val fname = OS.Path.joinBaseExt {base = #domain fs,
169 ext = SOME "zone"}
170 val fname = OS.Path.joinDirFile {dir = Config.Bind.zonePath,
171 file = fname}
172 in
173 Slave.shellF ([Config.rm, " -f ", fname],
174 fn cl => "Error deleting file: " ^ cl)
175 end
176 else
177 let
178 val inf = TextIO.openIn (OS.Path.joinDirFile {dir = #dir fs,
179 file = "soa"})
180 val kind = readLine inf
181 val ttl = readILine inf
182 val ns = readLine inf
183 val serial = case readLine inf of
184 "" => NONE
185 | s => Int.fromString s
186 val rf = readILine inf
187 val ret = readILine inf
188 val exp = readILine inf
189 val min = readILine inf
190 val () = TextIO.closeIn inf
191
192 val serialPath = OS.Path.joinDirFile {dir = Config.serialDir,
193 file = #domain fs}
194
195 val oldSerial = let
196 val inf = TextIO.openIn serialPath
197 in
198 SOME (readLine inf)
199 before TextIO.closeIn inf
200 end handle IO.Io {name, ...} => NONE
201
202 val newSerial =
203 case serial of
204 SOME n => Int.toString n
205 | NONE =>
206 let
207 val prefix = dateString ()
208 in
209 prefix
210 ^ (case oldSerial of
211 NONE => "00"
212 | SOME old =>
213 if size old >= 8 andalso
214 String.substring (old, 0, 8) = prefix then
215 case Int.fromString (String.extract (old, 8, NONE)) of
216 NONE => "00"
217 | SOME old => padBy #"0" 2 (Int.toString (old+1))
218 else
219 "00")
220 end
221
222 val outf = TextIO.openOut serialPath
223 val _ = TextIO.output (outf, newSerial)
224 val _ = TextIO.closeOut outf
225
226 val dns = OS.Path.joinDirFile {dir = #dir fs,
227 file = "dns"}
228
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
234 val outf = TextIO.openOut fname
235 in
236 zoneChanged := true;
237 TextIO.output (outf, "$TTL ");
238 TextIO.output (outf, Int.toString ttl);
239 TextIO.output (outf, "\n\n@\tIN\tSOA\t");
240 TextIO.output (outf, ns);
241 TextIO.output (outf, ".\thostmaster.");
242 TextIO.output (outf, #domain fs);
243 TextIO.output (outf, ". ( ");
244 TextIO.output (outf, newSerial);
245 TextIO.output (outf, " ");
246 TextIO.output (outf, Int.toString rf);
247 TextIO.output (outf, " ");
248 TextIO.output (outf, Int.toString ret);
249 TextIO.output (outf, " ");
250 TextIO.output (outf, Int.toString exp);
251 TextIO.output (outf, " ");
252 TextIO.output (outf, Int.toString min);
253 TextIO.output (outf, " )\n\n");
254 TextIO.closeOut outf;
255 if Posix.FileSys.access (dns, []) then
256 Slave.shellF ([Config.cat, " ", dns, " >>", fname],
257 fn cl => "Error concatenating file: " ^ cl)
258 else
259 ();
260 didDomain := #domain fs
261 end
262 in
263 case file of
264 "soa" => dnsChanged ()
265 | "dns" => dnsChanged ()
266 | "named.conf" => namedChanged := true
267 | _ => ()
268 end)
269
270 val () = Slave.registerPostHandler
271 (fn () =>
272 (if !namedChanged then
273 Slave.concatTo (fn s => s = "named.conf") Config.Bind.namedConf
274 else
275 ();
276 if !namedChanged orelse !zoneChanged then
277 Slave.shellF ([Config.Bind.reload],
278 fn cl => "Error reloading bind with " ^ cl)
279 else
280 ()))
281
282 val () = Domain.registerResetLocal (fn () =>
283 ignore (OS.Process.system (Config.rm ^ " -rf /var/domtool/zones/*")))
284
285 end