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