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