ACLs
[hcoop/domtool2.git] / src / domain.sml
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
21 structure Domain :> DOMAIN = struct
22
23 structure SM = DataStructures.StringMap
24 structure SS = DataStructures.StringSet
25
26 val nodes = map #1 Config.nodeIps
27 val nodeMap = foldl (fn ((node, ip), mp) => SM.insert (mp, node, ip))
28 SM.empty Config.nodeIps
29
30 val usr = ref ""
31 fun setUser ur = usr := ur
32 fun getUser () = !usr
33
34 val your_doms = ref SS.empty
35 fun your_domains () = !your_doms
36
37 fun validIp s =
38 case map Int.fromString (String.fields (fn ch => ch = #".") s) of
39 [SOME n1, SOME n2, SOME n3, SOME n4] =>
40 n1 >= 0 andalso n1 < 256 andalso n2 >= 0 andalso n2 < 256 andalso n3 >= 0 andalso n3 < 256 andalso n4 >= 0 andalso n4 < 256
41 | _ => false
42
43 fun isIdent ch = Char.isLower ch orelse Char.isDigit ch
44
45 fun validHost s =
46 size s > 0 andalso size s < 20
47 andalso CharVector.all (fn ch => isIdent ch orelse ch = #"-") s
48
49 fun validDomain s =
50 size s > 0 andalso size s < 100
51 andalso List.all validHost (String.fields (fn ch => ch = #".") s)
52
53 fun validNode s = List.exists (fn s' => s = s') nodes
54
55 fun yourDomain s = SS.member (your_domains (), s)
56
57 val _ = Env.type_one "ip"
58 Env.string
59 validIp
60
61 val _ = Env.type_one "host"
62 Env.string
63 validHost
64
65 val _ = Env.type_one "domain"
66 Env.string
67 validDomain
68
69 val _ = Env.type_one "your_domain"
70 Env.string
71 yourDomain
72
73 val _ = Env.type_one "node"
74 Env.string
75 validNode
76
77 open Ast
78
79 val dl = ErrorMsg.dummyLoc
80
81 val nsD = (EString Config.defaultNs, dl)
82 val serialD = (EVar "serialAuto", dl)
83 val refD = (EInt Config.defaultRefresh, dl)
84 val retD = (EInt Config.defaultRetry, dl)
85 val expD = (EInt Config.defaultExpiry, dl)
86 val minD = (EInt Config.defaultMinimum, dl)
87
88 val soaD = multiApp ((EVar "soa", dl),
89 dl,
90 [nsD, serialD, refD, retD, expD, minD])
91
92 val masterD = (EApp ((EVar "internalMaster", dl),
93 (EString Config.defaultNode, dl)),
94 dl)
95
96 val _ = Main.registerDefault ("DNS",
97 (TBase "dnsKind", dl),
98 (multiApp ((EVar "useDns", dl),
99 dl,
100 [soaD, masterD, (EList [], dl)])))
101
102 val _ = Main.registerDefault ("TTL",
103 (TBase "int", dl),
104 (EInt Config.Bind.defaultTTL, dl))
105
106 type soa = {ns : string,
107 serial : int option,
108 ref : int,
109 ret : int,
110 exp : int,
111 min : int}
112
113 val serial = fn (EVar "serialAuto", _) => SOME NONE
114 | (EApp ((EVar "serialConst", _), n), _) => Option.map SOME (Env.int n)
115 | _ => NONE
116
117 val soa = fn (EApp ((EApp ((EApp ((EApp ((EApp ((EApp
118 ((EVar "soa", _), ns), _),
119 sl), _),
120 rf), _),
121 ret), _),
122 exp), _),
123 min), _) =>
124 (case (Env.string ns, serial sl, Env.int rf,
125 Env.int ret, Env.int exp, Env.int min) of
126 (SOME ns, SOME sl, SOME rf,
127 SOME ret, SOME exp, SOME min) =>
128 SOME {ns = ns,
129 serial = sl,
130 ref = rf,
131 ret = ret,
132 exp = exp,
133 min = min}
134 | _ => NONE)
135 | _ => NONE
136
137 datatype master =
138 ExternalMaster of string
139 | InternalMaster of string
140
141 val master = fn (EApp ((EVar "externalMaster", _), e), _) => Option.map ExternalMaster (Env.string e)
142 | (EApp ((EVar "internalMaster", _), e), _) => Option.map InternalMaster (Env.string e)
143 | _ => NONE
144
145 datatype dnsKind =
146 UseDns of {soa : soa,
147 master : master,
148 slaves : string list}
149 | NoDns
150
151 val dnsKind = fn (EApp ((EApp ((EApp
152 ((EVar "useDns", _), sa), _),
153 mstr), _),
154 slaves), _) =>
155 (case (soa sa, master mstr, Env.list Env.string slaves) of
156 (SOME sa, SOME mstr, SOME slaves) =>
157 SOME (UseDns {soa = sa,
158 master = mstr,
159 slaves = slaves})
160 | _ => NONE)
161 | _ => NONE
162
163 val befores = ref (fn (_ : string) => ())
164 val afters = ref (fn (_ : string) => ())
165
166 fun registerBefore f =
167 let
168 val old = !befores
169 in
170 befores := (fn x => (old x; f x))
171 end
172
173 fun registerAfter f =
174 let
175 val old = !afters
176 in
177 afters := (fn x => (old x; f x))
178 end
179
180 val current = ref ""
181 val currentPath = ref (fn (_ : string) => "")
182
183 val scratch = ref ""
184
185 fun currentDomain () = !current
186
187 fun domainFile {node, name} = ((*print ("Opening " ^ !currentPath node ^ name ^ "\n");*)
188 TextIO.openOut (!currentPath node ^ name))
189
190 fun getPath domain =
191 let
192 val toks = String.fields (fn ch => ch = #".") domain
193
194 val elems = foldr (fn (piece, elems) =>
195 let
196 val elems = piece :: elems
197
198 fun doNode node =
199 let
200 val path = String.concatWith "/"
201 (Config.resultRoot :: node :: rev elems)
202 val tmpPath = String.concatWith "/"
203 (Config.tmpDir :: node :: rev elems)
204 in
205 (if Posix.FileSys.ST.isDir
206 (Posix.FileSys.stat path) then
207 ()
208 else
209 (OS.FileSys.remove path;
210 OS.FileSys.mkDir path))
211 handle OS.SysErr _ => OS.FileSys.mkDir path;
212
213 (if Posix.FileSys.ST.isDir
214 (Posix.FileSys.stat tmpPath) then
215 ()
216 else
217 (OS.FileSys.remove tmpPath;
218 OS.FileSys.mkDir tmpPath))
219 handle OS.SysErr _ => OS.FileSys.mkDir tmpPath
220 end
221 in
222 app doNode nodes;
223 elems
224 end) [] toks
225 in
226 fn (root, site) => String.concatWith "/" (root :: site :: rev ("" :: elems))
227 end
228
229 datatype file_action' =
230 Add' of {src : string, dst : string}
231 | Delete' of string
232 | Modify' of {src : string, dst : string}
233
234 fun findDiffs (site, dom, acts) =
235 let
236 val gp = getPath dom
237 val realPath = gp (Config.resultRoot, site)
238 val tmpPath = gp (Config.tmpDir, site)
239
240 (*val _ = print ("getDiffs(" ^ site ^ ", " ^ dom ^ ")... " ^ realPath ^ "; " ^ tmpPath ^ "\n")*)
241
242 val dir = Posix.FileSys.opendir realPath
243
244 fun loopReal acts =
245 case Posix.FileSys.readdir dir of
246 NONE => (Posix.FileSys.closedir dir;
247 acts)
248 | SOME fname =>
249 let
250 val real = OS.Path.joinDirFile {dir = realPath,
251 file = fname}
252 val tmp = OS.Path.joinDirFile {dir = tmpPath,
253 file = fname}
254 in
255 if Posix.FileSys.ST.isDir (Posix.FileSys.stat real) then
256 loopReal acts
257 else if Posix.FileSys.access (tmp, []) then
258 if Slave.shell [Config.diff, " ", real, " ", tmp] then
259 loopReal acts
260 else
261 loopReal ((site, dom, realPath, Modify' {src = tmp, dst = real}) :: acts)
262 else
263 loopReal ((site, dom, realPath, Delete' real) :: acts)
264 end
265
266 val acts = loopReal acts
267
268 val dir = Posix.FileSys.opendir tmpPath
269
270 fun loopTmp acts =
271 case Posix.FileSys.readdir dir of
272 NONE => (Posix.FileSys.closedir dir;
273 acts)
274 | SOME fname =>
275 let
276 val real = OS.Path.joinDirFile {dir = realPath,
277 file = fname}
278 val tmp = OS.Path.joinDirFile {dir = tmpPath,
279 file = fname}
280 in
281 if Posix.FileSys.ST.isDir (Posix.FileSys.stat tmp) then
282 loopTmp acts
283 else if Posix.FileSys.access (real, []) then
284 loopTmp acts
285 else
286 loopTmp ((site, dom, realPath, Add' {src = tmp, dst = real}) :: acts)
287 end
288
289 val acts = loopTmp acts
290 in
291 acts
292 end
293
294 fun findAllDiffs () =
295 let
296 val dir = Posix.FileSys.opendir Config.tmpDir
297 val len = length (String.fields (fn ch => ch = #"/") Config.tmpDir) + 1
298
299 fun exploreSites diffs =
300 case Posix.FileSys.readdir dir of
301 NONE => diffs
302 | SOME site =>
303 let
304 fun explore (dname, diffs) =
305 let
306 val dir = Posix.FileSys.opendir dname
307
308 fun loop diffs =
309 case Posix.FileSys.readdir dir of
310 NONE => diffs
311 | SOME name =>
312 let
313 val fname = OS.Path.joinDirFile {dir = dname,
314 file = name}
315 in
316 loop (if Posix.FileSys.ST.isDir (Posix.FileSys.stat fname) then
317 let
318 val dom = String.fields (fn ch => ch = #"/") fname
319 val dom = List.drop (dom, len)
320 val dom = String.concatWith "." (rev dom)
321
322 val dname' = OS.Path.joinDirFile {dir = dname,
323 file = name}
324 in
325 explore (dname',
326 findDiffs (site, dom, diffs))
327 end
328 else
329 diffs)
330 end
331 in
332 loop diffs
333 before Posix.FileSys.closedir dir
334 end
335 in
336 explore (OS.Path.joinDirFile {dir = Config.tmpDir,
337 file = site}, diffs)
338 end
339 in
340 exploreSites []
341 before Posix.FileSys.closedir dir
342 end
343
344 val masterNode : string option ref = ref NONE
345 fun dnsMaster () = !masterNode
346
347 val _ = Env.containerV_one "domain"
348 ("domain", Env.string)
349 (fn (evs, dom) =>
350 let
351 val kind = Env.env dnsKind (evs, "DNS")
352 val ttl = Env.env Env.int (evs, "TTL")
353
354 val path = getPath dom
355
356 val () = (current := dom;
357 currentPath := (fn site => path (Config.tmpDir, site)))
358
359 fun saveSoa (kind, soa : soa) node =
360 let
361 val outf = domainFile {node = node, name = "soa"}
362 in
363 TextIO.output (outf, kind);
364 TextIO.output (outf, "\n");
365 TextIO.output (outf, Int.toString ttl);
366 TextIO.output (outf, "\n");
367 TextIO.output (outf, #ns soa);
368 TextIO.output (outf, "\n");
369 case #serial soa of
370 NONE => ()
371 | SOME n => TextIO.output (outf, Int.toString n);
372 TextIO.output (outf, "\n");
373 TextIO.output (outf, Int.toString (#ref soa));
374 TextIO.output (outf, "\n");
375 TextIO.output (outf, Int.toString (#ret soa));
376 TextIO.output (outf, "\n");
377 TextIO.output (outf, Int.toString (#exp soa));
378 TextIO.output (outf, "\n");
379 TextIO.output (outf, Int.toString (#min soa));
380 TextIO.output (outf, "\n");
381 TextIO.closeOut outf
382 end
383
384 fun saveNamed (kind, soa : soa, masterIp) node =
385 let
386 val outf = domainFile {node = node, name = "named.conf"}
387 in
388 TextIO.output (outf, "\nzone \"");
389 TextIO.output (outf, dom);
390 TextIO.output (outf, "\" IN {\n\ttype ");
391 TextIO.output (outf, kind);
392 TextIO.output (outf, ";\n\tfile \"");
393 TextIO.output (outf, Config.Bind.zonePath);
394 TextIO.output (outf, "/");
395 TextIO.output (outf, dom);
396 TextIO.output (outf, ".zone\";\n");
397 case kind of
398 "master" => TextIO.output (outf, "\tallow-update { none; };\n")
399 | _ => (TextIO.output (outf, "\tmasters { ");
400 TextIO.output (outf, masterIp);
401 TextIO.output (outf, " };\n"));
402 TextIO.output (outf, "};\n");
403 TextIO.closeOut outf
404 end
405 in
406 case kind of
407 NoDns => masterNode := NONE
408 | UseDns dns =>
409 let
410 val masterIp =
411 case #master dns of
412 InternalMaster node => valOf (SM.find (nodeMap, node))
413 | ExternalMaster ip => ip
414 in
415 app (saveSoa ("slave", #soa dns)) (#slaves dns);
416 app (saveNamed ("slave", #soa dns, masterIp)) (#slaves dns);
417 case #master dns of
418 InternalMaster node =>
419 (masterNode := SOME node;
420 saveSoa ("master", #soa dns) node;
421 saveNamed ("master", #soa dns, masterIp) node)
422 | _ => masterNode := NONE;
423 !befores dom
424 end
425 end,
426 fn () => !afters (!current))
427
428 val () = Env.registerPreTycheck (fn () => (setUser Config.testUser;
429 Acl.read Config.aclFile;
430 your_doms := Acl.class {user = getUser (),
431 class = "domain"}))
432
433 val () = Env.registerPre (fn () => (ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, ""],
434 fn cl => "Temp file cleanup failed: " ^ cl));
435 OS.FileSys.mkDir Config.tmpDir;
436 app (fn node => OS.FileSys.mkDir
437 (OS.Path.joinDirFile {dir = Config.tmpDir,
438 file = node}))
439 nodes;
440 app (fn node => OS.FileSys.mkDir
441 (OS.Path.joinDirFile {dir = Config.resultRoot,
442 file = node})
443 handle OS.SysErr _ => ())
444 nodes))
445
446 val () = Env.registerPost (fn () =>
447 let
448 val diffs = findAllDiffs ()
449
450 val diffs = map (fn (site, dom, dir, Add' {src, dst}) =>
451 (Slave.shellF ([Config.cp, " ", src, " ", dst],
452 fn cl => "Copy failed: " ^ cl);
453 (site,
454 {action = Slave.Add,
455 domain = dom,
456 dir = dir,
457 file = dst}))
458 | (site, dom, dir, Delete' dst) =>
459 (OS.FileSys.remove dst
460 handle OS.SysErr _ =>
461 ErrorMsg.error NONE ("Delete failed for " ^ dst);
462 (site,
463 {action = Slave.Delete,
464 domain = dom,
465 dir = dir,
466 file = dst}))
467 | (site, dom, dir, Modify' {src, dst}) =>
468 (Slave.shellF ([Config.cp, " ", src, " ", dst],
469 fn cl => "Copy failed: " ^ cl);
470 (site,
471 {action = Slave.Modify,
472 domain = dom,
473 dir = dir,
474 file = dst}))) diffs
475 in
476 if !ErrorMsg.anyErrors then
477 ()
478 else
479 Slave.handleChanges (map #2 diffs)(*;
480 ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, ""],
481 fn cl => "Temp file cleanup failed: " ^ cl))*)
482 end)
483
484
485
486 end