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