ip_of_node support
[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 open Ast
157
158 val dl = ErrorMsg.dummyLoc
159
160 val nsD = (EString Config.defaultNs, dl)
161 val serialD = (EVar "serialAuto", dl)
162 val refD = (EInt Config.defaultRefresh, dl)
163 val retD = (EInt Config.defaultRetry, dl)
164 val expD = (EInt Config.defaultExpiry, dl)
165 val minD = (EInt Config.defaultMinimum, dl)
166
167 val soaD = multiApp ((EVar "soa", dl),
168 dl,
169 [nsD, serialD, refD, retD, expD, minD])
170
171 val masterD = (EApp ((EVar "internalMaster", dl),
172 (EString Config.defaultNode, dl)),
173 dl)
174
175 val _ = Defaults.registerDefault ("Mailbox",
176 (TBase "email", dl),
177 (fn () => (EString (getUser ()), dl)))
178
179 val _ = Defaults.registerDefault ("DNS",
180 (TBase "dnsKind", dl),
181 (fn () => multiApp ((EVar "useDns", dl),
182 dl,
183 [soaD, masterD, (EList [], dl)])))
184
185 val _ = Defaults.registerDefault ("TTL",
186 (TBase "int", dl),
187 (fn () => (EInt Config.Bind.defaultTTL, dl)))
188
189 type soa = {ns : string,
190 serial : int option,
191 ref : int,
192 ret : int,
193 exp : int,
194 min : int}
195
196 val serial = fn (EVar "serialAuto", _) => SOME NONE
197 | (EApp ((EVar "serialConst", _), n), _) => Option.map SOME (Env.int n)
198 | _ => NONE
199
200 val soa = fn (EApp ((EApp ((EApp ((EApp ((EApp ((EApp
201 ((EVar "soa", _), ns), _),
202 sl), _),
203 rf), _),
204 ret), _),
205 exp), _),
206 min), _) =>
207 (case (Env.string ns, serial sl, Env.int rf,
208 Env.int ret, Env.int exp, Env.int min) of
209 (SOME ns, SOME sl, SOME rf,
210 SOME ret, SOME exp, SOME min) =>
211 SOME {ns = ns,
212 serial = sl,
213 ref = rf,
214 ret = ret,
215 exp = exp,
216 min = min}
217 | _ => NONE)
218 | _ => NONE
219
220 datatype master =
221 ExternalMaster of string
222 | InternalMaster of string
223
224 val ip = fn (EApp ((EVar "ip_of_node", _), e), _) => Option.map nodeIp (Env.string e)
225 | e => Env.string e
226
227 val master = fn (EApp ((EVar "externalMaster", _), e), _) => Option.map ExternalMaster (ip e)
228 | (EApp ((EVar "internalMaster", _), e), _) => Option.map InternalMaster (ip e)
229 | _ => NONE
230
231 datatype dnsKind =
232 UseDns of {soa : soa,
233 master : master,
234 slaves : string list}
235 | NoDns
236
237 val dnsKind = fn (EApp ((EApp ((EApp
238 ((EVar "useDns", _), sa), _),
239 mstr), _),
240 slaves), _) =>
241 (case (soa sa, master mstr, Env.list Env.string slaves) of
242 (SOME sa, SOME mstr, SOME slaves) =>
243 SOME (UseDns {soa = sa,
244 master = mstr,
245 slaves = slaves})
246 | _ => NONE)
247 | (EVar "noDns", _) => SOME NoDns
248 | _ => NONE
249
250 val befores = ref (fn (_ : string) => ())
251 val afters = ref (fn (_ : string) => ())
252
253 fun registerBefore f =
254 let
255 val old = !befores
256 in
257 befores := (fn x => (old x; f x))
258 end
259
260 fun registerAfter f =
261 let
262 val old = !afters
263 in
264 afters := (fn x => (old x; f x))
265 end
266
267 val current = ref ""
268 val currentPath = ref (fn (_ : string) => "")
269
270 val scratch = ref ""
271
272 fun currentDomain () = !current
273
274 fun domainFile {node, name} = ((*print ("Opening " ^ !currentPath node ^ name ^ "\n");*)
275 TextIO.openOut (!currentPath node ^ name))
276
277 fun getPath domain =
278 let
279 val toks = String.fields (fn ch => ch = #".") domain
280
281 val elems = foldr (fn (piece, elems) =>
282 let
283 val elems = piece :: elems
284
285 fun doNode node =
286 let
287 val path = String.concatWith "/"
288 (Config.resultRoot :: node :: rev elems)
289 val tmpPath = String.concatWith "/"
290 (Config.tmpDir :: node :: rev elems)
291 in
292 (if Posix.FileSys.ST.isDir
293 (Posix.FileSys.stat path) then
294 ()
295 else
296 (OS.FileSys.remove path;
297 OS.FileSys.mkDir path))
298 handle OS.SysErr _ => OS.FileSys.mkDir path;
299
300 (if Posix.FileSys.ST.isDir
301 (Posix.FileSys.stat tmpPath) then
302 ()
303 else
304 (OS.FileSys.remove tmpPath;
305 OS.FileSys.mkDir tmpPath))
306 handle OS.SysErr _ => OS.FileSys.mkDir tmpPath
307 end
308 in
309 app doNode nodes;
310 elems
311 end) [] toks
312 in
313 fn (root, site) => String.concatWith "/" (root :: site :: rev ("" :: elems))
314 end
315
316 datatype file_action' =
317 Add' of {src : string, dst : string}
318 | Delete' of string
319 | Modify' of {src : string, dst : string}
320
321 fun findDiffs (site, dom, acts) =
322 let
323 val gp = getPath dom
324 val realPath = gp (Config.resultRoot, site)
325 val tmpPath = gp (Config.tmpDir, site)
326
327 (*val _ = print ("getDiffs(" ^ site ^ ", " ^ dom ^ ")... " ^ realPath ^ "; " ^ tmpPath ^ "\n")*)
328
329 val dir = Posix.FileSys.opendir realPath
330
331 fun loopReal acts =
332 case Posix.FileSys.readdir dir of
333 NONE => (Posix.FileSys.closedir dir;
334 acts)
335 | SOME fname =>
336 let
337 val real = OS.Path.joinDirFile {dir = realPath,
338 file = fname}
339 val tmp = OS.Path.joinDirFile {dir = tmpPath,
340 file = fname}
341 in
342 if Posix.FileSys.ST.isDir (Posix.FileSys.stat real) then
343 loopReal acts
344 else if Posix.FileSys.access (tmp, []) then
345 if Slave.shell [Config.diff, " ", real, " ", tmp] then
346 loopReal acts
347 else
348 loopReal ((site, dom, realPath, Modify' {src = tmp, dst = real}) :: acts)
349 else
350 loopReal ((site, dom, realPath, Delete' real) :: acts)
351 end
352
353 val acts = loopReal acts
354
355 val dir = Posix.FileSys.opendir tmpPath
356
357 fun loopTmp acts =
358 case Posix.FileSys.readdir dir of
359 NONE => (Posix.FileSys.closedir dir;
360 acts)
361 | SOME fname =>
362 let
363 val real = OS.Path.joinDirFile {dir = realPath,
364 file = fname}
365 val tmp = OS.Path.joinDirFile {dir = tmpPath,
366 file = fname}
367 in
368 if Posix.FileSys.ST.isDir (Posix.FileSys.stat tmp) then
369 loopTmp acts
370 else if Posix.FileSys.access (real, []) then
371 loopTmp acts
372 else
373 loopTmp ((site, dom, realPath, Add' {src = tmp, dst = real}) :: acts)
374 end
375
376 val acts = loopTmp acts
377 in
378 acts
379 end
380
381 fun findAllDiffs () =
382 let
383 val dir = Posix.FileSys.opendir Config.tmpDir
384 val len = length (String.fields (fn ch => ch = #"/") Config.tmpDir) + 1
385
386 fun exploreSites diffs =
387 case Posix.FileSys.readdir dir of
388 NONE => diffs
389 | SOME site =>
390 let
391 fun explore (dname, diffs) =
392 let
393 val dir = Posix.FileSys.opendir dname
394
395 fun loop diffs =
396 case Posix.FileSys.readdir dir of
397 NONE => diffs
398 | SOME name =>
399 let
400 val fname = OS.Path.joinDirFile {dir = dname,
401 file = name}
402 in
403 loop (if Posix.FileSys.ST.isDir (Posix.FileSys.stat fname) then
404 let
405 val dom = String.fields (fn ch => ch = #"/") fname
406 val dom = List.drop (dom, len)
407 val dom = String.concatWith "." (rev dom)
408
409 val dname' = OS.Path.joinDirFile {dir = dname,
410 file = name}
411 in
412 explore (dname',
413 findDiffs (site, dom, diffs))
414 end
415 else
416 diffs)
417 end
418 in
419 loop diffs
420 before Posix.FileSys.closedir dir
421 end
422 in
423 exploreSites (explore (OS.Path.joinDirFile {dir = Config.tmpDir,
424 file = site}, diffs))
425 end
426 in
427 exploreSites []
428 before Posix.FileSys.closedir dir
429 end
430
431 val masterNode : string option ref = ref NONE
432 fun dnsMaster () = !masterNode
433
434 val _ = Env.containerV_one "domain"
435 ("domain", Env.string)
436 (fn (evs, dom) =>
437 let
438 val kind = Env.env dnsKind (evs, "DNS")
439 val ttl = Env.env Env.int (evs, "TTL")
440
441 val path = getPath dom
442
443 val () = (current := dom;
444 currentPath := (fn site => path (Config.tmpDir, site)))
445
446 fun saveSoa (kind, soa : soa) node =
447 let
448 val outf = domainFile {node = node, name = "soa"}
449 in
450 TextIO.output (outf, kind);
451 TextIO.output (outf, "\n");
452 TextIO.output (outf, Int.toString ttl);
453 TextIO.output (outf, "\n");
454 TextIO.output (outf, #ns soa);
455 TextIO.output (outf, "\n");
456 case #serial soa of
457 NONE => ()
458 | SOME n => TextIO.output (outf, Int.toString n);
459 TextIO.output (outf, "\n");
460 TextIO.output (outf, Int.toString (#ref soa));
461 TextIO.output (outf, "\n");
462 TextIO.output (outf, Int.toString (#ret soa));
463 TextIO.output (outf, "\n");
464 TextIO.output (outf, Int.toString (#exp soa));
465 TextIO.output (outf, "\n");
466 TextIO.output (outf, Int.toString (#min soa));
467 TextIO.output (outf, "\n");
468 TextIO.closeOut outf
469 end
470
471 fun saveNamed (kind, soa : soa, masterIp) node =
472 let
473 val outf = domainFile {node = node, name = "named.conf"}
474 in
475 TextIO.output (outf, "\nzone \"");
476 TextIO.output (outf, dom);
477 TextIO.output (outf, "\" IN {\n\ttype ");
478 TextIO.output (outf, kind);
479 TextIO.output (outf, ";\n\tfile \"");
480 TextIO.output (outf, Config.Bind.zonePath_real);
481 TextIO.output (outf, "/");
482 TextIO.output (outf, dom);
483 TextIO.output (outf, ".zone\";\n");
484 case kind of
485 "master" => TextIO.output (outf, "\tallow-update { none; };\n")
486 | _ => (TextIO.output (outf, "\tmasters { ");
487 TextIO.output (outf, masterIp);
488 TextIO.output (outf, " };\n"));
489 TextIO.output (outf, "};\n");
490 TextIO.closeOut outf
491 end
492 in
493 case kind of
494 NoDns => masterNode := NONE
495 | UseDns dns =>
496 let
497 val masterIp =
498 case #master dns of
499 InternalMaster node => valOf (SM.find (nodeMap, node))
500 | ExternalMaster ip => ip
501 in
502 app (saveSoa ("slave", #soa dns)) (#slaves dns);
503 app (saveNamed ("slave", #soa dns, masterIp)) (#slaves dns);
504 case #master dns of
505 InternalMaster node =>
506 (masterNode := SOME node;
507 saveSoa ("master", #soa dns) node;
508 saveNamed ("master", #soa dns, masterIp) node)
509 | _ => masterNode := NONE;
510 !befores dom
511 end
512 end,
513 fn () => !afters (!current))
514
515 val () = Env.registerPre (fn () => (ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, ""],
516 fn cl => "Temp file cleanup failed: " ^ cl));
517 OS.FileSys.mkDir Config.tmpDir;
518 app (fn node => OS.FileSys.mkDir
519 (OS.Path.joinDirFile {dir = Config.tmpDir,
520 file = node}))
521 nodes;
522 app (fn node => OS.FileSys.mkDir
523 (OS.Path.joinDirFile {dir = Config.resultRoot,
524 file = node})
525 handle OS.SysErr _ => ())
526 nodes))
527
528 val () = Env.registerPost (fn () =>
529 let
530 val diffs = findAllDiffs ()
531
532 val diffs = map (fn (site, dom, dir, Add' {src, dst}) =>
533 (Slave.shellF ([Config.cp, " ", src, " ", dst],
534 fn cl => "Copy failed: " ^ cl);
535 (site,
536 {action = Slave.Add,
537 domain = dom,
538 dir = dir,
539 file = dst}))
540 | (site, dom, dir, Delete' dst) =>
541 (OS.FileSys.remove dst
542 handle OS.SysErr _ =>
543 ErrorMsg.error NONE ("Delete failed for " ^ dst);
544 (site,
545 {action = Slave.Delete,
546 domain = dom,
547 dir = dir,
548 file = dst}))
549 | (site, dom, dir, Modify' {src, dst}) =>
550 (Slave.shellF ([Config.cp, " ", src, " ", dst],
551 fn cl => "Copy failed: " ^ cl);
552 (site,
553 {action = Slave.Modify,
554 domain = dom,
555 dir = dir,
556 file = dst}))) diffs
557 in
558 if !ErrorMsg.anyErrors then
559 ()
560 else let
561 val changed = foldl (fn ((site, file), changed) =>
562 let
563 val ls = case SM.find (changed, site) of
564 NONE => []
565 | SOME ls => ls
566 in
567 SM.insert (changed, site, file :: ls)
568 end) SM.empty diffs
569
570 fun handleSite (site, files) =
571 let
572
573 in
574 print ("New configuration for node " ^ site ^ "\n");
575 if site = Config.defaultNode then
576 Slave.handleChanges files
577 else let
578 val bio = OpenSSL.connect (valOf (!ssl_context),
579 nodeIp site
580 ^ ":"
581 ^ Int.toString Config.slavePort)
582 in
583 app (fn file => Msg.send (bio, MsgFile file)) files;
584 Msg.send (bio, MsgDoFiles);
585 case Msg.recv bio of
586 NONE => print "Slave closed connection unexpectedly\n"
587 | SOME m =>
588 case m of
589 MsgOk => print ("Slave " ^ site ^ " finished\n")
590 | MsgError s => print ("Slave " ^ site
591 ^ " returned error: " ^
592 s ^ "\n")
593 | _ => print ("Slave " ^ site
594 ^ " returned unexpected command\n");
595 OpenSSL.close bio
596 end
597 end
598 in
599 SM.appi handleSite changed
600 end;
601 ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, ""],
602 fn cl => "Temp file cleanup failed: " ^ cl))
603 end)
604
605 end