Fix BIND slave syntax
[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
23open MsgTypes
24
25structure SM = DataStructures.StringMap
26structure SS = DataStructures.StringSet
27
28val ssl_context = ref (NONE : OpenSSL.context option)
29fun set_context ctx = ssl_context := SOME ctx
30
31val nodes = map #1 Config.nodeIps
32val nodeMap = foldl (fn ((node, ip), mp) => SM.insert (mp, node, ip))
33 SM.empty Config.nodeIps
34fun nodeIp node = valOf (SM.find (nodeMap, node))
35
36val usr = ref ""
37fun getUser () = !usr
38
39val your_doms = ref SS.empty
40fun your_domains () = !your_doms
41
42val your_usrs = ref SS.empty
43fun your_users () = !your_usrs
44
45val your_grps = ref SS.empty
46fun your_groups () = !your_grps
47
48val your_pths = ref SS.empty
49fun your_paths () = !your_pths
50
51fun setUser user =
52 (usr := user;
53 your_doms := Acl.class {user = getUser (),
54 class = "domain"};
55 your_usrs := Acl.class {user = getUser (),
56 class = "user"};
57 your_grps := Acl.class {user = getUser (),
58 class = "group"};
59 your_pths := Acl.class {user = getUser (),
60 class = "path"})
61
62fun validIp s =
63 case map Int.fromString (String.fields (fn ch => ch = #".") s) of
64 [SOME n1, SOME n2, SOME n3, SOME n4] =>
65 n1 >= 0 andalso n1 < 256 andalso n2 >= 0 andalso n2 < 256 andalso n3 >= 0 andalso n3 < 256 andalso n4 >= 0 andalso n4 < 256
66 | _ => false
67
68fun isIdent ch = Char.isLower ch orelse Char.isDigit ch
69
70fun validHost s =
71 size s > 0 andalso size s < 20
72 andalso CharVector.all (fn ch => isIdent ch orelse ch = #"-") s
73
74fun validDomain s =
75 size s > 0 andalso size s < 100
76 andalso List.all validHost (String.fields (fn ch => ch = #".") s)
77
78fun validNode s = List.exists (fn s' => s = s') nodes
79
80fun yourDomain s = SS.member (your_domains (), s)
81fun yourUser s = SS.member (your_users (), s)
82fun yourGroup s = SS.member (your_groups (), s)
83fun yourPath path =
84 List.all (fn s => s <> "..") (String.fields (fn ch => ch = #"/") path)
85 andalso CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"." orelse ch = #"/"
86 orelse ch = #"-" orelse ch = #"_") path
87 andalso SS.exists (fn s' => path = s' orelse String.isPrefix (s' ^ "/") path) (your_paths ())
88
89fun yourDomainHost s =
90 yourDomain s
91 orelse let
92 val (pref, suf) = Substring.splitl (fn ch => ch <> #".") (Substring.full s)
93 in
94 Substring.size suf > 0
95 andalso validHost (Substring.string pref)
96 andalso yourDomain (Substring.string
97 (Substring.slice (suf, 1, NONE)))
98 end
99
100fun validUser s = size s > 0 andalso size s < 20
101 andalso CharVector.all Char.isAlphaNum s
102
103val validGroup = validUser
104
105val _ = Env.type_one "no_spaces"
106 Env.string
107 (CharVector.all (fn ch => not (Char.isSpace ch)))
108val _ = Env.type_one "no_newlines"
109 Env.string
110 (CharVector.all (fn ch => ch <> #"\n" andalso ch <> #"\r"))
111
112val _ = Env.type_one "ip"
113 Env.string
114 validIp
115
116val _ = Env.type_one "host"
117 Env.string
118 validHost
119
120val _ = Env.type_one "domain"
121 Env.string
122 validDomain
123
124val _ = Env.type_one "your_domain"
125 Env.string
126 yourDomain
127
128val _ = Env.type_one "your_domain_host"
129 Env.string
130 yourDomainHost
131
132val _ = Env.type_one "user"
133 Env.string
134 validUser
135
136val _ = Env.type_one "group"
137 Env.string
138 validGroup
139
140val _ = Env.type_one "your_user"
141 Env.string
142 yourUser
143
144val _ = Env.type_one "your_group"
145 Env.string
146 yourGroup
147
148val _ = Env.type_one "your_path"
149 Env.string
150 yourPath
151
152val _ = Env.type_one "node"
153 Env.string
154 validNode
155
156open Ast
157
158val dl = ErrorMsg.dummyLoc
159
160val nsD = (EString Config.defaultNs, dl)
161val serialD = (EVar "serialAuto", dl)
162val refD = (EInt Config.defaultRefresh, dl)
163val retD = (EInt Config.defaultRetry, dl)
164val expD = (EInt Config.defaultExpiry, dl)
165val minD = (EInt Config.defaultMinimum, dl)
166
167val soaD = multiApp ((EVar "soa", dl),
168 dl,
169 [nsD, serialD, refD, retD, expD, minD])
170
171val masterD = (EApp ((EVar "internalMaster", dl),
172 (EString Config.masterNode, dl)),
173 dl)
174
175val slavesD = (EList (map (fn s => (EString s, dl)) Config.slaveNodes), dl)
176
177val _ = Defaults.registerDefault ("Mailbox",
178 (TBase "email", dl),
179 (fn () => (EString (getUser ()), dl)))
180
181val _ = Defaults.registerDefault ("DNS",
182 (TBase "dnsKind", dl),
183 (fn () => multiApp ((EVar "useDns", dl),
184 dl,
185 [soaD, masterD, slavesD])))
186
187val _ = Defaults.registerDefault ("TTL",
188 (TBase "int", dl),
189 (fn () => (EInt Config.Bind.defaultTTL, dl)))
190
191type soa = {ns : string,
192 serial : int option,
193 ref : int,
194 ret : int,
195 exp : int,
196 min : int}
197
198val serial = fn (EVar "serialAuto", _) => SOME NONE
199 | (EApp ((EVar "serialConst", _), n), _) => Option.map SOME (Env.int n)
200 | _ => NONE
201
202val soa = fn (EApp ((EApp ((EApp ((EApp ((EApp ((EApp
203 ((EVar "soa", _), ns), _),
204 sl), _),
205 rf), _),
206 ret), _),
207 exp), _),
208 min), _) =>
209 (case (Env.string ns, serial sl, Env.int rf,
210 Env.int ret, Env.int exp, Env.int min) of
211 (SOME ns, SOME sl, SOME rf,
212 SOME ret, SOME exp, SOME min) =>
213 SOME {ns = ns,
214 serial = sl,
215 ref = rf,
216 ret = ret,
217 exp = exp,
218 min = min}
219 | _ => NONE)
220 | _ => NONE
221
222datatype master =
223 ExternalMaster of string
224 | InternalMaster of string
225
226val ip = fn (EApp ((EVar "ip_of_node", _), e), _) => Option.map nodeIp (Env.string e)
227 | e => Env.string e
228
229val master = fn (EApp ((EVar "externalMaster", _), e), _) => Option.map ExternalMaster (ip e)
230 | (EApp ((EVar "internalMaster", _), e), _) => Option.map InternalMaster (Env.string e)
231 | _ => NONE
232
233datatype dnsKind =
234 UseDns of {soa : soa,
235 master : master,
236 slaves : string list}
237 | NoDns
238
239val dnsKind = fn (EApp ((EApp ((EApp
240 ((EVar "useDns", _), sa), _),
241 mstr), _),
242 slaves), _) =>
243 (case (soa sa, master mstr, Env.list Env.string slaves) of
244 (SOME sa, SOME mstr, SOME slaves) =>
245 SOME (UseDns {soa = sa,
246 master = mstr,
247 slaves = slaves})
248 | _ => NONE)
249 | (EVar "noDns", _) => SOME NoDns
250 | _ => NONE
251
252val befores = ref (fn (_ : string) => ())
253val afters = ref (fn (_ : string) => ())
254
255fun registerBefore f =
256 let
257 val old = !befores
258 in
259 befores := (fn x => (old x; f x))
260 end
261
262fun registerAfter f =
263 let
264 val old = !afters
265 in
266 afters := (fn x => (old x; f x))
267 end
268
269val current = ref ""
270val currentPath = ref (fn (_ : string) => "")
271
272val scratch = ref ""
273
274fun currentDomain () = !current
275
276fun domainFile {node, name} = ((*print ("Opening " ^ !currentPath node ^ name ^ "\n");*)
277 TextIO.openOut (!currentPath node ^ name))
278
279fun getPath domain =
280 let
281 val toks = String.fields (fn ch => ch = #".") domain
282
283 val elems = foldr (fn (piece, elems) =>
284 let
285 val elems = piece :: elems
286
287 fun doNode node =
288 let
289 val path = String.concatWith "/"
290 (Config.resultRoot :: node :: rev elems)
291 val tmpPath = String.concatWith "/"
292 (Config.tmpDir :: node :: rev elems)
293 in
294 (if Posix.FileSys.ST.isDir
295 (Posix.FileSys.stat path) then
296 ()
297 else
298 (OS.FileSys.remove path;
299 OS.FileSys.mkDir path))
300 handle OS.SysErr _ => OS.FileSys.mkDir path;
301
302 (if Posix.FileSys.ST.isDir
303 (Posix.FileSys.stat tmpPath) then
304 ()
305 else
306 (OS.FileSys.remove tmpPath;
307 OS.FileSys.mkDir tmpPath))
308 handle OS.SysErr _ => OS.FileSys.mkDir tmpPath
309 end
310 in
311 app doNode nodes;
312 elems
313 end) [] toks
314 in
315 fn (root, site) => String.concatWith "/" (root :: site :: rev ("" :: elems))
316 end
317
318datatype file_action' =
319 Add' of {src : string, dst : string}
320 | Delete' of string
321 | Modify' of {src : string, dst : string}
322
323fun findDiffs (site, dom, acts) =
324 let
325 val gp = getPath dom
326 val realPath = gp (Config.resultRoot, site)
327 val tmpPath = gp (Config.tmpDir, site)
328
329 (*val _ = print ("getDiffs(" ^ site ^ ", " ^ dom ^ ")... " ^ realPath ^ "; " ^ tmpPath ^ "\n")*)
330
331 val dir = Posix.FileSys.opendir realPath
332
333 fun loopReal acts =
334 case Posix.FileSys.readdir dir of
335 NONE => (Posix.FileSys.closedir dir;
336 acts)
337 | SOME fname =>
338 let
339 val real = OS.Path.joinDirFile {dir = realPath,
340 file = fname}
341 val tmp = OS.Path.joinDirFile {dir = tmpPath,
342 file = fname}
343 in
344 if Posix.FileSys.ST.isDir (Posix.FileSys.stat real) then
345 loopReal acts
346 else if Posix.FileSys.access (tmp, []) then
347 if Slave.shell [Config.diff, " ", real, " ", tmp] then
348 loopReal acts
349 else
350 loopReal ((site, dom, realPath, Modify' {src = tmp, dst = real}) :: acts)
351 else
352 loopReal ((site, dom, realPath, Delete' real) :: acts)
353 end
354
355 val acts = loopReal acts
356
357 val dir = Posix.FileSys.opendir tmpPath
358
359 fun loopTmp acts =
360 case Posix.FileSys.readdir dir of
361 NONE => (Posix.FileSys.closedir dir;
362 acts)
363 | SOME fname =>
364 let
365 val real = OS.Path.joinDirFile {dir = realPath,
366 file = fname}
367 val tmp = OS.Path.joinDirFile {dir = tmpPath,
368 file = fname}
369 in
370 if Posix.FileSys.ST.isDir (Posix.FileSys.stat tmp) then
371 loopTmp acts
372 else if Posix.FileSys.access (real, []) then
373 loopTmp acts
374 else
375 loopTmp ((site, dom, realPath, Add' {src = tmp, dst = real}) :: acts)
376 end
377
378 val acts = loopTmp acts
379 in
380 acts
381 end
382
383fun findAllDiffs () =
384 let
385 val dir = Posix.FileSys.opendir Config.tmpDir
386 val len = length (String.fields (fn ch => ch = #"/") Config.tmpDir) + 1
387
388 fun exploreSites diffs =
389 case Posix.FileSys.readdir dir of
390 NONE => diffs
391 | SOME site =>
392 let
393 fun explore (dname, diffs) =
394 let
395 val dir = Posix.FileSys.opendir dname
396
397 fun loop diffs =
398 case Posix.FileSys.readdir dir of
399 NONE => diffs
400 | SOME name =>
401 let
402 val fname = OS.Path.joinDirFile {dir = dname,
403 file = name}
404 in
405 loop (if Posix.FileSys.ST.isDir (Posix.FileSys.stat fname) then
406 let
407 val dom = String.fields (fn ch => ch = #"/") fname
408 val dom = List.drop (dom, len)
409 val dom = String.concatWith "." (rev dom)
410
411 val dname' = OS.Path.joinDirFile {dir = dname,
412 file = name}
413 in
414 explore (dname',
415 findDiffs (site, dom, diffs))
416 end
417 else
418 diffs)
419 end
420 in
421 loop diffs
422 before Posix.FileSys.closedir dir
423 end
424 in
425 exploreSites (explore (OS.Path.joinDirFile {dir = Config.tmpDir,
426 file = site}, diffs))
427 end
428 in
429 exploreSites []
430 before Posix.FileSys.closedir dir
431 end
432
433val masterNode : string option ref = ref NONE
434fun dnsMaster () = !masterNode
435
436val _ = Env.containerV_one "domain"
437 ("domain", Env.string)
438 (fn (evs, dom) =>
439 let
440 val kind = Env.env dnsKind (evs, "DNS")
441 val ttl = Env.env Env.int (evs, "TTL")
442
443 val path = getPath dom
444
445 val () = (current := dom;
446 currentPath := (fn site => path (Config.tmpDir, site)))
447
448 fun saveSoa (kind, soa : soa) node =
449 let
450 val outf = domainFile {node = node, name = "soa"}
451 in
452 TextIO.output (outf, kind);
453 TextIO.output (outf, "\n");
454 TextIO.output (outf, Int.toString ttl);
455 TextIO.output (outf, "\n");
456 TextIO.output (outf, #ns soa);
457 TextIO.output (outf, "\n");
458 case #serial soa of
459 NONE => ()
460 | SOME n => TextIO.output (outf, Int.toString n);
461 TextIO.output (outf, "\n");
462 TextIO.output (outf, Int.toString (#ref soa));
463 TextIO.output (outf, "\n");
464 TextIO.output (outf, Int.toString (#ret soa));
465 TextIO.output (outf, "\n");
466 TextIO.output (outf, Int.toString (#exp soa));
467 TextIO.output (outf, "\n");
468 TextIO.output (outf, Int.toString (#min soa));
469 TextIO.output (outf, "\n");
470 TextIO.closeOut outf
471 end
472
473 fun saveNamed (kind, soa : soa, masterIp) node =
474 let
475 val outf = domainFile {node = node, name = "named.conf"}
476 in
477 TextIO.output (outf, "\nzone \"");
478 TextIO.output (outf, dom);
479 TextIO.output (outf, "\" IN {\n\ttype ");
480 TextIO.output (outf, kind);
481 TextIO.output (outf, ";\n\tfile \"");
482 TextIO.output (outf, Config.Bind.zonePath_real);
483 TextIO.output (outf, "/");
484 TextIO.output (outf, dom);
485 TextIO.output (outf, ".zone\";\n");
486 case kind of
487 "master" => TextIO.output (outf, "\tallow-update { none; };\n")
488 | _ => (TextIO.output (outf, "\tmasters { ");
489 TextIO.output (outf, masterIp);
490 TextIO.output (outf, "; };\n"));
491 TextIO.output (outf, "};\n");
492 TextIO.closeOut outf
493 end
494 in
495 case kind of
496 NoDns => masterNode := NONE
497 | UseDns dns =>
498 let
499 val masterIp =
500 case #master dns of
501 InternalMaster node => valOf (SM.find (nodeMap, node))
502 | ExternalMaster ip => ip
503 in
504 app (saveSoa ("slave", #soa dns)) (#slaves dns);
505 app (saveNamed ("slave", #soa dns, masterIp)) (#slaves dns);
506 case #master dns of
507 InternalMaster node =>
508 (masterNode := SOME node;
509 saveSoa ("master", #soa dns) node;
510 saveNamed ("master", #soa dns, masterIp) node)
511 | _ => masterNode := NONE;
512 !befores dom
513 end
514 end,
515 fn () => !afters (!current))
516
517val () = Env.registerPre (fn () => (ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, ""],
518 fn cl => "Temp file cleanup failed: " ^ cl));
519 OS.FileSys.mkDir Config.tmpDir;
520 app (fn node => OS.FileSys.mkDir
521 (OS.Path.joinDirFile {dir = Config.tmpDir,
522 file = node}))
523 nodes;
524 app (fn node => OS.FileSys.mkDir
525 (OS.Path.joinDirFile {dir = Config.resultRoot,
526 file = node})
527 handle OS.SysErr _ => ())
528 nodes))
529
530val () = Env.registerPost (fn () =>
531 let
532 val diffs = findAllDiffs ()
533
534 val diffs = map (fn (site, dom, dir, Add' {src, dst}) =>
535 (Slave.shellF ([Config.cp, " ", src, " ", dst],
536 fn cl => "Copy failed: " ^ cl);
537 (site,
538 {action = Slave.Add,
539 domain = dom,
540 dir = dir,
541 file = dst}))
542 | (site, dom, dir, Delete' dst) =>
543 (OS.FileSys.remove dst
544 handle OS.SysErr _ =>
545 ErrorMsg.error NONE ("Delete failed for " ^ dst);
546 (site,
547 {action = Slave.Delete,
548 domain = dom,
549 dir = dir,
550 file = dst}))
551 | (site, dom, dir, Modify' {src, dst}) =>
552 (Slave.shellF ([Config.cp, " ", src, " ", dst],
553 fn cl => "Copy failed: " ^ cl);
554 (site,
555 {action = Slave.Modify,
556 domain = dom,
557 dir = dir,
558 file = dst}))) diffs
559 in
560 if !ErrorMsg.anyErrors then
561 ()
562 else let
563 val changed = foldl (fn ((site, file), changed) =>
564 let
565 val ls = case SM.find (changed, site) of
566 NONE => []
567 | SOME ls => ls
568 in
569 SM.insert (changed, site, file :: ls)
570 end) SM.empty diffs
571
572 fun handleSite (site, files) =
573 let
574
575 in
576 print ("New configuration for node " ^ site ^ "\n");
577 if site = Config.defaultNode then
578 Slave.handleChanges files
579 else let
580 val bio = OpenSSL.connect (valOf (!ssl_context),
581 nodeIp site
582 ^ ":"
583 ^ Int.toString Config.slavePort)
584 in
585 app (fn file => Msg.send (bio, MsgFile file)) files;
586 Msg.send (bio, MsgDoFiles);
587 case Msg.recv bio of
588 NONE => print "Slave closed connection unexpectedly\n"
589 | SOME m =>
590 case m of
591 MsgOk => print ("Slave " ^ site ^ " finished\n")
592 | MsgError s => print ("Slave " ^ site
593 ^ " returned error: " ^
594 s ^ "\n")
595 | _ => print ("Slave " ^ site
596 ^ " returned unexpected command\n");
597 OpenSSL.close bio
598 end
599 end
600 in
601 SM.appi handleSite changed
602 end;
603 ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, ""],
604 fn cl => "Temp file cleanup failed: " ^ cl))
605 end)
606
607end