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