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