Limiting acceptable mail nodes
[hcoop/domtool2.git] / src / domain.sml
CommitLineData
a3698041
AC
1(* HCoop Domtool (http://hcoop.sourceforge.net/)
2 * Copyright (c) 2006, 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.
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
AC
37fun getUser () = !usr
38
39val your_doms = ref SS.empty
40fun your_domains () = !your_doms
41
8a7c40fa
AC
42val your_usrs = ref SS.empty
43fun your_users () = !your_usrs
44
45val your_grps = ref SS.empty
46fun your_groups () = !your_grps
47
48val your_pths = ref SS.empty
49fun your_paths () = !your_pths
50
aa56e112 51fun setUser user =
a088cea6 52 (usr := user;
aa56e112
AC
53 your_doms := Acl.class {user = getUser (),
54 class = "domain"};
55 your_usrs := Acl.class {user = getUser (),
56 class = "user"};
57 your_grps := Acl.class {user = getUser (),
58 class = "group"};
59 your_pths := Acl.class {user = getUser (),
60 class = "path"})
61
6ae327f8
AC
62fun validIp s =
63 case map Int.fromString (String.fields (fn ch => ch = #".") s) of
64 [SOME n1, SOME n2, SOME n3, SOME n4] =>
65 n1 >= 0 andalso n1 < 256 andalso n2 >= 0 andalso n2 < 256 andalso n3 >= 0 andalso n3 < 256 andalso n4 >= 0 andalso n4 < 256
66 | _ => false
67
629a34f6
AC
68fun isIdent ch = Char.isLower ch orelse Char.isDigit ch
69
70fun validHost s =
71 size s > 0 andalso size s < 20
72 andalso CharVector.all (fn ch => isIdent ch orelse ch = #"-") s
73
74fun validDomain s =
75 size s > 0 andalso size s < 100
76 andalso List.all validHost (String.fields (fn ch => ch = #".") s)
77
2ed6d0e5 78fun validNode s = List.exists (fn s' => s = s') nodes
e0b0abd2 79
12adf55a 80fun yourDomain s = SS.member (your_domains (), s)
8a7c40fa
AC
81fun yourUser s = SS.member (your_users (), s)
82fun yourGroup s = SS.member (your_groups (), s)
83fun yourPath path =
84 List.all (fn s => s <> "..") (String.fields (fn ch => ch = #"/") path)
85 andalso CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"." orelse ch = #"/"
86 orelse ch = #"-" orelse ch = #"_") path
87 andalso SS.exists (fn s' => path = s' orelse String.isPrefix (s' ^ "/") path) (your_paths ())
12adf55a 88
edd38024 89fun yourDomainHost s =
c98b57cf
AC
90 yourDomain s
91 orelse let
edd38024
AC
92 val (pref, suf) = Substring.splitl (fn ch => ch <> #".") (Substring.full s)
93 in
edd38024
AC
94 Substring.size suf > 0
95 andalso validHost (Substring.string pref)
96 andalso yourDomain (Substring.string
c98b57cf 97 (Substring.slice (suf, 1, NONE)))
edd38024
AC
98 end
99
2aeb9eec
AC
100fun validUser s = size s > 0 andalso size s < 20
101 andalso CharVector.all Char.isAlphaNum s
102
103val validGroup = validUser
104
f8dfbbcc
AC
105val _ = Env.type_one "no_spaces"
106 Env.string
107 (CharVector.all (fn ch => not (Char.isSpace ch)))
d5754b53
AC
108val _ = Env.type_one "no_newlines"
109 Env.string
110 (CharVector.all (fn ch => ch <> #"\n" andalso ch <> #"\r"))
f8dfbbcc 111
6ae327f8
AC
112val _ = Env.type_one "ip"
113 Env.string
114 validIp
115
629a34f6
AC
116val _ = Env.type_one "host"
117 Env.string
118 validHost
119
120val _ = Env.type_one "domain"
121 Env.string
122 validDomain
123
12adf55a
AC
124val _ = Env.type_one "your_domain"
125 Env.string
126 yourDomain
127
edd38024
AC
128val _ = Env.type_one "your_domain_host"
129 Env.string
130 yourDomainHost
131
2aeb9eec
AC
132val _ = Env.type_one "user"
133 Env.string
134 validUser
135
136val _ = Env.type_one "group"
137 Env.string
138 validGroup
139
8a7c40fa
AC
140val _ = Env.type_one "your_user"
141 Env.string
142 yourUser
143
144val _ = Env.type_one "your_group"
145 Env.string
146 yourGroup
147
148val _ = Env.type_one "your_path"
149 Env.string
150 yourPath
151
e0b0abd2
AC
152val _ = Env.type_one "node"
153 Env.string
154 validNode
155
bbdf617f
AC
156val _ = Env.registerFunction ("dns_node_to_node",
157 fn [e] => SOME e
158 | _ => NONE)
159
160val _ = Env.registerFunction ("mail_node_to_node",
be1bea4c
AC
161 fn [e] => SOME e
162 | _ => NONE)
a3698041
AC
163open Ast
164
6ae327f8
AC
165val dl = ErrorMsg.dummyLoc
166
167val nsD = (EString Config.defaultNs, dl)
168val serialD = (EVar "serialAuto", dl)
169val refD = (EInt Config.defaultRefresh, dl)
170val retD = (EInt Config.defaultRetry, dl)
171val expD = (EInt Config.defaultExpiry, dl)
172val minD = (EInt Config.defaultMinimum, dl)
173
174val soaD = multiApp ((EVar "soa", dl),
175 dl,
176 [nsD, serialD, refD, retD, expD, minD])
177
e0b0abd2 178val masterD = (EApp ((EVar "internalMaster", dl),
8b84db5b 179 (EString Config.masterNode, dl)),
e0b0abd2
AC
180 dl)
181
8b84db5b
AC
182val slavesD = (EList (map (fn s => (EString s, dl)) Config.slaveNodes), dl)
183
6bb366c5
AC
184val _ = Defaults.registerDefault ("Mailbox",
185 (TBase "email", dl),
186 (fn () => (EString (getUser ()), dl)))
187
aa56e112
AC
188val _ = Defaults.registerDefault ("DNS",
189 (TBase "dnsKind", dl),
190 (fn () => multiApp ((EVar "useDns", dl),
191 dl,
8b84db5b 192 [soaD, masterD, slavesD])))
6ae327f8 193
aa56e112
AC
194val _ = Defaults.registerDefault ("TTL",
195 (TBase "int", dl),
196 (fn () => (EInt Config.Bind.defaultTTL, dl)))
6ae327f8
AC
197
198type soa = {ns : string,
199 serial : int option,
200 ref : int,
201 ret : int,
202 exp : int,
203 min : int}
204
205val serial = fn (EVar "serialAuto", _) => SOME NONE
206 | (EApp ((EVar "serialConst", _), n), _) => Option.map SOME (Env.int n)
207 | _ => NONE
208
209val soa = fn (EApp ((EApp ((EApp ((EApp ((EApp ((EApp
210 ((EVar "soa", _), ns), _),
211 sl), _),
212 rf), _),
213 ret), _),
214 exp), _),
215 min), _) =>
216 (case (Env.string ns, serial sl, Env.int rf,
217 Env.int ret, Env.int exp, Env.int min) of
218 (SOME ns, SOME sl, SOME rf,
219 SOME ret, SOME exp, SOME min) =>
220 SOME {ns = ns,
221 serial = sl,
222 ref = rf,
223 ret = ret,
224 exp = exp,
225 min = min}
226 | _ => NONE)
227 | _ => NONE
228
e0b0abd2
AC
229datatype master =
230 ExternalMaster of string
231 | InternalMaster of string
232
cf879b4f
AC
233val ip = Env.string
234
235val _ = Env.registerFunction ("ip_of_node",
236 fn [(EString node, _)] => SOME (EString (nodeIp node), dl)
237 | _ => NONE)
97665758
AC
238
239val master = fn (EApp ((EVar "externalMaster", _), e), _) => Option.map ExternalMaster (ip e)
8b84db5b 240 | (EApp ((EVar "internalMaster", _), e), _) => Option.map InternalMaster (Env.string e)
e0b0abd2
AC
241 | _ => NONE
242
6ae327f8 243datatype dnsKind =
e0b0abd2
AC
244 UseDns of {soa : soa,
245 master : master,
246 slaves : string list}
6ae327f8
AC
247 | NoDns
248
e0b0abd2
AC
249val dnsKind = fn (EApp ((EApp ((EApp
250 ((EVar "useDns", _), sa), _),
251 mstr), _),
252 slaves), _) =>
253 (case (soa sa, master mstr, Env.list Env.string slaves) of
254 (SOME sa, SOME mstr, SOME slaves) =>
255 SOME (UseDns {soa = sa,
256 master = mstr,
257 slaves = slaves})
258 | _ => NONE)
325285ab 259 | (EVar "noDns", _) => SOME NoDns
6ae327f8
AC
260 | _ => NONE
261
a3698041
AC
262val befores = ref (fn (_ : string) => ())
263val afters = ref (fn (_ : string) => ())
264
265fun registerBefore f =
266 let
267 val old = !befores
268 in
269 befores := (fn x => (old x; f x))
270 end
271
272fun registerAfter f =
273 let
274 val old = !afters
275 in
276 afters := (fn x => (old x; f x))
277 end
278
279val current = ref ""
e0b0abd2 280val currentPath = ref (fn (_ : string) => "")
dac62e84 281
d612d62c
AC
282val scratch = ref ""
283
dac62e84
AC
284fun currentDomain () = !current
285
e0b0abd2
AC
286fun domainFile {node, name} = ((*print ("Opening " ^ !currentPath node ^ name ^ "\n");*)
287 TextIO.openOut (!currentPath node ^ name))
dac62e84
AC
288
289fun getPath domain =
290 let
291 val toks = String.fields (fn ch => ch = #".") domain
292
293 val elems = foldr (fn (piece, elems) =>
294 let
295 val elems = piece :: elems
d612d62c 296
e0b0abd2
AC
297 fun doNode node =
298 let
299 val path = String.concatWith "/"
300 (Config.resultRoot :: node :: rev elems)
301 val tmpPath = String.concatWith "/"
302 (Config.tmpDir :: node :: rev elems)
303 in
304 (if Posix.FileSys.ST.isDir
305 (Posix.FileSys.stat path) then
306 ()
307 else
308 (OS.FileSys.remove path;
309 OS.FileSys.mkDir path))
310 handle OS.SysErr _ => OS.FileSys.mkDir path;
311
312 (if Posix.FileSys.ST.isDir
313 (Posix.FileSys.stat tmpPath) then
314 ()
315 else
316 (OS.FileSys.remove tmpPath;
317 OS.FileSys.mkDir tmpPath))
318 handle OS.SysErr _ => OS.FileSys.mkDir tmpPath
319 end
320 in
2ed6d0e5 321 app doNode nodes;
dac62e84
AC
322 elems
323 end) [] toks
324 in
e0b0abd2 325 fn (root, site) => String.concatWith "/" (root :: site :: rev ("" :: elems))
d612d62c
AC
326 end
327
328datatype file_action' =
329 Add' of {src : string, dst : string}
330 | Delete' of string
331 | Modify' of {src : string, dst : string}
332
e0b0abd2 333fun findDiffs (site, dom, acts) =
d612d62c 334 let
e0b0abd2
AC
335 val gp = getPath dom
336 val realPath = gp (Config.resultRoot, site)
337 val tmpPath = gp (Config.tmpDir, site)
338
339 (*val _ = print ("getDiffs(" ^ site ^ ", " ^ dom ^ ")... " ^ realPath ^ "; " ^ tmpPath ^ "\n")*)
d612d62c
AC
340
341 val dir = Posix.FileSys.opendir realPath
342
343 fun loopReal acts =
344 case Posix.FileSys.readdir dir of
345 NONE => (Posix.FileSys.closedir dir;
346 acts)
347 | SOME fname =>
348 let
349 val real = OS.Path.joinDirFile {dir = realPath,
350 file = fname}
351 val tmp = OS.Path.joinDirFile {dir = tmpPath,
352 file = fname}
353 in
354 if Posix.FileSys.ST.isDir (Posix.FileSys.stat real) then
355 loopReal acts
356 else if Posix.FileSys.access (tmp, []) then
8df2e702 357 if Slave.shell [Config.diff, " ", real, " ", tmp] then
d612d62c
AC
358 loopReal acts
359 else
e0b0abd2 360 loopReal ((site, dom, realPath, Modify' {src = tmp, dst = real}) :: acts)
d612d62c 361 else
e0b0abd2 362 loopReal ((site, dom, realPath, Delete' real) :: acts)
d612d62c
AC
363 end
364
e0b0abd2 365 val acts = loopReal acts
d612d62c 366
8df2e702 367 val dir = Posix.FileSys.opendir tmpPath
d612d62c
AC
368
369 fun loopTmp acts =
370 case Posix.FileSys.readdir dir of
371 NONE => (Posix.FileSys.closedir dir;
372 acts)
373 | SOME fname =>
374 let
375 val real = OS.Path.joinDirFile {dir = realPath,
376 file = fname}
377 val tmp = OS.Path.joinDirFile {dir = tmpPath,
378 file = fname}
379 in
380 if Posix.FileSys.ST.isDir (Posix.FileSys.stat tmp) then
381 loopTmp acts
382 else if Posix.FileSys.access (real, []) then
383 loopTmp acts
384 else
e0b0abd2 385 loopTmp ((site, dom, realPath, Add' {src = tmp, dst = real}) :: acts)
d612d62c
AC
386 end
387
388 val acts = loopTmp acts
389 in
390 acts
dac62e84 391 end
a3698041 392
e0b0abd2
AC
393fun findAllDiffs () =
394 let
395 val dir = Posix.FileSys.opendir Config.tmpDir
396 val len = length (String.fields (fn ch => ch = #"/") Config.tmpDir) + 1
397
398 fun exploreSites diffs =
399 case Posix.FileSys.readdir dir of
400 NONE => diffs
401 | SOME site =>
402 let
403 fun explore (dname, diffs) =
404 let
405 val dir = Posix.FileSys.opendir dname
406
407 fun loop diffs =
408 case Posix.FileSys.readdir dir of
409 NONE => diffs
410 | SOME name =>
411 let
412 val fname = OS.Path.joinDirFile {dir = dname,
413 file = name}
414 in
415 loop (if Posix.FileSys.ST.isDir (Posix.FileSys.stat fname) then
416 let
417 val dom = String.fields (fn ch => ch = #"/") fname
418 val dom = List.drop (dom, len)
419 val dom = String.concatWith "." (rev dom)
420
421 val dname' = OS.Path.joinDirFile {dir = dname,
422 file = name}
423 in
424 explore (dname',
425 findDiffs (site, dom, diffs))
426 end
427 else
428 diffs)
429 end
430 in
431 loop diffs
432 before Posix.FileSys.closedir dir
433 end
434 in
36e42cb8
AC
435 exploreSites (explore (OS.Path.joinDirFile {dir = Config.tmpDir,
436 file = site}, diffs))
e0b0abd2
AC
437 end
438 in
439 exploreSites []
440 before Posix.FileSys.closedir dir
441 end
442
443val masterNode : string option ref = ref NONE
444fun dnsMaster () = !masterNode
445
6ae327f8
AC
446val _ = Env.containerV_one "domain"
447 ("domain", Env.string)
448 (fn (evs, dom) =>
449 let
450 val kind = Env.env dnsKind (evs, "DNS")
451 val ttl = Env.env Env.int (evs, "TTL")
452
e0b0abd2 453 val path = getPath dom
6ae327f8
AC
454
455 val () = (current := dom;
e0b0abd2 456 currentPath := (fn site => path (Config.tmpDir, site)))
6ae327f8 457
e0b0abd2 458 fun saveSoa (kind, soa : soa) node =
6ae327f8 459 let
e0b0abd2 460 val outf = domainFile {node = node, name = "soa"}
6ae327f8
AC
461 in
462 TextIO.output (outf, kind);
463 TextIO.output (outf, "\n");
464 TextIO.output (outf, Int.toString ttl);
465 TextIO.output (outf, "\n");
466 TextIO.output (outf, #ns soa);
467 TextIO.output (outf, "\n");
468 case #serial soa of
469 NONE => ()
470 | SOME n => TextIO.output (outf, Int.toString n);
471 TextIO.output (outf, "\n");
472 TextIO.output (outf, Int.toString (#ref soa));
473 TextIO.output (outf, "\n");
474 TextIO.output (outf, Int.toString (#ret soa));
475 TextIO.output (outf, "\n");
476 TextIO.output (outf, Int.toString (#exp soa));
477 TextIO.output (outf, "\n");
478 TextIO.output (outf, Int.toString (#min soa));
479 TextIO.output (outf, "\n");
480 TextIO.closeOut outf
481 end
482
2ed6d0e5 483 fun saveNamed (kind, soa : soa, masterIp) node =
6ae327f8 484 let
e0b0abd2 485 val outf = domainFile {node = node, name = "named.conf"}
6ae327f8
AC
486 in
487 TextIO.output (outf, "\nzone \"");
488 TextIO.output (outf, dom);
489 TextIO.output (outf, "\" IN {\n\ttype ");
490 TextIO.output (outf, kind);
491 TextIO.output (outf, ";\n\tfile \"");
27e20924 492 TextIO.output (outf, Config.Bind.zonePath_real);
6ae327f8
AC
493 TextIO.output (outf, "/");
494 TextIO.output (outf, dom);
495 TextIO.output (outf, ".zone\";\n");
496 case kind of
497 "master" => TextIO.output (outf, "\tallow-update { none; };\n")
2ed6d0e5
AC
498 | _ => (TextIO.output (outf, "\tmasters { ");
499 TextIO.output (outf, masterIp);
7d042452 500 TextIO.output (outf, "; };\n"));
2ed6d0e5 501 TextIO.output (outf, "};\n");
6ae327f8
AC
502 TextIO.closeOut outf
503 end
6ae327f8
AC
504 in
505 case kind of
e0b0abd2
AC
506 NoDns => masterNode := NONE
507 | UseDns dns =>
2ed6d0e5
AC
508 let
509 val masterIp =
510 case #master dns of
511 InternalMaster node => valOf (SM.find (nodeMap, node))
512 | ExternalMaster ip => ip
513 in
514 app (saveSoa ("slave", #soa dns)) (#slaves dns);
515 app (saveNamed ("slave", #soa dns, masterIp)) (#slaves dns);
516 case #master dns of
517 InternalMaster node =>
518 (masterNode := SOME node;
519 saveSoa ("master", #soa dns) node;
520 saveNamed ("master", #soa dns, masterIp) node)
521 | _ => masterNode := NONE;
522 !befores dom
523 end
6ae327f8 524 end,
e0b0abd2
AC
525 fn () => !afters (!current))
526
527val () = Env.registerPre (fn () => (ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, ""],
528 fn cl => "Temp file cleanup failed: " ^ cl));
529 OS.FileSys.mkDir Config.tmpDir;
530 app (fn node => OS.FileSys.mkDir
531 (OS.Path.joinDirFile {dir = Config.tmpDir,
532 file = node}))
2ed6d0e5 533 nodes;
e0b0abd2
AC
534 app (fn node => OS.FileSys.mkDir
535 (OS.Path.joinDirFile {dir = Config.resultRoot,
536 file = node})
537 handle OS.SysErr _ => ())
2ed6d0e5 538 nodes))
e0b0abd2
AC
539
540val () = Env.registerPost (fn () =>
541 let
542 val diffs = findAllDiffs ()
6ae327f8 543
e0b0abd2
AC
544 val diffs = map (fn (site, dom, dir, Add' {src, dst}) =>
545 (Slave.shellF ([Config.cp, " ", src, " ", dst],
546 fn cl => "Copy failed: " ^ cl);
547 (site,
6ae327f8
AC
548 {action = Slave.Add,
549 domain = dom,
550 dir = dir,
e0b0abd2
AC
551 file = dst}))
552 | (site, dom, dir, Delete' dst) =>
553 (OS.FileSys.remove dst
554 handle OS.SysErr _ =>
555 ErrorMsg.error NONE ("Delete failed for " ^ dst);
556 (site,
6ae327f8
AC
557 {action = Slave.Delete,
558 domain = dom,
559 dir = dir,
e0b0abd2
AC
560 file = dst}))
561 | (site, dom, dir, Modify' {src, dst}) =>
562 (Slave.shellF ([Config.cp, " ", src, " ", dst],
563 fn cl => "Copy failed: " ^ cl);
564 (site,
6ae327f8
AC
565 {action = Slave.Modify,
566 domain = dom,
567 dir = dir,
e0b0abd2
AC
568 file = dst}))) diffs
569 in
570 if !ErrorMsg.anyErrors then
571 ()
36e42cb8
AC
572 else let
573 val changed = foldl (fn ((site, file), changed) =>
574 let
575 val ls = case SM.find (changed, site) of
576 NONE => []
577 | SOME ls => ls
578 in
579 SM.insert (changed, site, file :: ls)
580 end) SM.empty diffs
581
582 fun handleSite (site, files) =
583 let
584
585 in
586 print ("New configuration for node " ^ site ^ "\n");
587 if site = Config.defaultNode then
588 Slave.handleChanges files
589 else let
590 val bio = OpenSSL.connect (valOf (!ssl_context),
591 nodeIp site
592 ^ ":"
593 ^ Int.toString Config.slavePort)
594 in
595 app (fn file => Msg.send (bio, MsgFile file)) files;
596 Msg.send (bio, MsgDoFiles);
597 case Msg.recv bio of
598 NONE => print "Slave closed connection unexpectedly\n"
599 | SOME m =>
600 case m of
601 MsgOk => print ("Slave " ^ site ^ " finished\n")
602 | MsgError s => print ("Slave " ^ site
603 ^ " returned error: " ^
604 s ^ "\n")
605 | _ => print ("Slave " ^ site
606 ^ " returned unexpected command\n");
607 OpenSSL.close bio
608 end
609 end
610 in
611 SM.appi handleSite changed
612 end;
e0b0abd2 613 ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, ""],
559e89e9 614 fn cl => "Temp file cleanup failed: " ^ cl))
e0b0abd2 615 end)
6ae327f8 616
be1bea4c
AC
617fun hasPriv priv = Acl.query {user = getUser (), class = "priv", value = "all"}
618 orelse Acl.query {user = getUser (), class = "priv", value = priv}
619
620val _ = Env.type_one "dns_node"
621 Env.string
622 (fn node =>
623 List.exists (fn x => x = node) Config.dnsNodes_all
624 orelse (hasPriv "dns"
625 andalso List.exists (fn x => x = node) Config.dnsNodes_admin))
60695e99 626
bbdf617f
AC
627val _ = Env.type_one "mail_node"
628 Env.string
629 (fn node =>
630 List.exists (fn x => x = node) Config.mailNodes_all
631 orelse (hasPriv "mail"
632 andalso List.exists (fn x => x = node) Config.mailNodes_admin))
633
a3698041 634end