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