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