HCoop / hcoop / domtool2.git / blame_incremental
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (non-incremental) | history | HEAD
Better DNS slave handling
[hcoop/domtool2.git] / src / domain.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(* Domain-related primitive actions *)
20
21structure Domain :> DOMAIN = struct
22
23structure SM = DataStructures.StringMap
24
25val nodes = map #2 Config.nodeIps
26val nodeMap = foldl (fn ((node, ip), mp) => SM.insert (mp, node, ip))
27 SM.empty Config.nodeIps
28
29fun validIp s =
30 case map Int.fromString (String.fields (fn ch => ch = #".") s) of
31 [SOME n1, SOME n2, SOME n3, SOME n4] =>
32 n1 >= 0 andalso n1 < 256 andalso n2 >= 0 andalso n2 < 256 andalso n3 >= 0 andalso n3 < 256 andalso n4 >= 0 andalso n4 < 256
33 | _ => false
34
35fun isIdent ch = Char.isLower ch orelse Char.isDigit ch
36
37fun validHost s =
38 size s > 0 andalso size s < 20
39 andalso CharVector.all (fn ch => isIdent ch orelse ch = #"-") s
40
41fun validDomain s =
42 size s > 0 andalso size s < 100
43 andalso List.all validHost (String.fields (fn ch => ch = #".") s)
44
45fun validNode s = List.exists (fn s' => s = s') nodes
46
47val _ = Env.type_one "ip"
48 Env.string
49 validIp
50
51val _ = Env.type_one "host"
52 Env.string
53 validHost
54
55val _ = Env.type_one "domain"
56 Env.string
57 validDomain
58
59val _ = Env.type_one "node"
60 Env.string
61 validNode
62
63open Ast
64
65val dl = ErrorMsg.dummyLoc
66
67val nsD = (EString Config.defaultNs, dl)
68val serialD = (EVar "serialAuto", dl)
69val refD = (EInt Config.defaultRefresh, dl)
70val retD = (EInt Config.defaultRetry, dl)
71val expD = (EInt Config.defaultExpiry, dl)
72val minD = (EInt Config.defaultMinimum, dl)
73
74val soaD = multiApp ((EVar "soa", dl),
75 dl,
76 [nsD, serialD, refD, retD, expD, minD])
77
78val masterD = (EApp ((EVar "internalMaster", dl),
79 (EString Config.defaultNode, dl)),
80 dl)
81
82val _ = Main.registerDefault ("DNS",
83 (TBase "dnsKind", dl),
84 (multiApp ((EVar "useDns", dl),
85 dl,
86 [soaD, masterD, (EList [], dl)])))
87
88val _ = Main.registerDefault ("TTL",
89 (TBase "int", dl),
90 (EInt Config.Bind.defaultTTL, dl))
91
92type soa = {ns : string,
93 serial : int option,
94 ref : int,
95 ret : int,
96 exp : int,
97 min : int}
98
99val serial = fn (EVar "serialAuto", _) => SOME NONE
100 | (EApp ((EVar "serialConst", _), n), _) => Option.map SOME (Env.int n)
101 | _ => NONE
102
103val soa = fn (EApp ((EApp ((EApp ((EApp ((EApp ((EApp
104 ((EVar "soa", _), ns), _),
105 sl), _),
106 rf), _),
107 ret), _),
108 exp), _),
109 min), _) =>
110 (case (Env.string ns, serial sl, Env.int rf,
111 Env.int ret, Env.int exp, Env.int min) of
112 (SOME ns, SOME sl, SOME rf,
113 SOME ret, SOME exp, SOME min) =>
114 SOME {ns = ns,
115 serial = sl,
116 ref = rf,
117 ret = ret,
118 exp = exp,
119 min = min}
120 | _ => NONE)
121 | _ => NONE
122
123datatype master =
124 ExternalMaster of string
125 | InternalMaster of string
126
127val master = fn (EApp ((EVar "externalMaster", _), e), _) => Option.map ExternalMaster (Env.string e)
128 | (EApp ((EVar "internalMaster", _), e), _) => Option.map InternalMaster (Env.string e)
129 | _ => NONE
130
131datatype dnsKind =
132 UseDns of {soa : soa,
133 master : master,
134 slaves : string list}
135 | NoDns
136
137val dnsKind = fn (EApp ((EApp ((EApp
138 ((EVar "useDns", _), sa), _),
139 mstr), _),
140 slaves), _) =>
141 (case (soa sa, master mstr, Env.list Env.string slaves) of
142 (SOME sa, SOME mstr, SOME slaves) =>
143 SOME (UseDns {soa = sa,
144 master = mstr,
145 slaves = slaves})
146 | _ => NONE)
147 | _ => NONE
148
149val befores = ref (fn (_ : string) => ())
150val afters = ref (fn (_ : string) => ())
151
152fun registerBefore f =
153 let
154 val old = !befores
155 in
156 befores := (fn x => (old x; f x))
157 end
158
159fun registerAfter f =
160 let
161 val old = !afters
162 in
163 afters := (fn x => (old x; f x))
164 end
165
166val current = ref ""
167val currentPath = ref (fn (_ : string) => "")
168
169val scratch = ref ""
170
171fun currentDomain () = !current
172
173fun domainFile {node, name} = ((*print ("Opening " ^ !currentPath node ^ name ^ "\n");*)
174 TextIO.openOut (!currentPath node ^ name))
175
176fun getPath domain =
177 let
178 val toks = String.fields (fn ch => ch = #".") domain
179
180 val elems = foldr (fn (piece, elems) =>
181 let
182 val elems = piece :: elems
183
184 fun doNode node =
185 let
186 val path = String.concatWith "/"
187 (Config.resultRoot :: node :: rev elems)
188 val tmpPath = String.concatWith "/"
189 (Config.tmpDir :: node :: rev elems)
190 in
191 (if Posix.FileSys.ST.isDir
192 (Posix.FileSys.stat path) then
193 ()
194 else
195 (OS.FileSys.remove path;
196 OS.FileSys.mkDir path))
197 handle OS.SysErr _ => OS.FileSys.mkDir path;
198
199 (if Posix.FileSys.ST.isDir
200 (Posix.FileSys.stat tmpPath) then
201 ()
202 else
203 (OS.FileSys.remove tmpPath;
204 OS.FileSys.mkDir tmpPath))
205 handle OS.SysErr _ => OS.FileSys.mkDir tmpPath
206 end
207 in
208 app doNode nodes;
209 elems
210 end) [] toks
211 in
212 fn (root, site) => String.concatWith "/" (root :: site :: rev ("" :: elems))
213 end
214
215datatype file_action' =
216 Add' of {src : string, dst : string}
217 | Delete' of string
218 | Modify' of {src : string, dst : string}
219
220fun findDiffs (site, dom, acts) =
221 let
222 val gp = getPath dom
223 val realPath = gp (Config.resultRoot, site)
224 val tmpPath = gp (Config.tmpDir, site)
225
226 (*val _ = print ("getDiffs(" ^ site ^ ", " ^ dom ^ ")... " ^ realPath ^ "; " ^ tmpPath ^ "\n")*)
227
228 val dir = Posix.FileSys.opendir realPath
229
230 fun loopReal acts =
231 case Posix.FileSys.readdir dir of
232 NONE => (Posix.FileSys.closedir dir;
233 acts)
234 | SOME fname =>
235 let
236 val real = OS.Path.joinDirFile {dir = realPath,
237 file = fname}
238 val tmp = OS.Path.joinDirFile {dir = tmpPath,
239 file = fname}
240 in
241 if Posix.FileSys.ST.isDir (Posix.FileSys.stat real) then
242 loopReal acts
243 else if Posix.FileSys.access (tmp, []) then
244 if Slave.shell [Config.diff, " ", real, " ", tmp] then
245 loopReal acts
246 else
247 loopReal ((site, dom, realPath, Modify' {src = tmp, dst = real}) :: acts)
248 else
249 loopReal ((site, dom, realPath, Delete' real) :: acts)
250 end
251
252 val acts = loopReal acts
253
254 val dir = Posix.FileSys.opendir tmpPath
255
256 fun loopTmp acts =
257 case Posix.FileSys.readdir dir of
258 NONE => (Posix.FileSys.closedir dir;
259 acts)
260 | SOME fname =>
261 let
262 val real = OS.Path.joinDirFile {dir = realPath,
263 file = fname}
264 val tmp = OS.Path.joinDirFile {dir = tmpPath,
265 file = fname}
266 in
267 if Posix.FileSys.ST.isDir (Posix.FileSys.stat tmp) then
268 loopTmp acts
269 else if Posix.FileSys.access (real, []) then
270 loopTmp acts
271 else
272 loopTmp ((site, dom, realPath, Add' {src = tmp, dst = real}) :: acts)
273 end
274
275 val acts = loopTmp acts
276 in
277 acts
278 end
279
280fun findAllDiffs () =
281 let
282 val dir = Posix.FileSys.opendir Config.tmpDir
283 val len = length (String.fields (fn ch => ch = #"/") Config.tmpDir) + 1
284
285 fun exploreSites diffs =
286 case Posix.FileSys.readdir dir of
287 NONE => diffs
288 | SOME site =>
289 let
290 fun explore (dname, diffs) =
291 let
292 val dir = Posix.FileSys.opendir dname
293
294 fun loop diffs =
295 case Posix.FileSys.readdir dir of
296 NONE => diffs
297 | SOME name =>
298 let
299 val fname = OS.Path.joinDirFile {dir = dname,
300 file = name}
301 in
302 loop (if Posix.FileSys.ST.isDir (Posix.FileSys.stat fname) then
303 let
304 val dom = String.fields (fn ch => ch = #"/") fname
305 val dom = List.drop (dom, len)
306 val dom = String.concatWith "." (rev dom)
307
308 val dname' = OS.Path.joinDirFile {dir = dname,
309 file = name}
310 in
311 explore (dname',
312 findDiffs (site, dom, diffs))
313 end
314 else
315 diffs)
316 end
317 in
318 loop diffs
319 before Posix.FileSys.closedir dir
320 end
321 in
322 explore (OS.Path.joinDirFile {dir = Config.tmpDir,
323 file = site}, diffs)
324 end
325 in
326 exploreSites []
327 before Posix.FileSys.closedir dir
328 end
329
330val masterNode : string option ref = ref NONE
331fun dnsMaster () = !masterNode
332
333val _ = Env.containerV_one "domain"
334 ("domain", Env.string)
335 (fn (evs, dom) =>
336 let
337 val kind = Env.env dnsKind (evs, "DNS")
338 val ttl = Env.env Env.int (evs, "TTL")
339
340 val path = getPath dom
341
342 val () = (current := dom;
343 currentPath := (fn site => path (Config.tmpDir, site)))
344
345 fun saveSoa (kind, soa : soa) node =
346 let
347 val outf = domainFile {node = node, name = "soa"}
348 in
349 TextIO.output (outf, kind);
350 TextIO.output (outf, "\n");
351 TextIO.output (outf, Int.toString ttl);
352 TextIO.output (outf, "\n");
353 TextIO.output (outf, #ns soa);
354 TextIO.output (outf, "\n");
355 case #serial soa of
356 NONE => ()
357 | SOME n => TextIO.output (outf, Int.toString n);
358 TextIO.output (outf, "\n");
359 TextIO.output (outf, Int.toString (#ref soa));
360 TextIO.output (outf, "\n");
361 TextIO.output (outf, Int.toString (#ret soa));
362 TextIO.output (outf, "\n");
363 TextIO.output (outf, Int.toString (#exp soa));
364 TextIO.output (outf, "\n");
365 TextIO.output (outf, Int.toString (#min soa));
366 TextIO.output (outf, "\n");
367 TextIO.closeOut outf
368 end
369
370 fun saveNamed (kind, soa : soa, masterIp) node =
371 let
372 val outf = domainFile {node = node, name = "named.conf"}
373 in
374 TextIO.output (outf, "\nzone \"");
375 TextIO.output (outf, dom);
376 TextIO.output (outf, "\" IN {\n\ttype ");
377 TextIO.output (outf, kind);
378 TextIO.output (outf, ";\n\tfile \"");
379 TextIO.output (outf, Config.Bind.zonePath);
380 TextIO.output (outf, "/");
381 TextIO.output (outf, dom);
382 TextIO.output (outf, ".zone\";\n");
383 case kind of
384 "master" => TextIO.output (outf, "\tallow-update { none; };\n")
385 | _ => (TextIO.output (outf, "\tmasters { ");
386 TextIO.output (outf, masterIp);
387 TextIO.output (outf, " };\n"));
388 TextIO.output (outf, "};\n");
389 TextIO.closeOut outf
390 end
391 in
392 case kind of
393 NoDns => masterNode := NONE
394 | UseDns dns =>
395 let
396 val masterIp =
397 case #master dns of
398 InternalMaster node => valOf (SM.find (nodeMap, node))
399 | ExternalMaster ip => ip
400 in
401 app (saveSoa ("slave", #soa dns)) (#slaves dns);
402 app (saveNamed ("slave", #soa dns, masterIp)) (#slaves dns);
403 case #master dns of
404 InternalMaster node =>
405 (masterNode := SOME node;
406 saveSoa ("master", #soa dns) node;
407 saveNamed ("master", #soa dns, masterIp) node)
408 | _ => masterNode := NONE;
409 !befores dom
410 end
411 end,
412 fn () => !afters (!current))
413
414val () = Env.registerPre (fn () => (ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, ""],
415 fn cl => "Temp file cleanup failed: " ^ cl));
416 OS.FileSys.mkDir Config.tmpDir;
417 app (fn node => OS.FileSys.mkDir
418 (OS.Path.joinDirFile {dir = Config.tmpDir,
419 file = node}))
420 nodes;
421 app (fn node => OS.FileSys.mkDir
422 (OS.Path.joinDirFile {dir = Config.resultRoot,
423 file = node})
424 handle OS.SysErr _ => ())
425 nodes))
426
427val () = Env.registerPost (fn () =>
428 let
429 val diffs = findAllDiffs ()
430
431 val diffs = map (fn (site, dom, dir, Add' {src, dst}) =>
432 (Slave.shellF ([Config.cp, " ", src, " ", dst],
433 fn cl => "Copy failed: " ^ cl);
434 (site,
435 {action = Slave.Add,
436 domain = dom,
437 dir = dir,
438 file = dst}))
439 | (site, dom, dir, Delete' dst) =>
440 (OS.FileSys.remove dst
441 handle OS.SysErr _ =>
442 ErrorMsg.error NONE ("Delete failed for " ^ dst);
443 (site,
444 {action = Slave.Delete,
445 domain = dom,
446 dir = dir,
447 file = dst}))
448 | (site, dom, dir, Modify' {src, dst}) =>
449 (Slave.shellF ([Config.cp, " ", src, " ", dst],
450 fn cl => "Copy failed: " ^ cl);
451 (site,
452 {action = Slave.Modify,
453 domain = dom,
454 dir = dir,
455 file = dst}))) diffs
456 in
457 if !ErrorMsg.anyErrors then
458 ()
459 else
460 Slave.handleChanges (map #2 diffs);
461 ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, ""],
462 fn cl => "Temp file cleanup failed: " ^ cl))
463 end)
464
465
466
467end
Unnamed repository; edit this file to name it for gitweb.