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