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