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