Permission revocation
[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 51fun setUser user =
a088cea6 52 (usr := user;
aa56e112
AC
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 171val masterD = (EApp ((EVar "internalMaster", dl),
8b84db5b 172 (EString Config.masterNode, dl)),
e0b0abd2
AC
173 dl)
174
8b84db5b
AC
175val slavesD = (EList (map (fn s => (EString s, dl)) Config.slaveNodes), dl)
176
6bb366c5
AC
177val _ = Defaults.registerDefault ("Mailbox",
178 (TBase "email", dl),
179 (fn () => (EString (getUser ()), dl)))
180
aa56e112
AC
181val _ = Defaults.registerDefault ("DNS",
182 (TBase "dnsKind", dl),
183 (fn () => multiApp ((EVar "useDns", dl),
184 dl,
8b84db5b 185 [soaD, masterD, slavesD])))
6ae327f8 186
aa56e112
AC
187val _ = Defaults.registerDefault ("TTL",
188 (TBase "int", dl),
189 (fn () => (EInt Config.Bind.defaultTTL, dl)))
6ae327f8
AC
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
e0b0abd2
AC
222datatype master =
223 ExternalMaster of string
224 | InternalMaster of string
225
97665758
AC
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)
8b84db5b 230 | (EApp ((EVar "internalMaster", _), e), _) => Option.map InternalMaster (Env.string e)
e0b0abd2
AC
231 | _ => NONE
232
6ae327f8 233datatype dnsKind =
e0b0abd2
AC
234 UseDns of {soa : soa,
235 master : master,
236 slaves : string list}
6ae327f8
AC
237 | NoDns
238
e0b0abd2
AC
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)
325285ab 249 | (EVar "noDns", _) => SOME NoDns
6ae327f8
AC
250 | _ => NONE
251
a3698041
AC
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 ""
e0b0abd2 270val currentPath = ref (fn (_ : string) => "")
dac62e84 271
d612d62c
AC
272val scratch = ref ""
273
dac62e84
AC
274fun currentDomain () = !current
275
e0b0abd2
AC
276fun domainFile {node, name} = ((*print ("Opening " ^ !currentPath node ^ name ^ "\n");*)
277 TextIO.openOut (!currentPath node ^ name))
dac62e84
AC
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
d612d62c 286
e0b0abd2
AC
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
2ed6d0e5 311 app doNode nodes;
dac62e84
AC
312 elems
313 end) [] toks
314 in
e0b0abd2 315 fn (root, site) => String.concatWith "/" (root :: site :: rev ("" :: elems))
d612d62c
AC
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
e0b0abd2 323fun findDiffs (site, dom, acts) =
d612d62c 324 let
e0b0abd2
AC
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")*)
d612d62c
AC
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
8df2e702 347 if Slave.shell [Config.diff, " ", real, " ", tmp] then
d612d62c
AC
348 loopReal acts
349 else
e0b0abd2 350 loopReal ((site, dom, realPath, Modify' {src = tmp, dst = real}) :: acts)
d612d62c 351 else
e0b0abd2 352 loopReal ((site, dom, realPath, Delete' real) :: acts)
d612d62c
AC
353 end
354
e0b0abd2 355 val acts = loopReal acts
d612d62c 356
8df2e702 357 val dir = Posix.FileSys.opendir tmpPath
d612d62c
AC
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
e0b0abd2 375 loopTmp ((site, dom, realPath, Add' {src = tmp, dst = real}) :: acts)
d612d62c
AC
376 end
377
378 val acts = loopTmp acts
379 in
380 acts
dac62e84 381 end
a3698041 382
e0b0abd2
AC
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
36e42cb8
AC
425 exploreSites (explore (OS.Path.joinDirFile {dir = Config.tmpDir,
426 file = site}, diffs))
e0b0abd2
AC
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
6ae327f8
AC
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
e0b0abd2 443 val path = getPath dom
6ae327f8
AC
444
445 val () = (current := dom;
e0b0abd2 446 currentPath := (fn site => path (Config.tmpDir, site)))
6ae327f8 447
e0b0abd2 448 fun saveSoa (kind, soa : soa) node =
6ae327f8 449 let
e0b0abd2 450 val outf = domainFile {node = node, name = "soa"}
6ae327f8
AC
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
2ed6d0e5 473 fun saveNamed (kind, soa : soa, masterIp) node =
6ae327f8 474 let
e0b0abd2 475 val outf = domainFile {node = node, name = "named.conf"}
6ae327f8
AC
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 \"");
27e20924 482 TextIO.output (outf, Config.Bind.zonePath_real);
6ae327f8
AC
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")
2ed6d0e5
AC
488 | _ => (TextIO.output (outf, "\tmasters { ");
489 TextIO.output (outf, masterIp);
7d042452 490 TextIO.output (outf, "; };\n"));
2ed6d0e5 491 TextIO.output (outf, "};\n");
6ae327f8
AC
492 TextIO.closeOut outf
493 end
6ae327f8
AC
494 in
495 case kind of
e0b0abd2
AC
496 NoDns => masterNode := NONE
497 | UseDns dns =>
2ed6d0e5
AC
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
6ae327f8 514 end,
e0b0abd2
AC
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}))
2ed6d0e5 523 nodes;
e0b0abd2
AC
524 app (fn node => OS.FileSys.mkDir
525 (OS.Path.joinDirFile {dir = Config.resultRoot,
526 file = node})
527 handle OS.SysErr _ => ())
2ed6d0e5 528 nodes))
e0b0abd2
AC
529
530val () = Env.registerPost (fn () =>
531 let
532 val diffs = findAllDiffs ()
6ae327f8 533
e0b0abd2
AC
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,
6ae327f8
AC
538 {action = Slave.Add,
539 domain = dom,
540 dir = dir,
e0b0abd2
AC
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,
6ae327f8
AC
547 {action = Slave.Delete,
548 domain = dom,
549 dir = dir,
e0b0abd2
AC
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,
6ae327f8
AC
555 {action = Slave.Modify,
556 domain = dom,
557 dir = dir,
e0b0abd2
AC
558 file = dst}))) diffs
559 in
560 if !ErrorMsg.anyErrors then
561 ()
36e42cb8
AC
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;
e0b0abd2 603 ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, ""],
559e89e9 604 fn cl => "Temp file cleanup failed: " ^ cl))
e0b0abd2 605 end)
6ae327f8 606
a3698041 607end