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