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