BIND
[hcoop/domtool2.git] / src / domain.sml
CommitLineData
a3698041
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.
dac62e84 17 *)
a3698041
AC
18
19(* Domain-related primitive actions *)
20
21structure Domain :> DOMAIN = struct
22
6ae327f8
AC
23fun validIp s =
24 case map Int.fromString (String.fields (fn ch => ch = #".") s) of
25 [SOME n1, SOME n2, SOME n3, SOME n4] =>
26 n1 >= 0 andalso n1 < 256 andalso n2 >= 0 andalso n2 < 256 andalso n3 >= 0 andalso n3 < 256 andalso n4 >= 0 andalso n4 < 256
27 | _ => false
28
629a34f6
AC
29fun isIdent ch = Char.isLower ch orelse Char.isDigit ch
30
31fun validHost s =
32 size s > 0 andalso size s < 20
33 andalso CharVector.all (fn ch => isIdent ch orelse ch = #"-") s
34
35fun validDomain s =
36 size s > 0 andalso size s < 100
37 andalso List.all validHost (String.fields (fn ch => ch = #".") s)
38
6ae327f8
AC
39val _ = Env.type_one "ip"
40 Env.string
41 validIp
42
629a34f6
AC
43val _ = Env.type_one "host"
44 Env.string
45 validHost
46
47val _ = Env.type_one "domain"
48 Env.string
49 validDomain
50
a3698041
AC
51open Ast
52
6ae327f8
AC
53val dl = ErrorMsg.dummyLoc
54
55val nsD = (EString Config.defaultNs, dl)
56val serialD = (EVar "serialAuto", dl)
57val refD = (EInt Config.defaultRefresh, dl)
58val retD = (EInt Config.defaultRetry, dl)
59val expD = (EInt Config.defaultExpiry, dl)
60val minD = (EInt Config.defaultMinimum, dl)
61
62val soaD = multiApp ((EVar "soa", dl),
63 dl,
64 [nsD, serialD, refD, retD, expD, minD])
65
66val _ = Main.registerDefault ("DNS",
67 (TBase "dnsKind", dl),
68 (EApp ((EVar "master", dl),
69 soaD), dl))
70
71val _ = Main.registerDefault ("TTL",
72 (TBase "int", dl),
73 (EInt Config.Bind.defaultTTL, dl))
74
75type soa = {ns : string,
76 serial : int option,
77 ref : int,
78 ret : int,
79 exp : int,
80 min : int}
81
82val serial = fn (EVar "serialAuto", _) => SOME NONE
83 | (EApp ((EVar "serialConst", _), n), _) => Option.map SOME (Env.int n)
84 | _ => NONE
85
86val soa = fn (EApp ((EApp ((EApp ((EApp ((EApp ((EApp
87 ((EVar "soa", _), ns), _),
88 sl), _),
89 rf), _),
90 ret), _),
91 exp), _),
92 min), _) =>
93 (case (Env.string ns, serial sl, Env.int rf,
94 Env.int ret, Env.int exp, Env.int min) of
95 (SOME ns, SOME sl, SOME rf,
96 SOME ret, SOME exp, SOME min) =>
97 SOME {ns = ns,
98 serial = sl,
99 ref = rf,
100 ret = ret,
101 exp = exp,
102 min = min}
103 | _ => NONE)
104 | _ => NONE
105
106datatype dnsKind =
107 Master of soa
108 | Slave of soa
109 | NoDns
110
111val dnsKind = fn (EApp ((EVar "master", _), e), _) => Option.map Master (soa e)
112 | (EApp ((EVar "slave", _), e), _) => Option.map Slave (soa e)
113 | (EVar "noDns", _) => SOME NoDns
114 | _ => NONE
115
a3698041
AC
116val befores = ref (fn (_ : string) => ())
117val afters = ref (fn (_ : string) => ())
118
119fun registerBefore f =
120 let
121 val old = !befores
122 in
123 befores := (fn x => (old x; f x))
124 end
125
126fun registerAfter f =
127 let
128 val old = !afters
129 in
130 afters := (fn x => (old x; f x))
131 end
132
133val current = ref ""
dac62e84
AC
134val currentPath = ref ""
135
d612d62c
AC
136val scratch = ref ""
137
dac62e84
AC
138fun currentDomain () = !current
139
140fun domainFile name = TextIO.openOut (!currentPath ^ name)
141
142fun getPath domain =
143 let
144 val toks = String.fields (fn ch => ch = #".") domain
145
146 val elems = foldr (fn (piece, elems) =>
147 let
148 val elems = piece :: elems
095de39e 149 val path = String.concatWith "/" (Config.resultRoot :: rev elems)
d612d62c 150 val tmpPath = String.concatWith "/" (Config.tmpDir :: rev elems)
dac62e84
AC
151 in
152 (if Posix.FileSys.ST.isDir
153 (Posix.FileSys.stat path) then
154 ()
155 else
156 (OS.FileSys.remove path;
157 OS.FileSys.mkDir path))
158 handle OS.SysErr _ => OS.FileSys.mkDir path;
d612d62c
AC
159
160 (if Posix.FileSys.ST.isDir
161 (Posix.FileSys.stat tmpPath) then
162 ()
163 else
164 (OS.FileSys.remove tmpPath;
165 OS.FileSys.mkDir tmpPath))
166 handle OS.SysErr _ => OS.FileSys.mkDir tmpPath;
167
dac62e84
AC
168 elems
169 end) [] toks
170 in
d612d62c
AC
171 fn root => String.concatWith "/" (root :: rev ("" :: elems))
172 end
173
174datatype file_action' =
175 Add' of {src : string, dst : string}
176 | Delete' of string
177 | Modify' of {src : string, dst : string}
178
d612d62c
AC
179fun findDiffs dom =
180 let
181 val realPath = getPath dom Config.resultRoot
182 val tmpPath = !currentPath
183
184 val dir = Posix.FileSys.opendir realPath
185
186 fun loopReal acts =
187 case Posix.FileSys.readdir dir of
188 NONE => (Posix.FileSys.closedir dir;
189 acts)
190 | SOME fname =>
191 let
192 val real = OS.Path.joinDirFile {dir = realPath,
193 file = fname}
194 val tmp = OS.Path.joinDirFile {dir = tmpPath,
195 file = fname}
196 in
197 if Posix.FileSys.ST.isDir (Posix.FileSys.stat real) then
198 loopReal acts
199 else if Posix.FileSys.access (tmp, []) then
8df2e702 200 if Slave.shell [Config.diff, " ", real, " ", tmp] then
d612d62c
AC
201 loopReal acts
202 else
203 loopReal (Modify' {src = tmp, dst = real} :: acts)
204 else
205 loopReal (Delete' real :: acts)
206 end
207
208 val acts = loopReal []
209
8df2e702 210 val dir = Posix.FileSys.opendir tmpPath
d612d62c
AC
211
212 fun loopTmp acts =
213 case Posix.FileSys.readdir dir of
214 NONE => (Posix.FileSys.closedir dir;
215 acts)
216 | SOME fname =>
217 let
218 val real = OS.Path.joinDirFile {dir = realPath,
219 file = fname}
220 val tmp = OS.Path.joinDirFile {dir = tmpPath,
221 file = fname}
222 in
223 if Posix.FileSys.ST.isDir (Posix.FileSys.stat tmp) then
224 loopTmp acts
225 else if Posix.FileSys.access (real, []) then
226 loopTmp acts
227 else
228 loopTmp (Add' {src = tmp, dst = real} :: acts)
229 end
230
231 val acts = loopTmp acts
232 in
233 acts
dac62e84 234 end
a3698041 235
6ae327f8
AC
236val _ = Env.containerV_one "domain"
237 ("domain", Env.string)
238 (fn (evs, dom) =>
239 let
240 val kind = Env.env dnsKind (evs, "DNS")
241 val ttl = Env.env Env.int (evs, "TTL")
242
243 val path = getPath dom Config.tmpDir
244
245 val () = (current := dom;
246 currentPath := path;
247 !befores dom)
248
249 fun saveSoa (kind, soa : soa) =
250 let
251 val outf = domainFile "soa"
252 in
253 TextIO.output (outf, kind);
254 TextIO.output (outf, "\n");
255 TextIO.output (outf, Int.toString ttl);
256 TextIO.output (outf, "\n");
257 TextIO.output (outf, #ns soa);
258 TextIO.output (outf, "\n");
259 case #serial soa of
260 NONE => ()
261 | SOME n => TextIO.output (outf, Int.toString n);
262 TextIO.output (outf, "\n");
263 TextIO.output (outf, Int.toString (#ref soa));
264 TextIO.output (outf, "\n");
265 TextIO.output (outf, Int.toString (#ret soa));
266 TextIO.output (outf, "\n");
267 TextIO.output (outf, Int.toString (#exp soa));
268 TextIO.output (outf, "\n");
269 TextIO.output (outf, Int.toString (#min soa));
270 TextIO.output (outf, "\n");
271 TextIO.closeOut outf
272 end
273
274 fun saveNamed (kind, soa : soa) =
275 let
276 val outf = domainFile "named.conf"
277 in
278 TextIO.output (outf, "\nzone \"");
279 TextIO.output (outf, dom);
280 TextIO.output (outf, "\" IN {\n\ttype ");
281 TextIO.output (outf, kind);
282 TextIO.output (outf, ";\n\tfile \"");
283 TextIO.output (outf, Config.Bind.zonePath);
284 TextIO.output (outf, "/");
285 TextIO.output (outf, dom);
286 TextIO.output (outf, ".zone\";\n");
287 case kind of
288 "master" => TextIO.output (outf, "\tallow-update { none; };\n")
289 | _ => TextIO.output (outf, "\tmasters { 1.2.3.4; };\n");
290 TextIO.output (outf, "}\n");
291 TextIO.closeOut outf
292 end
293
294 fun saveBoth ks = (saveSoa ks; saveNamed ks)
295 in
296 case kind of
297 NoDns => ()
298 | Master soa => saveBoth ("master", soa)
299 | Slave soa => saveBoth ("slave", soa)
300 end,
301 fn () =>
302 let
303 val dom = !current
304 val () = !afters dom
305
306 val diffs = findDiffs dom
307
308 val dir = getPath dom Config.resultRoot
309
310 val diffs = map (fn Add' {src, dst} =>
311 (Slave.shellF ([Config.cp, " ", src, " ", dst],
312 fn cl => "Copy failed: " ^ cl);
313 {action = Slave.Add,
314 domain = dom,
315 dir = dir,
316 file = dst})
317 | Delete' dst =>
318 (OS.FileSys.remove dst
319 handle OS.SysErr _ =>
320 ErrorMsg.error NONE ("Delete failed for " ^ dst);
321 {action = Slave.Delete,
322 domain = dom,
323 dir = dir,
324 file = dst})
325 | Modify' {src, dst} =>
326 (Slave.shellF ([Config.cp, " ", src, " ", dst],
327 fn cl => "Copy failed: " ^ cl);
328 {action = Slave.Modify,
329 domain = dom,
330 dir = dir,
331 file = dst})) diffs
332 in
333 if !ErrorMsg.anyErrors then
334 ()
335 else
336 Slave.handleChanges diffs;
337 ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, "/*"],
338 fn cl => "Temp file cleanup failed: " ^ cl))
339 end)
340
341
a3698041
AC
342
343end