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