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