URL handling
[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
8a7c40fa 29fun nodeIp node = valOf (SM.find (nodeMap, node))
2ed6d0e5 30
12adf55a
AC
31val usr = ref ""
32fun setUser ur = usr := ur
33fun getUser () = !usr
34
35val your_doms = ref SS.empty
36fun your_domains () = !your_doms
37
8a7c40fa
AC
38val your_usrs = ref SS.empty
39fun your_users () = !your_usrs
40
41val your_grps = ref SS.empty
42fun your_groups () = !your_grps
43
44val your_pths = ref SS.empty
45fun your_paths () = !your_pths
46
6ae327f8
AC
47fun 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
629a34f6
AC
53fun isIdent ch = Char.isLower ch orelse Char.isDigit ch
54
55fun validHost s =
56 size s > 0 andalso size s < 20
57 andalso CharVector.all (fn ch => isIdent ch orelse ch = #"-") s
58
59fun validDomain s =
60 size s > 0 andalso size s < 100
61 andalso List.all validHost (String.fields (fn ch => ch = #".") s)
62
2ed6d0e5 63fun validNode s = List.exists (fn s' => s = s') nodes
e0b0abd2 64
12adf55a 65fun yourDomain s = SS.member (your_domains (), s)
8a7c40fa
AC
66fun yourUser s = SS.member (your_users (), s)
67fun yourGroup s = SS.member (your_groups (), s)
68fun 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 ())
12adf55a 73
f8dfbbcc
AC
74val _ = Env.type_one "no_spaces"
75 Env.string
76 (CharVector.all (fn ch => not (Char.isSpace ch)))
d5754b53
AC
77val _ = Env.type_one "no_newlines"
78 Env.string
79 (CharVector.all (fn ch => ch <> #"\n" andalso ch <> #"\r"))
f8dfbbcc 80
6ae327f8
AC
81val _ = Env.type_one "ip"
82 Env.string
83 validIp
84
629a34f6
AC
85val _ = Env.type_one "host"
86 Env.string
87 validHost
88
89val _ = Env.type_one "domain"
90 Env.string
91 validDomain
92
12adf55a
AC
93val _ = Env.type_one "your_domain"
94 Env.string
95 yourDomain
96
8a7c40fa
AC
97val _ = Env.type_one "your_user"
98 Env.string
99 yourUser
100
101val _ = Env.type_one "your_group"
102 Env.string
103 yourGroup
104
105val _ = Env.type_one "your_path"
106 Env.string
107 yourPath
108
e0b0abd2
AC
109val _ = Env.type_one "node"
110 Env.string
111 validNode
112
a3698041
AC
113open Ast
114
6ae327f8
AC
115val dl = ErrorMsg.dummyLoc
116
117val nsD = (EString Config.defaultNs, dl)
118val serialD = (EVar "serialAuto", dl)
119val refD = (EInt Config.defaultRefresh, dl)
120val retD = (EInt Config.defaultRetry, dl)
121val expD = (EInt Config.defaultExpiry, dl)
122val minD = (EInt Config.defaultMinimum, dl)
123
124val soaD = multiApp ((EVar "soa", dl),
125 dl,
126 [nsD, serialD, refD, retD, expD, minD])
127
e0b0abd2
AC
128val masterD = (EApp ((EVar "internalMaster", dl),
129 (EString Config.defaultNode, dl)),
130 dl)
131
6ae327f8
AC
132val _ = Main.registerDefault ("DNS",
133 (TBase "dnsKind", dl),
8a7c40fa 134 (fn () => multiApp ((EVar "useDns", dl),
e0b0abd2
AC
135 dl,
136 [soaD, masterD, (EList [], dl)])))
6ae327f8
AC
137
138val _ = Main.registerDefault ("TTL",
139 (TBase "int", dl),
8a7c40fa 140 (fn () => (EInt Config.Bind.defaultTTL, dl)))
6ae327f8
AC
141
142type soa = {ns : string,
143 serial : int option,
144 ref : int,
145 ret : int,
146 exp : int,
147 min : int}
148
149val serial = fn (EVar "serialAuto", _) => SOME NONE
150 | (EApp ((EVar "serialConst", _), n), _) => Option.map SOME (Env.int n)
151 | _ => NONE
152
153val 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
e0b0abd2
AC
173datatype master =
174 ExternalMaster of string
175 | InternalMaster of string
176
177val 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
6ae327f8 181datatype dnsKind =
e0b0abd2
AC
182 UseDns of {soa : soa,
183 master : master,
184 slaves : string list}
6ae327f8
AC
185 | NoDns
186
e0b0abd2
AC
187val 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)
6ae327f8
AC
197 | _ => NONE
198
a3698041
AC
199val befores = ref (fn (_ : string) => ())
200val afters = ref (fn (_ : string) => ())
201
202fun registerBefore f =
203 let
204 val old = !befores
205 in
206 befores := (fn x => (old x; f x))
207 end
208
209fun registerAfter f =
210 let
211 val old = !afters
212 in
213 afters := (fn x => (old x; f x))
214 end
215
216val current = ref ""
e0b0abd2 217val currentPath = ref (fn (_ : string) => "")
dac62e84 218
d612d62c
AC
219val scratch = ref ""
220
dac62e84
AC
221fun currentDomain () = !current
222
e0b0abd2
AC
223fun domainFile {node, name} = ((*print ("Opening " ^ !currentPath node ^ name ^ "\n");*)
224 TextIO.openOut (!currentPath node ^ name))
dac62e84
AC
225
226fun 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
d612d62c 233
e0b0abd2
AC
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
2ed6d0e5 258 app doNode nodes;
dac62e84
AC
259 elems
260 end) [] toks
261 in
e0b0abd2 262 fn (root, site) => String.concatWith "/" (root :: site :: rev ("" :: elems))
d612d62c
AC
263 end
264
265datatype file_action' =
266 Add' of {src : string, dst : string}
267 | Delete' of string
268 | Modify' of {src : string, dst : string}
269
e0b0abd2 270fun findDiffs (site, dom, acts) =
d612d62c 271 let
e0b0abd2
AC
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")*)
d612d62c
AC
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
8df2e702 294 if Slave.shell [Config.diff, " ", real, " ", tmp] then
d612d62c
AC
295 loopReal acts
296 else
e0b0abd2 297 loopReal ((site, dom, realPath, Modify' {src = tmp, dst = real}) :: acts)
d612d62c 298 else
e0b0abd2 299 loopReal ((site, dom, realPath, Delete' real) :: acts)
d612d62c
AC
300 end
301
e0b0abd2 302 val acts = loopReal acts
d612d62c 303
8df2e702 304 val dir = Posix.FileSys.opendir tmpPath
d612d62c
AC
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
e0b0abd2 322 loopTmp ((site, dom, realPath, Add' {src = tmp, dst = real}) :: acts)
d612d62c
AC
323 end
324
325 val acts = loopTmp acts
326 in
327 acts
dac62e84 328 end
a3698041 329
e0b0abd2
AC
330fun 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
380val masterNode : string option ref = ref NONE
381fun dnsMaster () = !masterNode
382
6ae327f8
AC
383val _ = 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
e0b0abd2 390 val path = getPath dom
6ae327f8
AC
391
392 val () = (current := dom;
e0b0abd2 393 currentPath := (fn site => path (Config.tmpDir, site)))
6ae327f8 394
e0b0abd2 395 fun saveSoa (kind, soa : soa) node =
6ae327f8 396 let
e0b0abd2 397 val outf = domainFile {node = node, name = "soa"}
6ae327f8
AC
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
2ed6d0e5 420 fun saveNamed (kind, soa : soa, masterIp) node =
6ae327f8 421 let
e0b0abd2 422 val outf = domainFile {node = node, name = "named.conf"}
6ae327f8
AC
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")
2ed6d0e5
AC
435 | _ => (TextIO.output (outf, "\tmasters { ");
436 TextIO.output (outf, masterIp);
437 TextIO.output (outf, " };\n"));
438 TextIO.output (outf, "};\n");
6ae327f8
AC
439 TextIO.closeOut outf
440 end
6ae327f8
AC
441 in
442 case kind of
e0b0abd2
AC
443 NoDns => masterNode := NONE
444 | UseDns dns =>
2ed6d0e5
AC
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
6ae327f8 461 end,
e0b0abd2
AC
462 fn () => !afters (!current))
463
12adf55a
AC
464val () = Env.registerPreTycheck (fn () => (setUser Config.testUser;
465 Acl.read Config.aclFile;
466 your_doms := Acl.class {user = getUser (),
8a7c40fa
AC
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"}))
12adf55a 474
e0b0abd2
AC
475val () = 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}))
2ed6d0e5 481 nodes;
e0b0abd2
AC
482 app (fn node => OS.FileSys.mkDir
483 (OS.Path.joinDirFile {dir = Config.resultRoot,
484 file = node})
485 handle OS.SysErr _ => ())
2ed6d0e5 486 nodes))
e0b0abd2
AC
487
488val () = Env.registerPost (fn () =>
489 let
490 val diffs = findAllDiffs ()
6ae327f8 491
e0b0abd2
AC
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,
6ae327f8
AC
496 {action = Slave.Add,
497 domain = dom,
498 dir = dir,
e0b0abd2
AC
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,
6ae327f8
AC
505 {action = Slave.Delete,
506 domain = dom,
507 dir = dir,
e0b0abd2
AC
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,
6ae327f8
AC
513 {action = Slave.Modify,
514 domain = dom,
515 dir = dir,
e0b0abd2
AC
516 file = dst}))) diffs
517 in
518 if !ErrorMsg.anyErrors then
519 ()
520 else
12adf55a 521 Slave.handleChanges (map #2 diffs)(*;
e0b0abd2 522 ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, ""],
12adf55a 523 fn cl => "Temp file cleanup failed: " ^ cl))*)
e0b0abd2 524 end)
6ae327f8
AC
525
526
a3698041
AC
527
528end