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