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