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