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