Remove Config.{dispatcher,defaultNode}
[hcoop/domtool2.git] / src / domain.sml
1 (* HCoop Domtool (http://hcoop.sourceforge.net/)
2 * Copyright (c) 2006-2007, 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
21 structure Domain :> DOMAIN = struct
22
23 open MsgTypes
24
25 structure SM = DataStructures.StringMap
26 structure SS = DataStructures.StringSet
27
28 val ssl_context = ref (NONE : OpenSSL.context option)
29 fun set_context ctx = ssl_context := SOME ctx
30 fun get_context () = valOf (!ssl_context)
31
32 val nodes = map #1 Config.nodeIps
33 val nodeMap = foldl (fn ((node, ip), mp) => SM.insert (mp, node, ip))
34 SM.empty Config.nodeIps
35 fun nodeIp node = valOf (SM.find (nodeMap, node))
36
37 val usr = ref ""
38 fun getUser () = !usr
39 val fakePrivs = ref false
40 val isClient = ref false
41
42 val your_doms = ref SS.empty
43 fun your_domains () = !your_doms
44
45 val your_usrs = ref SS.empty
46 fun your_users () = !your_usrs
47
48 val your_grps = ref SS.empty
49 fun your_groups () = !your_grps
50
51 val your_pths = ref SS.empty
52 fun your_paths () = !your_pths
53
54 val your_ipss = ref SS.empty
55 fun your_ips () = !your_ipss
56
57 val world_readable = SS.addList (SS.empty, Config.worldReadable)
58 val readable_pths = ref world_readable
59 fun readable_paths () = !readable_pths
60
61 fun setUser user =
62 let
63 val () = usr := user
64
65 val your_paths = Acl.class {user = getUser (),
66 class = "path"}
67 in
68 fakePrivs := false;
69 your_doms := Acl.class {user = getUser (),
70 class = "domain"};
71 your_usrs := Acl.class {user = getUser (),
72 class = "user"};
73 your_grps := Acl.class {user = getUser (),
74 class = "group"};
75 your_pths := your_paths;
76 readable_pths := SS.union (your_paths, world_readable);
77 your_ipss := Acl.class {user = getUser (),
78 class = "ip"}
79 end
80
81 fun declareClient () = isClient := true
82 fun fakePrivileges () = if !isClient then
83 fakePrivs := true
84 else
85 raise Fail "Tried to fake privileges as non-client"
86
87 fun validIp s =
88 case map Int.fromString (String.fields (fn ch => ch = #".") s) of
89 [SOME n1, SOME n2, SOME n3, SOME n4] =>
90 n1 >= 0 andalso n1 < 256 andalso n2 >= 0 andalso n2 < 256 andalso n3 >= 0 andalso n3 < 256 andalso n4 >= 0 andalso n4 < 256
91 | _ => false
92
93 fun isHexDigit ch = Char.isDigit ch orelse (ord ch >= ord #"a" andalso ord ch <= ord #"f")
94
95 fun validIpv6 s =
96 let
97 val fields = String.fields (fn ch => ch = #":") s
98
99 val empties = foldl (fn ("", n) => n + 1
100 | (_, n) => n) 0 fields
101
102 fun noIpv4 maxLen =
103 length fields >= 2
104 andalso length fields <= maxLen
105 andalso empties <= 1
106 andalso List.all (fn "" => true
107 | s => size s <= 4
108 andalso CharVector.all isHexDigit s) fields
109
110 fun hasIpv4 () =
111 length fields > 0
112 andalso
113 let
114 val maybeIpv4 = List.last fields
115 val theRest = List.take (fields, length fields - 1)
116 in
117 validIp maybeIpv4 andalso noIpv4 6
118 end
119 in
120 noIpv4 8 orelse hasIpv4 ()
121 end
122
123 fun isIdent ch = Char.isLower ch orelse Char.isDigit ch
124
125 fun validHost s =
126 size s > 0 andalso size s < 50
127 andalso CharVector.all (fn ch => isIdent ch orelse ch = #"-") s
128
129 fun validDomain s =
130 size s > 0 andalso size s < 200
131 andalso List.all validHost (String.fields (fn ch => ch = #".") s)
132
133 fun validNode s = List.exists (fn s' => s = s') nodes
134
135 fun yourDomain s = !fakePrivs orelse SS.member (your_domains (), s)
136 fun yourUser s = SS.member (your_users (), s)
137 fun yourGroup s = SS.member (your_groups (), s)
138 fun checkPath paths path =
139 (List.all (fn s => s <> "..") (String.fields (fn ch => ch = #"/") path)
140 andalso CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"." orelse ch = #"/"
141 orelse ch = #"-" orelse ch = #"_") path
142 andalso SS.exists (fn s' => path = s' orelse String.isPrefix (s' ^ "/") path) (paths ()))
143 val yourPath = checkPath your_paths
144 val readablePath = checkPath readable_paths
145 fun yourIp s = !fakePrivs orelse SS.member (your_ips (), s)
146
147 fun yourDomainHost s =
148 !fakePrivs
149 orelse yourDomain s
150 orelse let
151 val (pref, suf) = Substring.splitl (fn ch => ch <> #".") (Substring.full s)
152 in
153 Substring.size suf > 0
154 andalso validHost (Substring.string pref)
155 andalso yourDomain (Substring.string
156 (Substring.slice (suf, 1, NONE)))
157 end
158
159 val yourDomain = yourDomainHost
160
161 fun validUser s = size s > 0 andalso size s < 20
162 andalso CharVector.all Char.isAlphaNum s
163
164 fun validEmailUser s =
165 size s > 0 andalso size s < 50
166 andalso CharVector.all (fn ch => Char.isAlphaNum ch
167 orelse ch = #"."
168 orelse ch = #"_"
169 orelse ch = #"-"
170 orelse ch = #"+") s
171
172 val validGroup = validUser
173
174 val _ = Env.type_one "no_spaces"
175 Env.string
176 (CharVector.all (fn ch => Char.isPrint ch andalso not (Char.isSpace ch)
177 andalso ch <> #"\"" andalso ch <> #"'"))
178 val _ = Env.type_one "no_newlines"
179 Env.string
180 (CharVector.all (fn ch => Char.isPrint ch andalso ch <> #"\n" andalso ch <> #"\r"
181 andalso ch <> #"\""))
182
183 val _ = Env.type_one "ip"
184 Env.string
185 validIp
186
187 val _ = Env.type_one "ipv6"
188 Env.string
189 validIpv6
190
191 val _ = Env.type_one "host"
192 Env.string
193 validHost
194
195 val _ = Env.type_one "domain"
196 Env.string
197 validDomain
198
199 val _ = Env.type_one "your_domain"
200 Env.string
201 yourDomain
202
203 val _ = Env.type_one "your_domain_host"
204 Env.string
205 yourDomainHost
206
207 val _ = Env.type_one "user"
208 Env.string
209 validUser
210
211 val _ = Env.type_one "group"
212 Env.string
213 validGroup
214
215 val _ = Env.type_one "your_user"
216 Env.string
217 yourUser
218
219 val _ = Env.type_one "your_group"
220 Env.string
221 yourGroup
222
223 val _ = Env.type_one "your_path"
224 Env.string
225 yourPath
226
227 val _ = Env.type_one "readable_path"
228 Env.string
229 readablePath
230
231 val _ = Env.type_one "your_ip"
232 Env.string
233 yourIp
234
235 val _ = Env.type_one "node"
236 Env.string
237 validNode
238
239 val _ = Env.type_one "mime_type"
240 Env.string
241 (CharVector.exists (fn ch => ch = #"/"))
242
243 val _ = Env.registerFunction ("your_ip_to_ip",
244 fn [e] => SOME e
245 | _ => NONE)
246
247 val _ = Env.registerFunction ("dns_node_to_node",
248 fn [e] => SOME e
249 | _ => NONE)
250
251 val _ = Env.registerFunction ("mail_node_to_node",
252 fn [e] => SOME e
253 | _ => NONE)
254
255
256 open Ast
257
258 val dl = ErrorMsg.dummyLoc
259
260 val _ = Env.registerFunction ("end_in_slash",
261 fn [(EString "", _)] => SOME (EString "/", dl)
262 | [(EString s, _)] =>
263 SOME (EString (if String.sub (s, size s - 1) = #"/" then
264 s
265 else
266 s ^ "/"), dl)
267 | _ => NONE)
268
269
270 val nsD = (EString Config.defaultNs, dl)
271 val serialD = (EVar "serialAuto", dl)
272 val refD = (EInt Config.defaultRefresh, dl)
273 val retD = (EInt Config.defaultRetry, dl)
274 val expD = (EInt Config.defaultExpiry, dl)
275 val minD = (EInt Config.defaultMinimum, dl)
276
277 val soaD = multiApp ((EVar "soa", dl),
278 dl,
279 [nsD, serialD, refD, retD, expD, minD])
280
281 val masterD = (EApp ((EVar "internalMaster", dl),
282 (EString Config.Bind.masterNode, dl)),
283 dl)
284
285 val slavesD = (EList (map (fn s => (EString s, dl))
286 (List.filter (fn x => List.exists (fn y => y = x) (Config.dnsNodes_all @ Config.dnsNodes_admin)) Config.Bind.slaveNodes)), dl)
287
288 val _ = Defaults.registerDefault ("Aliases",
289 (TList (TBase "your_domain", dl), dl),
290 (fn () => (EList [], dl)))
291
292 val _ = Defaults.registerDefault ("Mailbox",
293 (TBase "email", dl),
294 (fn () => (EString (getUser ()), dl)))
295
296 val _ = Defaults.registerDefault ("DNS",
297 (TBase "dnsKind", dl),
298 (fn () => multiApp ((EVar "useDns", dl),
299 dl,
300 [soaD, masterD, slavesD])))
301
302 val _ = Defaults.registerDefault ("TTL",
303 (TBase "int", dl),
304 (fn () => (EInt Config.Bind.defaultTTL, dl)))
305
306 type soa = {ns : string,
307 serial : int option,
308 ref : int,
309 ret : int,
310 exp : int,
311 min : int}
312
313 val serial = fn (EVar "serialAuto", _) => SOME NONE
314 | (EApp ((EVar "serialConst", _), n), _) => Option.map SOME (Env.int n)
315 | _ => NONE
316
317 val soa = fn (EApp ((EApp ((EApp ((EApp ((EApp ((EApp
318 ((EVar "soa", _), ns), _),
319 sl), _),
320 rf), _),
321 ret), _),
322 exp), _),
323 min), _) =>
324 (case (Env.string ns, serial sl, Env.int rf,
325 Env.int ret, Env.int exp, Env.int min) of
326 (SOME ns, SOME sl, SOME rf,
327 SOME ret, SOME exp, SOME min) =>
328 SOME {ns = ns,
329 serial = sl,
330 ref = rf,
331 ret = ret,
332 exp = exp,
333 min = min}
334 | _ => NONE)
335 | _ => NONE
336
337 datatype master =
338 ExternalMaster of string
339 | InternalMaster of string
340
341 val ip = Env.string
342
343 val _ = Env.registerFunction ("ip_of_node",
344 fn [(EString node, _)] => SOME (EString (nodeIp node), dl)
345 | _ => NONE)
346
347 val master = fn (EApp ((EVar "externalMaster", _), e), _) => Option.map ExternalMaster (ip e)
348 | (EApp ((EVar "internalMaster", _), e), _) => Option.map InternalMaster (Env.string e)
349 | _ => NONE
350
351 datatype dnsKind =
352 UseDns of {soa : soa,
353 master : master,
354 slaves : string list}
355 | NoDns
356
357 val dnsKind = fn (EApp ((EApp ((EApp
358 ((EVar "useDns", _), sa), _),
359 mstr), _),
360 slaves), _) =>
361 (case (soa sa, master mstr, Env.list Env.string slaves) of
362 (SOME sa, SOME mstr, SOME slaves) =>
363 SOME (UseDns {soa = sa,
364 master = mstr,
365 slaves = slaves})
366 | _ => NONE)
367 | (EVar "noDns", _) => SOME NoDns
368 | _ => NONE
369
370 val befores = ref (fn (_ : string) => ())
371 val afters = ref (fn (_ : string) => ())
372
373 fun registerBefore f =
374 let
375 val old = !befores
376 in
377 befores := (fn x => (old x; f x))
378 end
379
380 fun registerAfter f =
381 let
382 val old = !afters
383 in
384 afters := (fn x => (old x; f x))
385 end
386
387 val globals = ref (fn () => ())
388 val locals = ref (fn () => ())
389
390 fun registerResetGlobal f =
391 let
392 val old = !globals
393 in
394 globals := (fn x => (old x; f x))
395 end
396
397 fun registerResetLocal f =
398 let
399 val old = !locals
400 in
401 locals := (fn x => (old x; f x))
402 end
403
404 fun resetGlobal () = (!globals ();
405 ignore (OS.Process.system (Config.rm ^ " -rf " ^ Config.resultRoot ^ "/*")))
406 fun resetLocal () = !locals ()
407
408 val current = ref ""
409 val currentPath = ref (fn (_ : string) => "")
410 val currentPathAli = ref (fn (_ : string, _ : string) => "")
411
412 val scratch = ref ""
413
414 fun currentDomain () = !current
415
416 val currentsAli = ref ([] : string list)
417
418 fun currentAliasDomains () = !currentsAli
419 fun currentDomains () = currentDomain () :: currentAliasDomains ()
420
421 fun domainFile {node, name} = ((*print ("Opening " ^ !currentPath node ^ name ^ "\n");*)
422 TextIO.openOut (!currentPath node ^ name))
423
424 type files = {write : string -> unit,
425 writeDom : unit -> unit,
426 close : unit -> unit}
427
428 fun domainsFile {node, name} =
429 let
430 val doms = currentDomains ()
431 val files = map (fn dom => (dom, TextIO.openOut (!currentPathAli (dom, node) ^ name))) doms
432 in
433 {write = fn s => app (fn (_, outf) => TextIO.output (outf, s)) files,
434 writeDom = fn () => app (fn (dom, outf) => TextIO.output (outf, dom)) files,
435 close = fn () => app (fn (_, outf) => TextIO.closeOut outf) files}
436 end
437
438 fun getPath domain =
439 let
440 val toks = String.fields (fn ch => ch = #".") domain
441
442 val elems = foldr (fn (piece, elems) =>
443 let
444 val elems = piece :: elems
445
446 fun doNode node =
447 let
448 val path = String.concatWith "/"
449 (Config.resultRoot :: node :: rev elems)
450 val tmpPath = String.concatWith "/"
451 (Config.tmpDir :: node :: rev elems)
452 in
453 (if Posix.FileSys.ST.isDir
454 (Posix.FileSys.stat path) then
455 ()
456 else
457 (OS.FileSys.remove path;
458 OS.FileSys.mkDir path))
459 handle OS.SysErr _ => OS.FileSys.mkDir path;
460
461 (if Posix.FileSys.ST.isDir
462 (Posix.FileSys.stat tmpPath) then
463 ()
464 else
465 (OS.FileSys.remove tmpPath;
466 OS.FileSys.mkDir tmpPath))
467 handle OS.SysErr _ => OS.FileSys.mkDir tmpPath
468 end
469 in
470 app doNode nodes;
471 elems
472 end) [] toks
473 in
474 fn (root, site) => String.concatWith "/" (root :: site :: rev ("" :: elems))
475 end
476
477 datatype file_action' =
478 Add' of {src : string, dst : string}
479 | Delete' of string
480 | Modify' of {src : string, dst : string}
481
482 fun findDiffs (prefixes, site, dom, acts) =
483 let
484 val gp = getPath dom
485 val realPath = gp (Config.resultRoot, site)
486 val tmpPath = gp (Config.tmpDir, site)
487
488 (*val _ = print ("getDiffs(" ^ site ^ ", " ^ dom ^ ")... " ^ realPath ^ "; " ^ tmpPath ^ "\n")*)
489
490 val dir = Posix.FileSys.opendir realPath
491
492 fun loopReal acts =
493 case Posix.FileSys.readdir dir of
494 NONE => (Posix.FileSys.closedir dir;
495 acts)
496 | SOME fname =>
497 let
498 val real = OS.Path.joinDirFile {dir = realPath,
499 file = fname}
500 val tmp = OS.Path.joinDirFile {dir = tmpPath,
501 file = fname}
502 in
503 if Posix.FileSys.ST.isDir (Posix.FileSys.stat real) then
504 loopReal acts
505 else if Posix.FileSys.access (tmp, []) then
506 if Slave.shell [Config.diff, " ", real, " ", tmp] then
507 loopReal acts
508 else
509 loopReal ((site, dom, realPath, Modify' {src = tmp, dst = real}) :: acts)
510 else if List.exists (fn prefix => String.isPrefix prefix real) prefixes then
511 loopReal ((site, dom, realPath, Delete' real) :: acts)
512 else
513 loopReal acts
514 end
515
516 val acts = loopReal acts
517
518 val dir = Posix.FileSys.opendir tmpPath
519
520 fun loopTmp acts =
521 case Posix.FileSys.readdir dir of
522 NONE => (Posix.FileSys.closedir dir;
523 acts)
524 | SOME fname =>
525 let
526 val real = OS.Path.joinDirFile {dir = realPath,
527 file = fname}
528 val tmp = OS.Path.joinDirFile {dir = tmpPath,
529 file = fname}
530 in
531 if Posix.FileSys.ST.isDir (Posix.FileSys.stat tmp) then
532 loopTmp acts
533 else if Posix.FileSys.access (real, []) then
534 loopTmp acts
535 else
536 loopTmp ((site, dom, realPath, Add' {src = tmp, dst = real}) :: acts)
537 end
538
539 val acts = loopTmp acts
540 in
541 acts
542 end
543
544 fun findAllDiffs prefixes =
545 let
546 val dir = Posix.FileSys.opendir Config.tmpDir
547 val len = length (String.fields (fn ch => ch = #"/") Config.tmpDir) + 1
548
549 fun exploreSites diffs =
550 case Posix.FileSys.readdir dir of
551 NONE => diffs
552 | SOME site =>
553 let
554 fun explore (dname, diffs) =
555 let
556 val dir = Posix.FileSys.opendir dname
557
558 fun loop diffs =
559 case Posix.FileSys.readdir dir of
560 NONE => diffs
561 | SOME name =>
562 let
563 val fname = OS.Path.joinDirFile {dir = dname,
564 file = name}
565 in
566 loop (if Posix.FileSys.ST.isDir (Posix.FileSys.stat fname) then
567 let
568 val dom = String.fields (fn ch => ch = #"/") fname
569 val dom = List.drop (dom, len)
570 val dom = String.concatWith "." (rev dom)
571
572 val dname' = OS.Path.joinDirFile {dir = dname,
573 file = name}
574 in
575 explore (dname',
576 findDiffs (prefixes, site, dom, diffs))
577 end
578 else
579 diffs)
580 end
581 in
582 loop diffs
583 before Posix.FileSys.closedir dir
584 end
585 in
586 exploreSites (explore (OS.Path.joinDirFile {dir = Config.tmpDir,
587 file = site}, diffs))
588 end
589 in
590 exploreSites []
591 before Posix.FileSys.closedir dir
592 end
593
594 val masterNode : string option ref = ref NONE
595 fun dnsMaster () = !masterNode
596
597 val seenDomains : string list ref = ref []
598
599 val _ = Env.containerV_one "domain"
600 ("domain", Env.string)
601 (fn (evs, dom) =>
602 let
603 val () = seenDomains := dom :: !seenDomains
604
605 val kind = Env.env dnsKind (evs, "DNS")
606 val ttl = Env.env Env.int (evs, "TTL")
607 val aliases = Env.env (Env.list Env.string) (evs, "Aliases")
608
609 val path = getPath dom
610
611 val () = (current := dom;
612 currentsAli := Slave.remove (Slave.removeDups aliases, dom);
613 currentPath := (fn site => path (Config.tmpDir, site));
614 currentPathAli := (fn (dom, site) => getPath dom (Config.tmpDir, site)))
615
616 fun saveSoa (kind, soa : soa) node =
617 let
618 val {write, writeDom, close} = domainsFile {node = node, name = "soa.conf"}
619 in
620 write kind;
621 write "\n";
622 write (Int.toString ttl);
623 write "\n";
624 write (#ns soa);
625 write "\n";
626 case #serial soa of
627 NONE => ()
628 | SOME n => write (Int.toString n);
629 write "\n";
630 write (Int.toString (#ref soa));
631 write "\n";
632 write (Int.toString (#ret soa));
633 write "\n";
634 write (Int.toString (#exp soa));
635 write "\n";
636 write (Int.toString (#min soa));
637 write "\n";
638 close ()
639 end
640
641 fun saveNamed (kind, soa : soa, masterIp, slaveIps) node =
642 if dom = "localhost" then
643 ()
644 else let
645 val {write, writeDom, close} = domainsFile {node = node, name = "named.conf"}
646 in
647 write "\nzone \"";
648 writeDom ();
649 write "\" {\n\ttype ";
650 write kind;
651 write ";\n\tfile \"";
652 write Config.Bind.zonePath_real;
653 write "/";
654 writeDom ();
655 write ".zone\";\n";
656 case kind of
657 "master" => (write "\tallow-transfer {\n";
658 app (fn ip => (write "\t\t";
659 write ip;
660 write ";\n")) slaveIps;
661 write "\t};\n")
662 | _ => (write "\tmasters { ";
663 write masterIp;
664 write "; };\n";
665 write "// Updated: ";
666 write (Time.toString (Time.now ()));
667 write "\n");
668 write "};\n";
669 close ()
670 end
671 in
672 case kind of
673 NoDns => masterNode := NONE
674 | UseDns dns =>
675 let
676 val masterIp =
677 case #master dns of
678 InternalMaster node => nodeIp node
679 | ExternalMaster ip => ip
680
681 val slaveIps = map nodeIp (#slaves dns)
682 in
683 app (saveSoa ("slave", #soa dns)) (#slaves dns);
684 app (saveNamed ("slave", #soa dns, masterIp, slaveIps)) (#slaves dns);
685 case #master dns of
686 InternalMaster node =>
687 (masterNode := SOME node;
688 saveSoa ("master", #soa dns) node;
689 saveNamed ("master", #soa dns, masterIp, slaveIps) node)
690 | _ => masterNode := NONE
691 end;
692 !befores dom
693 end,
694 fn () => !afters (!current))
695
696 val () = Env.registerPre (fn () => (seenDomains := [];
697 ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, ""],
698 fn cl => "Temp file cleanup failed: " ^ cl));
699 OS.FileSys.mkDir Config.tmpDir;
700 app (fn node => OS.FileSys.mkDir
701 (OS.Path.joinDirFile {dir = Config.tmpDir,
702 file = node}))
703 nodes;
704 app (fn node => OS.FileSys.mkDir
705 (OS.Path.joinDirFile {dir = Config.resultRoot,
706 file = node})
707 handle OS.SysErr _ => ())
708 nodes))
709
710 fun handleSite (site, files) =
711 let
712
713 in
714 print ("New configuration for node " ^ site ^ "\n");
715 if site = Config.dispatcherName then
716 Slave.handleChanges files
717 else let
718 val bio = OpenSSL.connect true (valOf (!ssl_context),
719 nodeIp site
720 ^ ":"
721 ^ Int.toString Config.slavePort)
722 in
723 app (fn file => Msg.send (bio, MsgFile file)) files;
724 Msg.send (bio, MsgDoFiles);
725 case Msg.recv bio of
726 NONE => print "Slave closed connection unexpectedly\n"
727 | SOME m =>
728 case m of
729 MsgOk => print ("Slave " ^ site ^ " finished\n")
730 | MsgError s => print ("Slave " ^ site
731 ^ " returned error: " ^
732 s ^ "\n")
733 | _ => print ("Slave " ^ site
734 ^ " returned unexpected command\n");
735 OpenSSL.close bio
736 end
737 end
738
739 val () = Env.registerPost (fn () =>
740 let
741 val prefixes = List.concat
742 (List.map (fn dom =>
743 let
744 val pieces = String.tokens (fn ch => ch = #".") dom
745 val path = String.concatWith "/" (rev pieces)
746 in
747 List.map (fn node =>
748 Config.resultRoot ^ "/" ^ node ^ "/" ^ path ^ "/")
749 nodes
750 end) (!seenDomains))
751
752 val diffs = findAllDiffs prefixes
753
754 val diffs = map (fn (site, dom, dir, Add' {src, dst}) =>
755 (Slave.shellF ([Config.cp, " ", src, " ", dst],
756 fn cl => "Copy failed: " ^ cl);
757 (site,
758 {action = Slave.Add,
759 domain = dom,
760 dir = dir,
761 file = dst}))
762 | (site, dom, dir, Delete' dst) =>
763 (OS.FileSys.remove dst
764 handle OS.SysErr _ =>
765 ErrorMsg.error NONE ("Delete failed for " ^ dst);
766 (site,
767 {action = Slave.Delete true,
768 domain = dom,
769 dir = dir,
770 file = dst}))
771 | (site, dom, dir, Modify' {src, dst}) =>
772 (Slave.shellF ([Config.cp, " ", src, " ", dst],
773 fn cl => "Copy failed: " ^ cl);
774 (site,
775 {action = Slave.Modify,
776 domain = dom,
777 dir = dir,
778 file = dst}))) diffs
779 in
780 if !ErrorMsg.anyErrors then
781 ()
782 else let
783 val changed = foldl (fn ((site, file), changed) =>
784 let
785 val ls = case SM.find (changed, site) of
786 NONE => []
787 | SOME ls => ls
788 in
789 SM.insert (changed, site, file :: ls)
790 end) SM.empty diffs
791 in
792 SM.appi handleSite changed
793 end;
794 ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, ""],
795 fn cl => "Temp file cleanup failed: " ^ cl))
796 end)
797
798 fun hasPriv priv = Acl.query {user = getUser (), class = "priv", value = "all"}
799 orelse Acl.query {user = getUser (), class = "priv", value = priv}
800
801 val _ = Env.type_one "dns_node"
802 Env.string
803 (fn node =>
804 List.exists (fn x => x = node) Config.dnsNodes_all
805 orelse (hasPriv "dns"
806 andalso List.exists (fn x => x = node) Config.dnsNodes_admin))
807
808 val _ = Env.type_one "mail_node"
809 Env.string
810 (fn node =>
811 List.exists (fn x => x = node) Config.mailNodes_all
812 orelse (hasPriv "mail"
813 andalso List.exists (fn x => x = node) Config.mailNodes_admin))
814
815 fun rmdom' delete resultRoot doms =
816 let
817 fun doNode (node, _) =
818 let
819 val dname = OS.Path.joinDirFile {dir = resultRoot,
820 file = node}
821
822 fun doDom (dom, actions) =
823 let
824 val domPath = String.concatWith "/" (rev (String.fields (fn ch => ch = #".") dom))
825 val dname = OS.Path.concat (dname, domPath)
826
827 fun visitDom (dom, dname, actions) =
828 let
829 val dir = Posix.FileSys.opendir dname
830
831 fun loop actions =
832 case Posix.FileSys.readdir dir of
833 NONE => actions
834 | SOME fname =>
835 let
836 val fnameFull = OS.Path.joinDirFile {dir = dname,
837 file = fname}
838 in
839 if Posix.FileSys.ST.isDir (Posix.FileSys.stat fnameFull) then
840 loop (visitDom (fname ^ "." ^ dom,
841 fnameFull,
842 actions))
843 else
844 loop ({action = Slave.Delete delete,
845 domain = dom,
846 dir = dname,
847 file = fnameFull} :: actions)
848 end
849 in
850 loop actions
851 before Posix.FileSys.closedir dir
852 end
853 handle OS.SysErr (s, _) =>
854 (print ("Warning: System error deleting domain " ^ dom ^ " on " ^ node ^ ": " ^ s ^ "\n");
855 actions)
856 in
857 visitDom (dom, dname, actions)
858 end
859
860 val actions = foldl doDom [] doms
861 in
862 handleSite (node, actions)
863 end
864 handle IO.Io _ => print ("Warning: IO error deleting domains on " ^ node ^ ".\n")
865
866 fun cleanupNode (node, _) =
867 let
868 fun doDom dom =
869 let
870 val domPath = String.concatWith "/" (rev (String.fields (fn ch => ch = #".") dom))
871 val dname = OS.Path.joinDirFile {dir = resultRoot,
872 file = node}
873 val dname = OS.Path.concat (dname, domPath)
874 in
875 if delete then
876 ignore (OS.Process.system (Config.rm ^ " -rf " ^ dname))
877 else
878 ()
879 end
880 in
881 app doDom doms
882 end
883 in
884 app doNode Config.nodeIps;
885 app cleanupNode Config.nodeIps
886 end
887
888 val rmdom = rmdom' true Config.resultRoot
889 val rmdom' = rmdom' false
890
891 fun homedirOf uname =
892 Posix.SysDB.Passwd.home (Posix.SysDB.getpwnam uname)
893
894 fun homedir () = homedirOf (getUser ())
895
896 type subject = {node : string, domain : string}
897
898 val describers : (subject -> string) list ref = ref []
899
900 fun registerDescriber f = describers := f :: !describers
901
902 fun describeOne arg = String.concat (map (fn f => f arg) (rev (!describers)))
903
904 val line = "--------------------------------------------------------------\n"
905 val dline = "==============================================================\n"
906
907 fun describe dom =
908 String.concat (List.mapPartial
909 (fn node =>
910 case describeOne {node = node, domain = dom} of
911 "" => NONE
912 | s =>
913 SOME (String.concat [dline, "Node ", node, "\n", dline, "\n", s]))
914 nodes)
915
916 datatype description =
917 Filename of { filename : string, heading : string, showEmpty : bool }
918 | Extension of { extension : string, heading : string -> string }
919
920 fun considerAll ds {node, domain} =
921 let
922 val ds = map (fn d => (d, ref [])) ds
923
924 val path = Config.resultRoot
925 val jdf = OS.Path.joinDirFile
926 val path = jdf {dir = path, file = node}
927 val path = foldr (fn (more, path) => jdf {dir = path, file = more})
928 path (String.tokens (fn ch => ch = #".") domain)
929 in
930 if Posix.FileSys.access (path, []) then
931 let
932 val dir = Posix.FileSys.opendir path
933
934 fun loop () =
935 case Posix.FileSys.readdir dir of
936 NONE => ()
937 | SOME fname =>
938 (app (fn (d, entries) =>
939 let
940 fun readFile showEmpty entries' =
941 let
942 val fname = OS.Path.joinDirFile {dir = path,
943 file = fname}
944
945 val inf = TextIO.openIn fname
946
947 fun loop (seenOne, entries') =
948 case TextIO.inputLine inf of
949 NONE => if seenOne orelse showEmpty then
950 "\n" :: entries'
951 else
952 !entries
953 | SOME line => loop (true, line :: entries')
954 in
955 loop (false, entries')
956 before TextIO.closeIn inf
957 end
958 in
959 case d of
960 Filename {filename, heading, showEmpty} =>
961 if fname = filename then
962 entries := readFile showEmpty ("\n" :: line :: "\n" :: heading :: line :: !entries)
963 else
964 ()
965 | Extension {extension, heading} =>
966 let
967 val {base, ext} = OS.Path.splitBaseExt fname
968 in
969 case ext of
970 NONE => ()
971 | SOME extension' =>
972 if extension' = extension then
973 entries := readFile true ("\n" :: line :: "\n" :: heading base :: line :: !entries)
974 else
975 ()
976 end
977 end) ds;
978 loop ())
979 in
980 loop ();
981 Posix.FileSys.closedir dir;
982 String.concat (List.concat (map (fn (_, entries) => rev (!entries)) ds))
983 end
984 else
985 ""
986 end
987
988 val () = registerDescriber (considerAll [Filename {filename = "soa.conf",
989 heading = "DNS SOA:",
990 showEmpty = false}])
991
992 val () = Env.registerAction ("domainHost",
993 fn (env, [(EString host, _)]) =>
994 SM.insert (env, "Hostname",
995 (EString (host ^ "." ^ currentDomain ()), dl))
996 | (_, args) => Env.badArgs ("domainHost", args))
997
998 val ouc = ref (fn () => ())
999
1000 fun registerOnUsersChange f =
1001 let
1002 val f' = !ouc
1003 in
1004 ouc := (fn () => (f' (); f ()))
1005 end
1006
1007 fun onUsersChange () = !ouc ()
1008
1009 end