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