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