HCoop / hcoop / domtool2.git / blame_incremental
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (non-incremental) | history | HEAD
merge toplevel-dynamic-environment
[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 (saveSoa ("slave", #soa dns)) (#slaves dns);
661 app (saveNamed ("slave", #soa dns, masterIp, slaveIps)) (#slaves dns);
662 case #master dns of
663 InternalMaster node =>
664 (masterNode := SOME node;
665 saveSoa ("master", #soa dns) node;
666 saveNamed ("master", #soa dns, masterIp, slaveIps) node)
667 | _ => masterNode := NONE
668 end;
669 !befores dom
670 end,
671 fn () => !afters (!current))
672
673val () = Env.registerPre (fn () => (seenDomains := [];
674 ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, ""],
675 fn cl => "Temp file cleanup failed: " ^ cl));
676 OS.FileSys.mkDir Config.tmpDir;
677 app (fn node => OS.FileSys.mkDir
678 (OS.Path.joinDirFile {dir = Config.tmpDir,
679 file = node}))
680 nodes;
681 app (fn node => OS.FileSys.mkDir
682 (OS.Path.joinDirFile {dir = Config.resultRoot,
683 file = node})
684 handle OS.SysErr _ => ())
685 nodes))
686
687fun handleSite (site, files) =
688 let
689
690 in
691 print ("New configuration for node " ^ site ^ "\n");
692 if site = Config.dispatcherName then
693 Slave.handleChanges files
694 else let
695 val bio = OpenSSL.connect true (valOf (!ssl_context),
696 nodeIp site
697 ^ ":"
698 ^ Int.toString Config.slavePort)
699 in
700 app (fn file => Msg.send (bio, MsgFile file)) files;
701 Msg.send (bio, MsgDoFiles);
702 case Msg.recv bio of
703 NONE => print "Slave closed connection unexpectedly\n"
704 | SOME m =>
705 case m of
706 MsgOk => print ("Slave " ^ site ^ " finished\n")
707 | MsgError s => print ("Slave " ^ site
708 ^ " returned error: " ^
709 s ^ "\n")
710 | _ => print ("Slave " ^ site
711 ^ " returned unexpected command\n");
712 OpenSSL.close bio
713 end
714 end
715
716val () = Env.registerPost (fn () =>
717 let
718 val prefixes = List.concat
719 (List.map (fn dom =>
720 let
721 val pieces = String.tokens (fn ch => ch = #".") dom
722 val path = String.concatWith "/" (rev pieces)
723 in
724 List.map (fn node =>
725 Config.resultRoot ^ "/" ^ node ^ "/" ^ path ^ "/")
726 nodes
727 end) (!seenDomains))
728
729 val diffs = findAllDiffs prefixes
730
731 val diffs = map (fn (site, dom, dir, Add' {src, dst}) =>
732 (Slave.shellF ([Config.cp, " ", src, " ", dst],
733 fn cl => "Copy failed: " ^ cl);
734 (site,
735 {action = Slave.Add,
736 domain = dom,
737 dir = dir,
738 file = dst}))
739 | (site, dom, dir, Delete' dst) =>
740 (OS.FileSys.remove dst
741 handle OS.SysErr _ =>
742 ErrorMsg.error NONE ("Delete failed for " ^ dst);
743 (site,
744 {action = Slave.Delete true,
745 domain = dom,
746 dir = dir,
747 file = dst}))
748 | (site, dom, dir, Modify' {src, dst}) =>
749 (Slave.shellF ([Config.cp, " ", src, " ", dst],
750 fn cl => "Copy failed: " ^ cl);
751 (site,
752 {action = Slave.Modify,
753 domain = dom,
754 dir = dir,
755 file = dst}))) diffs
756 in
757 if !ErrorMsg.anyErrors then
758 ()
759 else let
760 val changed = foldl (fn ((site, file), changed) =>
761 let
762 val ls = case SM.find (changed, site) of
763 NONE => []
764 | SOME ls => ls
765 in
766 SM.insert (changed, site, file :: ls)
767 end) SM.empty diffs
768 in
769 SM.appi handleSite changed
770 end;
771 ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, ""],
772 fn cl => "Temp file cleanup failed: " ^ cl))
773 end)
774
775fun hasPriv priv = Acl.query {user = getUser (), class = "priv", value = "all"}
776 orelse Acl.query {user = getUser (), class = "priv", value = priv}
777
778val _ = Env.type_one "dns_node"
779 Env.string
780 (fn node =>
781 List.exists (fn x => x = node) Config.dnsNodes_all
782 orelse (hasPriv "dns"
783 andalso List.exists (fn x => x = node) Config.dnsNodes_admin))
784
785val _ = Env.type_one "mail_node"
786 Env.string
787 (fn node =>
788 List.exists (fn x => x = node) Config.mailNodes_all
789 orelse (hasPriv "mail"
790 andalso List.exists (fn x => x = node) Config.mailNodes_admin))
791
792fun rmdom' delete resultRoot doms =
793 let
794 fun doNode (node, _) =
795 let
796 val dname = OS.Path.joinDirFile {dir = resultRoot,
797 file = node}
798
799 fun doDom (dom, actions) =
800 let
801 val domPath = String.concatWith "/" (rev (String.fields (fn ch => ch = #".") dom))
802 val dname = OS.Path.concat (dname, domPath)
803
804 fun visitDom (dom, dname, actions) =
805 let
806 val dir = Posix.FileSys.opendir dname
807
808 fun loop actions =
809 case Posix.FileSys.readdir dir of
810 NONE => actions
811 | SOME fname =>
812 let
813 val fnameFull = OS.Path.joinDirFile {dir = dname,
814 file = fname}
815 in
816 if Posix.FileSys.ST.isDir (Posix.FileSys.stat fnameFull) then
817 loop (visitDom (fname ^ "." ^ dom,
818 fnameFull,
819 actions))
820 else
821 loop ({action = Slave.Delete delete,
822 domain = dom,
823 dir = dname,
824 file = fnameFull} :: actions)
825 end
826 in
827 loop actions
828 before Posix.FileSys.closedir dir
829 end
830 handle OS.SysErr (s, _) =>
831 (print ("Warning: System error deleting domain " ^ dom ^ " on " ^ node ^ ": " ^ s ^ "\n");
832 actions)
833 in
834 visitDom (dom, dname, actions)
835 end
836
837 val actions = foldl doDom [] doms
838 in
839 handleSite (node, actions)
840 end
841 handle IO.Io _ => print ("Warning: IO error deleting domains on " ^ node ^ ".\n")
842
843 fun cleanupNode (node, _) =
844 let
845 fun doDom dom =
846 let
847 val domPath = String.concatWith "/" (rev (String.fields (fn ch => ch = #".") dom))
848 val dname = OS.Path.joinDirFile {dir = resultRoot,
849 file = node}
850 val dname = OS.Path.concat (dname, domPath)
851 in
852 if delete then
853 ignore (OS.Process.system (Config.rm ^ " -rf " ^ dname))
854 else
855 ()
856 end
857 in
858 app doDom doms
859 end
860 in
861 app doNode Config.nodeIps;
862 app cleanupNode Config.nodeIps
863 end
864
865val rmdom = rmdom' true Config.resultRoot
866val rmdom' = rmdom' false
867
868fun homedirOf uname =
869 Posix.SysDB.Passwd.home (Posix.SysDB.getpwnam uname)
870
871fun homedir () = homedirOf (getUser ())
872 handle e => if !fakePrivs then "/tmp" else raise e
873
874type subject = {node : string, domain : string}
875
876val describers : (subject -> string) list ref = ref []
877
878fun registerDescriber f = describers := f :: !describers
879
880fun describeOne arg = String.concat (map (fn f => f arg) (rev (!describers)))
881
882val line = "--------------------------------------------------------------\n"
883val dline = "==============================================================\n"
884
885fun describe dom =
886 String.concat (List.mapPartial
887 (fn node =>
888 case describeOne {node = node, domain = dom} of
889 "" => NONE
890 | s =>
891 SOME (String.concat [dline, "Node ", node, "\n", dline, "\n", s]))
892 nodes)
893
894datatype description =
895 Filename of { filename : string, heading : string, showEmpty : bool }
896 | Extension of { extension : string, heading : string -> string }
897
898fun considerAll ds {node, domain} =
899 let
900 val ds = map (fn d => (d, ref [])) ds
901
902 val path = Config.resultRoot
903 val jdf = OS.Path.joinDirFile
904 val path = jdf {dir = path, file = node}
905 val path = foldr (fn (more, path) => jdf {dir = path, file = more})
906 path (String.tokens (fn ch => ch = #".") domain)
907 in
908 if Posix.FileSys.access (path, []) then
909 let
910 val dir = Posix.FileSys.opendir path
911
912 fun loop () =
913 case Posix.FileSys.readdir dir of
914 NONE => ()
915 | SOME fname =>
916 (app (fn (d, entries) =>
917 let
918 fun readFile showEmpty entries' =
919 let
920 val fname = OS.Path.joinDirFile {dir = path,
921 file = fname}
922
923 val inf = TextIO.openIn fname
924
925 fun loop (seenOne, entries') =
926 case TextIO.inputLine inf of
927 NONE => if seenOne orelse showEmpty then
928 "\n" :: entries'
929 else
930 !entries
931 | SOME line => loop (true, line :: entries')
932 in
933 loop (false, entries')
934 before TextIO.closeIn inf
935 end
936 in
937 case d of
938 Filename {filename, heading, showEmpty} =>
939 if fname = filename then
940 entries := readFile showEmpty ("\n" :: line :: "\n" :: heading :: line :: !entries)
941 else
942 ()
943 | Extension {extension, heading} =>
944 let
945 val {base, ext} = OS.Path.splitBaseExt fname
946 in
947 case ext of
948 NONE => ()
949 | SOME extension' =>
950 if extension' = extension then
951 entries := readFile true ("\n" :: line :: "\n" :: heading base :: line :: !entries)
952 else
953 ()
954 end
955 end) ds;
956 loop ())
957 in
958 loop ();
959 Posix.FileSys.closedir dir;
960 String.concat (List.concat (map (fn (_, entries) => rev (!entries)) ds))
961 end
962 else
963 ""
964 end
965
966val () = registerDescriber (considerAll [Filename {filename = "soa.conf",
967 heading = "DNS SOA:",
968 showEmpty = false}])
969
970val () = Env.registerAction ("domainHost",
971 fn (env, [(EString host, _)]) =>
972 SM.insert (env, "Hostname",
973 (EString (host ^ "." ^ currentDomain ()), dl))
974 | (_, args) => Env.badArgs ("domainHost", args))
975
976val ouc = ref (fn () => ())
977
978fun registerOnUsersChange f =
979 let
980 val f' = !ouc
981 in
982 ouc := (fn () => (f' (); f ()))
983 end
984
985fun onUsersChange () = !ouc ()
986
987end
Unnamed repository; edit this file to name it for gitweb.