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