ACLs
[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
2ed6d0e5 23structure SM = DataStructures.StringMap
12adf55a 24structure SS = DataStructures.StringSet
2ed6d0e5 25
12adf55a 26val nodes = map #1 Config.nodeIps
2ed6d0e5
AC
27val nodeMap = foldl (fn ((node, ip), mp) => SM.insert (mp, node, ip))
28 SM.empty Config.nodeIps
29
12adf55a
AC
30val usr = ref ""
31fun setUser ur = usr := ur
32fun getUser () = !usr
33
34val your_doms = ref SS.empty
35fun your_domains () = !your_doms
36
6ae327f8
AC
37fun 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
629a34f6
AC
43fun isIdent ch = Char.isLower ch orelse Char.isDigit ch
44
45fun validHost s =
46 size s > 0 andalso size s < 20
47 andalso CharVector.all (fn ch => isIdent ch orelse ch = #"-") s
48
49fun validDomain s =
50 size s > 0 andalso size s < 100
51 andalso List.all validHost (String.fields (fn ch => ch = #".") s)
52
2ed6d0e5 53fun validNode s = List.exists (fn s' => s = s') nodes
e0b0abd2 54
12adf55a
AC
55fun yourDomain s = SS.member (your_domains (), s)
56
6ae327f8
AC
57val _ = Env.type_one "ip"
58 Env.string
59 validIp
60
629a34f6
AC
61val _ = Env.type_one "host"
62 Env.string
63 validHost
64
65val _ = Env.type_one "domain"
66 Env.string
67 validDomain
68
12adf55a
AC
69val _ = Env.type_one "your_domain"
70 Env.string
71 yourDomain
72
e0b0abd2
AC
73val _ = Env.type_one "node"
74 Env.string
75 validNode
76
a3698041
AC
77open Ast
78
6ae327f8
AC
79val dl = ErrorMsg.dummyLoc
80
81val nsD = (EString Config.defaultNs, dl)
82val serialD = (EVar "serialAuto", dl)
83val refD = (EInt Config.defaultRefresh, dl)
84val retD = (EInt Config.defaultRetry, dl)
85val expD = (EInt Config.defaultExpiry, dl)
86val minD = (EInt Config.defaultMinimum, dl)
87
88val soaD = multiApp ((EVar "soa", dl),
89 dl,
90 [nsD, serialD, refD, retD, expD, minD])
91
e0b0abd2
AC
92val masterD = (EApp ((EVar "internalMaster", dl),
93 (EString Config.defaultNode, dl)),
94 dl)
95
6ae327f8
AC
96val _ = Main.registerDefault ("DNS",
97 (TBase "dnsKind", dl),
e0b0abd2
AC
98 (multiApp ((EVar "useDns", dl),
99 dl,
100 [soaD, masterD, (EList [], dl)])))
6ae327f8
AC
101
102val _ = Main.registerDefault ("TTL",
103 (TBase "int", dl),
104 (EInt Config.Bind.defaultTTL, dl))
105
106type soa = {ns : string,
107 serial : int option,
108 ref : int,
109 ret : int,
110 exp : int,
111 min : int}
112
113val serial = fn (EVar "serialAuto", _) => SOME NONE
114 | (EApp ((EVar "serialConst", _), n), _) => Option.map SOME (Env.int n)
115 | _ => NONE
116
117val 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
e0b0abd2
AC
137datatype master =
138 ExternalMaster of string
139 | InternalMaster of string
140
141val 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
6ae327f8 145datatype dnsKind =
e0b0abd2
AC
146 UseDns of {soa : soa,
147 master : master,
148 slaves : string list}
6ae327f8
AC
149 | NoDns
150
e0b0abd2
AC
151val 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)
6ae327f8
AC
161 | _ => NONE
162
a3698041
AC
163val befores = ref (fn (_ : string) => ())
164val afters = ref (fn (_ : string) => ())
165
166fun registerBefore f =
167 let
168 val old = !befores
169 in
170 befores := (fn x => (old x; f x))
171 end
172
173fun registerAfter f =
174 let
175 val old = !afters
176 in
177 afters := (fn x => (old x; f x))
178 end
179
180val current = ref ""
e0b0abd2 181val currentPath = ref (fn (_ : string) => "")
dac62e84 182
d612d62c
AC
183val scratch = ref ""
184
dac62e84
AC
185fun currentDomain () = !current
186
e0b0abd2
AC
187fun domainFile {node, name} = ((*print ("Opening " ^ !currentPath node ^ name ^ "\n");*)
188 TextIO.openOut (!currentPath node ^ name))
dac62e84
AC
189
190fun 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
d612d62c 197
e0b0abd2
AC
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
2ed6d0e5 222 app doNode nodes;
dac62e84
AC
223 elems
224 end) [] toks
225 in
e0b0abd2 226 fn (root, site) => String.concatWith "/" (root :: site :: rev ("" :: elems))
d612d62c
AC
227 end
228
229datatype file_action' =
230 Add' of {src : string, dst : string}
231 | Delete' of string
232 | Modify' of {src : string, dst : string}
233
e0b0abd2 234fun findDiffs (site, dom, acts) =
d612d62c 235 let
e0b0abd2
AC
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")*)
d612d62c
AC
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
8df2e702 258 if Slave.shell [Config.diff, " ", real, " ", tmp] then
d612d62c
AC
259 loopReal acts
260 else
e0b0abd2 261 loopReal ((site, dom, realPath, Modify' {src = tmp, dst = real}) :: acts)
d612d62c 262 else
e0b0abd2 263 loopReal ((site, dom, realPath, Delete' real) :: acts)
d612d62c
AC
264 end
265
e0b0abd2 266 val acts = loopReal acts
d612d62c 267
8df2e702 268 val dir = Posix.FileSys.opendir tmpPath
d612d62c
AC
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
e0b0abd2 286 loopTmp ((site, dom, realPath, Add' {src = tmp, dst = real}) :: acts)
d612d62c
AC
287 end
288
289 val acts = loopTmp acts
290 in
291 acts
dac62e84 292 end
a3698041 293
e0b0abd2
AC
294fun 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
344val masterNode : string option ref = ref NONE
345fun dnsMaster () = !masterNode
346
6ae327f8
AC
347val _ = 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
e0b0abd2 354 val path = getPath dom
6ae327f8
AC
355
356 val () = (current := dom;
e0b0abd2 357 currentPath := (fn site => path (Config.tmpDir, site)))
6ae327f8 358
e0b0abd2 359 fun saveSoa (kind, soa : soa) node =
6ae327f8 360 let
e0b0abd2 361 val outf = domainFile {node = node, name = "soa"}
6ae327f8
AC
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
2ed6d0e5 384 fun saveNamed (kind, soa : soa, masterIp) node =
6ae327f8 385 let
e0b0abd2 386 val outf = domainFile {node = node, name = "named.conf"}
6ae327f8
AC
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")
2ed6d0e5
AC
399 | _ => (TextIO.output (outf, "\tmasters { ");
400 TextIO.output (outf, masterIp);
401 TextIO.output (outf, " };\n"));
402 TextIO.output (outf, "};\n");
6ae327f8
AC
403 TextIO.closeOut outf
404 end
6ae327f8
AC
405 in
406 case kind of
e0b0abd2
AC
407 NoDns => masterNode := NONE
408 | UseDns dns =>
2ed6d0e5
AC
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
6ae327f8 425 end,
e0b0abd2
AC
426 fn () => !afters (!current))
427
12adf55a
AC
428val () = Env.registerPreTycheck (fn () => (setUser Config.testUser;
429 Acl.read Config.aclFile;
430 your_doms := Acl.class {user = getUser (),
431 class = "domain"}))
432
e0b0abd2
AC
433val () = 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}))
2ed6d0e5 439 nodes;
e0b0abd2
AC
440 app (fn node => OS.FileSys.mkDir
441 (OS.Path.joinDirFile {dir = Config.resultRoot,
442 file = node})
443 handle OS.SysErr _ => ())
2ed6d0e5 444 nodes))
e0b0abd2
AC
445
446val () = Env.registerPost (fn () =>
447 let
448 val diffs = findAllDiffs ()
6ae327f8 449
e0b0abd2
AC
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,
6ae327f8
AC
454 {action = Slave.Add,
455 domain = dom,
456 dir = dir,
e0b0abd2
AC
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,
6ae327f8
AC
463 {action = Slave.Delete,
464 domain = dom,
465 dir = dir,
e0b0abd2
AC
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,
6ae327f8
AC
471 {action = Slave.Modify,
472 domain = dom,
473 dir = dir,
e0b0abd2
AC
474 file = dst}))) diffs
475 in
476 if !ErrorMsg.anyErrors then
477 ()
478 else
12adf55a 479 Slave.handleChanges (map #2 diffs)(*;
e0b0abd2 480 ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, ""],
12adf55a 481 fn cl => "Temp file cleanup failed: " ^ cl))*)
e0b0abd2 482 end)
6ae327f8
AC
483
484
a3698041
AC
485
486end