'-fake' flag added to 'domtool'
[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
AC
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)
998ed174 137fun checkPath paths path =
04502362
AC
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 ()))
998ed174
AC
143val yourPath = checkPath your_paths
144val readablePath = checkPath readable_paths
04502362 145fun yourIp s = !fakePrivs orelse SS.member (your_ips (), s)
12adf55a 146
edd38024 147fun yourDomainHost s =
04502362
AC
148 !fakePrivs
149 orelse yourDomain s
c98b57cf 150 orelse let
edd38024
AC
151 val (pref, suf) = Substring.splitl (fn ch => ch <> #".") (Substring.full s)
152 in
edd38024
AC
153 Substring.size suf > 0
154 andalso validHost (Substring.string pref)
155 andalso yourDomain (Substring.string
c98b57cf 156 (Substring.slice (suf, 1, NONE)))
edd38024
AC
157 end
158
93c2f623
AC
159val yourDomain = yourDomainHost
160
2aeb9eec
AC
161fun validUser s = size s > 0 andalso size s < 20
162 andalso CharVector.all Char.isAlphaNum s
163
2e96b9d4
AC
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
2aeb9eec
AC
172val validGroup = validUser
173
f8dfbbcc
AC
174val _ = Env.type_one "no_spaces"
175 Env.string
ca6ffb3f
AC
176 (CharVector.all (fn ch => Char.isPrint ch andalso not (Char.isSpace ch)
177 andalso ch <> #"\"" andalso ch <> #"'"))
d5754b53
AC
178val _ = Env.type_one "no_newlines"
179 Env.string
ca6ffb3f 180 (CharVector.all (fn ch => Char.isPrint ch andalso ch <> #"\n" andalso ch <> #"\r"
5e3ad5d2 181 andalso ch <> #"\""))
f8dfbbcc 182
6ae327f8
AC
183val _ = Env.type_one "ip"
184 Env.string
185 validIp
186
090692f7
AC
187val _ = Env.type_one "ipv6"
188 Env.string
189 validIpv6
190
629a34f6
AC
191val _ = Env.type_one "host"
192 Env.string
193 validHost
194
195val _ = Env.type_one "domain"
196 Env.string
197 validDomain
198
12adf55a
AC
199val _ = Env.type_one "your_domain"
200 Env.string
201 yourDomain
202
edd38024
AC
203val _ = Env.type_one "your_domain_host"
204 Env.string
205 yourDomainHost
206
2aeb9eec
AC
207val _ = Env.type_one "user"
208 Env.string
209 validUser
210
211val _ = Env.type_one "group"
212 Env.string
213 validGroup
214
8a7c40fa
AC
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
998ed174
AC
227val _ = Env.type_one "readable_path"
228 Env.string
229 readablePath
230
26c7d224
AC
231val _ = Env.type_one "your_ip"
232 Env.string
233 yourIp
234
e0b0abd2
AC
235val _ = Env.type_one "node"
236 Env.string
237 validNode
238
2e87719c
AC
239val _ = Env.registerFunction ("your_ip_to_ip",
240 fn [e] => SOME e
241 | _ => NONE)
242
bbdf617f
AC
243val _ = Env.registerFunction ("dns_node_to_node",
244 fn [e] => SOME e
245 | _ => NONE)
246
247val _ = Env.registerFunction ("mail_node_to_node",
be1bea4c
AC
248 fn [e] => SOME e
249 | _ => NONE)
b0963032
AC
250
251
a3698041
AC
252open Ast
253
6ae327f8
AC
254val dl = ErrorMsg.dummyLoc
255
b0963032
AC
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
6ae327f8
AC
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
e0b0abd2 277val masterD = (EApp ((EVar "internalMaster", dl),
8b84db5b 278 (EString Config.masterNode, dl)),
e0b0abd2
AC
279 dl)
280
8b84db5b
AC
281val slavesD = (EList (map (fn s => (EString s, dl)) Config.slaveNodes), dl)
282
e0b80e65
AC
283val _ = Defaults.registerDefault ("Aliases",
284 (TList (TBase "your_domain", dl), dl),
285 (fn () => (EList [], dl)))
286
6bb366c5
AC
287val _ = Defaults.registerDefault ("Mailbox",
288 (TBase "email", dl),
289 (fn () => (EString (getUser ()), dl)))
290
aa56e112
AC
291val _ = Defaults.registerDefault ("DNS",
292 (TBase "dnsKind", dl),
293 (fn () => multiApp ((EVar "useDns", dl),
294 dl,
8b84db5b 295 [soaD, masterD, slavesD])))
6ae327f8 296
aa56e112
AC
297val _ = Defaults.registerDefault ("TTL",
298 (TBase "int", dl),
299 (fn () => (EInt Config.Bind.defaultTTL, dl)))
6ae327f8
AC
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
e0b0abd2
AC
332datatype master =
333 ExternalMaster of string
334 | InternalMaster of string
335
cf879b4f
AC
336val ip = Env.string
337
338val _ = Env.registerFunction ("ip_of_node",
339 fn [(EString node, _)] => SOME (EString (nodeIp node), dl)
340 | _ => NONE)
97665758
AC
341
342val master = fn (EApp ((EVar "externalMaster", _), e), _) => Option.map ExternalMaster (ip e)
8b84db5b 343 | (EApp ((EVar "internalMaster", _), e), _) => Option.map InternalMaster (Env.string e)
e0b0abd2
AC
344 | _ => NONE
345
6ae327f8 346datatype dnsKind =
e0b0abd2
AC
347 UseDns of {soa : soa,
348 master : master,
349 slaves : string list}
6ae327f8
AC
350 | NoDns
351
e0b0abd2
AC
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)
325285ab 362 | (EVar "noDns", _) => SOME NoDns
6ae327f8
AC
363 | _ => NONE
364
a3698041
AC
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
71420f8b
AC
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
a3698041 403val current = ref ""
e0b0abd2 404val currentPath = ref (fn (_ : string) => "")
e0b80e65 405val currentPathAli = ref (fn (_ : string, _ : string) => "")
dac62e84 406
d612d62c
AC
407val scratch = ref ""
408
dac62e84
AC
409fun currentDomain () = !current
410
e0b80e65
AC
411val currentsAli = ref ([] : string list)
412
413fun currentAliasDomains () = !currentsAli
414fun currentDomains () = currentDomain () :: currentAliasDomains ()
415
e0b0abd2
AC
416fun domainFile {node, name} = ((*print ("Opening " ^ !currentPath node ^ name ^ "\n");*)
417 TextIO.openOut (!currentPath node ^ name))
dac62e84 418
e0b80e65
AC
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
dac62e84
AC
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
d612d62c 440
e0b0abd2
AC
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
2ed6d0e5 465 app doNode nodes;
dac62e84
AC
466 elems
467 end) [] toks
468 in
e0b0abd2 469 fn (root, site) => String.concatWith "/" (root :: site :: rev ("" :: elems))
d612d62c
AC
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
aaf70d45 477fun findDiffs (prefixes, site, dom, acts) =
d612d62c 478 let
e0b0abd2
AC
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")*)
d612d62c
AC
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
8df2e702 501 if Slave.shell [Config.diff, " ", real, " ", tmp] then
d612d62c
AC
502 loopReal acts
503 else
e0b0abd2 504 loopReal ((site, dom, realPath, Modify' {src = tmp, dst = real}) :: acts)
4f9c5b51 505 else if List.exists (fn prefix => String.isPrefix prefix real) prefixes then
e0b0abd2 506 loopReal ((site, dom, realPath, Delete' real) :: acts)
aaf70d45
AC
507 else
508 loopReal acts
d612d62c
AC
509 end
510
e0b0abd2 511 val acts = loopReal acts
d612d62c 512
8df2e702 513 val dir = Posix.FileSys.opendir tmpPath
d612d62c
AC
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
e0b0abd2 531 loopTmp ((site, dom, realPath, Add' {src = tmp, dst = real}) :: acts)
d612d62c
AC
532 end
533
534 val acts = loopTmp acts
535 in
536 acts
dac62e84 537 end
a3698041 538
aaf70d45 539fun findAllDiffs prefixes =
e0b0abd2
AC
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',
aaf70d45 571 findDiffs (prefixes, site, dom, diffs))
e0b0abd2
AC
572 end
573 else
574 diffs)
575 end
576 in
577 loop diffs
578 before Posix.FileSys.closedir dir
579 end
580 in
36e42cb8
AC
581 exploreSites (explore (OS.Path.joinDirFile {dir = Config.tmpDir,
582 file = site}, diffs))
e0b0abd2
AC
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
aaf70d45
AC
592val seenDomains : string list ref = ref []
593
6ae327f8
AC
594val _ = Env.containerV_one "domain"
595 ("domain", Env.string)
596 (fn (evs, dom) =>
597 let
aaf70d45
AC
598 val () = seenDomains := dom :: !seenDomains
599
6ae327f8
AC
600 val kind = Env.env dnsKind (evs, "DNS")
601 val ttl = Env.env Env.int (evs, "TTL")
e0b80e65 602 val aliases = Env.env (Env.list Env.string) (evs, "Aliases")
6ae327f8 603
e0b0abd2 604 val path = getPath dom
6ae327f8
AC
605
606 val () = (current := dom;
e0b80e65
AC
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)))
6ae327f8 610
e0b0abd2 611 fun saveSoa (kind, soa : soa) node =
e2359100 612 let
e0b80e65 613 val {write, writeDom, close} = domainsFile {node = node, name = "soa"}
e2359100 614 in
e0b80e65
AC
615 write kind;
616 write "\n";
617 write (Int.toString ttl);
618 write "\n";
619 write (#ns soa);
620 write "\n";
e2359100
AC
621 case #serial soa of
622 NONE => ()
e0b80e65
AC
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 ()
e2359100 634 end
6ae327f8 635
a431ca34 636 fun saveNamed (kind, soa : soa, masterIp, slaveIps) node =
b341fd6d
AC
637 if dom = "localhost" then
638 ()
639 else let
e0b80e65 640 val {write, writeDom, close} = domainsFile {node = node, name = "named.conf"}
b341fd6d 641 in
e0b80e65
AC
642 write "\nzone \"";
643 writeDom ();
a431ca34 644 write "\" {\n\ttype ";
e0b80e65
AC
645 write kind;
646 write ";\n\tfile \"";
647 write Config.Bind.zonePath_real;
648 write "/";
649 writeDom ();
650 write ".zone\";\n";
b341fd6d 651 case kind of
a431ca34
AC
652 "master" => (write "\tallow-transfer {\n";
653 app (fn ip => (write "\t\t";
654 write ip;
655 write ";\n")) slaveIps;
656 write "\t};\n")
e0b80e65
AC
657 | _ => (write "\tmasters { ";
658 write masterIp;
036cfc59
AC
659 write "; };\n";
660 write "// Updated: ";
661 write (Time.toString (Time.now ()));
662 write "\n");
e0b80e65
AC
663 write "};\n";
664 close ()
b341fd6d 665 end
6ae327f8
AC
666 in
667 case kind of
e0b0abd2
AC
668 NoDns => masterNode := NONE
669 | UseDns dns =>
2ed6d0e5
AC
670 let
671 val masterIp =
672 case #master dns of
a431ca34 673 InternalMaster node => nodeIp node
2ed6d0e5 674 | ExternalMaster ip => ip
a431ca34
AC
675
676 val slaveIps = map nodeIp (#slaves dns)
2ed6d0e5
AC
677 in
678 app (saveSoa ("slave", #soa dns)) (#slaves dns);
a431ca34 679 app (saveNamed ("slave", #soa dns, masterIp, slaveIps)) (#slaves dns);
2ed6d0e5
AC
680 case #master dns of
681 InternalMaster node =>
682 (masterNode := SOME node;
683 saveSoa ("master", #soa dns) node;
a431ca34 684 saveNamed ("master", #soa dns, masterIp, slaveIps) node)
b25161c7
AC
685 | _ => masterNode := NONE
686 end;
687 !befores dom
6ae327f8 688 end,
e0b0abd2
AC
689 fn () => !afters (!current))
690
aaf70d45
AC
691val () = Env.registerPre (fn () => (seenDomains := [];
692 ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, ""],
e0b0abd2
AC
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}))
2ed6d0e5 698 nodes;
e0b0abd2
AC
699 app (fn node => OS.FileSys.mkDir
700 (OS.Path.joinDirFile {dir = Config.resultRoot,
701 file = node})
702 handle OS.SysErr _ => ())
2ed6d0e5 703 nodes))
e0b0abd2 704
c189cbe9
AC
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
8be753d9
AC
713 val bio = OpenSSL.connect true (valOf (!ssl_context),
714 nodeIp site
715 ^ ":"
716 ^ Int.toString Config.slavePort)
c189cbe9
AC
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
e0b0abd2
AC
734val () = Env.registerPost (fn () =>
735 let
4f9c5b51
AC
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))
aaf70d45
AC
746
747 val diffs = findAllDiffs prefixes
6ae327f8 748
e0b0abd2
AC
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,
6ae327f8
AC
753 {action = Slave.Add,
754 domain = dom,
755 dir = dir,
e0b0abd2
AC
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,
1638d5a2 762 {action = Slave.Delete true,
6ae327f8
AC
763 domain = dom,
764 dir = dir,
e0b0abd2
AC
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,
6ae327f8
AC
770 {action = Slave.Modify,
771 domain = dom,
772 dir = dir,
e0b0abd2
AC
773 file = dst}))) diffs
774 in
775 if !ErrorMsg.anyErrors then
776 ()
36e42cb8
AC
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
36e42cb8
AC
786 in
787 SM.appi handleSite changed
788 end;
e0b0abd2 789 ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, ""],
559e89e9 790 fn cl => "Temp file cleanup failed: " ^ cl))
e0b0abd2 791 end)
6ae327f8 792
be1bea4c
AC
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))
60695e99 802
bbdf617f
AC
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
1638d5a2 810fun rmdom' delete resultRoot doms =
c189cbe9 811 let
c189cbe9
AC
812 fun doNode (node, _) =
813 let
1638d5a2 814 val dname = OS.Path.joinDirFile {dir = resultRoot,
c189cbe9 815 file = node}
c189cbe9 816
e69e60cc 817 fun doDom (dom, actions) =
93c2f623 818 let
e69e60cc
AC
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))
1638d5a2 838 else
1638d5a2
AC
839 loop ({action = Slave.Delete delete,
840 domain = dom,
841 dir = dname,
b200e996 842 file = fnameFull} :: actions)
e69e60cc
AC
843 end
844 in
845 loop actions
846 before Posix.FileSys.closedir dir
847 end
1638d5a2
AC
848 handle OS.SysErr (s, _) =>
849 (print ("Warning: System error deleting domain " ^ dom ^ " on " ^ node ^ ": " ^ s ^ "\n");
e69e60cc 850 actions)
93c2f623 851 in
e69e60cc 852 visitDom (dom, dname, actions)
93c2f623
AC
853 end
854
e69e60cc 855 val actions = foldl doDom [] doms
c189cbe9 856 in
c189cbe9
AC
857 handleSite (node, actions)
858 end
e69e60cc 859 handle IO.Io _ => print ("Warning: IO error deleting domains on " ^ node ^ ".\n")
c189cbe9
AC
860
861 fun cleanupNode (node, _) =
862 let
e69e60cc
AC
863 fun doDom dom =
864 let
865 val domPath = String.concatWith "/" (rev (String.fields (fn ch => ch = #".") dom))
1638d5a2 866 val dname = OS.Path.joinDirFile {dir = resultRoot,
e69e60cc
AC
867 file = node}
868 val dname = OS.Path.concat (dname, domPath)
869 in
1638d5a2
AC
870 if delete then
871 ignore (OS.Process.system (Config.rm ^ " -rf " ^ dname))
872 else
873 ()
e69e60cc 874 end
c189cbe9 875 in
e69e60cc 876 app doDom doms
c189cbe9
AC
877 end
878 in
879 app doNode Config.nodeIps;
880 app cleanupNode Config.nodeIps
881 end
882
1638d5a2
AC
883val rmdom = rmdom' true Config.resultRoot
884val rmdom' = rmdom' false
885
0da1c677
AC
886fun homedirOf uname =
887 Posix.SysDB.Passwd.home (Posix.SysDB.getpwnam uname)
888
889fun homedir () = homedirOf (getUser ())
890
314ce7bd
AC
891type subject = {node : string, domain : string}
892
893val describers : (subject -> string) list ref = ref []
894
895fun registerDescriber f = describers := f :: !describers
896
41c58daf 897fun describeOne arg = String.concat (map (fn f => f arg) (rev (!describers)))
314ce7bd 898
d300166d
AC
899val line = "--------------------------------------------------------------\n"
900val dline = "==============================================================\n"
314ce7bd
AC
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 =
41c58daf 912 Filename of { filename : string, heading : string, showEmpty : bool }
314ce7bd
AC
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 =>
41c58daf
AC
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
d936cf4d 957 entries := readFile showEmpty ("\n" :: line :: "\n" :: heading :: line :: !entries)
41c58daf
AC
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
d936cf4d 968 entries := readFile true ("\n" :: line :: "\n" :: heading base :: line :: !entries)
41c58daf
AC
969 else
970 ()
971 end
972 end) ds;
973 loop ())
314ce7bd
AC
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",
d936cf4d 984 heading = "DNS SOA:",
41c58daf 985 showEmpty = false}])
314ce7bd 986
e9f528ab
AC
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
a3698041 993end