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