HCoop / hcoop / domtool2.git / blame_incremental
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (non-incremental) | history | HEAD
Make 'domtool -tc' (no other arguments) work properly
[hcoop/domtool2.git] / src / domain.sml
... / ...
CommitLineData
1(* HCoop Domtool (http://hcoop.sourceforge.net/)
2 * Copyright (c) 2006-2007, 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
21structure Domain :> DOMAIN = struct
22
23open MsgTypes
24
25structure SM = DataStructures.StringMap
26structure SS = DataStructures.StringSet
27
28val ssl_context = ref (NONE : OpenSSL.context option)
29fun set_context ctx = ssl_context := SOME ctx
30
31val nodes = map #1 Config.nodeIps
32val nodeMap = foldl (fn ((node, ip), mp) => SM.insert (mp, node, ip))
33 SM.empty Config.nodeIps
34fun nodeIp node = valOf (SM.find (nodeMap, node))
35
36val usr = ref ""
37fun getUser () = !usr
38
39val your_doms = ref SS.empty
40fun your_domains () = !your_doms
41
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
51val world_readable = SS.addList (SS.empty, Config.worldReadable)
52val readable_pths = ref SS.empty
53fun readable_paths () = !readable_pths
54
55fun setUser user =
56 let
57 val () = usr := user
58
59 val your_paths = Acl.class {user = getUser (),
60 class = "path"}
61 in
62 your_doms := Acl.class {user = getUser (),
63 class = "domain"};
64 your_usrs := Acl.class {user = getUser (),
65 class = "user"};
66 your_grps := Acl.class {user = getUser (),
67 class = "group"};
68 your_pths := your_paths;
69 readable_pths := SS.union (your_paths, world_readable)
70 end
71
72fun validIp s =
73 case map Int.fromString (String.fields (fn ch => ch = #".") s) of
74 [SOME n1, SOME n2, SOME n3, SOME n4] =>
75 n1 >= 0 andalso n1 < 256 andalso n2 >= 0 andalso n2 < 256 andalso n3 >= 0 andalso n3 < 256 andalso n4 >= 0 andalso n4 < 256
76 | _ => false
77
78fun isIdent ch = Char.isLower ch orelse Char.isDigit ch
79
80fun validHost s =
81 size s > 0 andalso size s < 20
82 andalso CharVector.all (fn ch => isIdent ch orelse ch = #"-") s
83
84fun validDomain s =
85 size s > 0 andalso size s < 100
86 andalso List.all validHost (String.fields (fn ch => ch = #".") s)
87
88fun validNode s = List.exists (fn s' => s = s') nodes
89
90fun yourDomain s = SS.member (your_domains (), s)
91fun yourUser s = SS.member (your_users (), s)
92fun yourGroup s = SS.member (your_groups (), s)
93fun checkPath paths path =
94 List.all (fn s => s <> "..") (String.fields (fn ch => ch = #"/") path)
95 andalso CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"." orelse ch = #"/"
96 orelse ch = #"-" orelse ch = #"_") path
97 andalso SS.exists (fn s' => path = s' orelse String.isPrefix (s' ^ "/") path) (paths ())
98val yourPath = checkPath your_paths
99val readablePath = checkPath readable_paths
100
101fun yourDomainHost s =
102 yourDomain s
103 orelse let
104 val (pref, suf) = Substring.splitl (fn ch => ch <> #".") (Substring.full s)
105 in
106 Substring.size suf > 0
107 andalso validHost (Substring.string pref)
108 andalso yourDomain (Substring.string
109 (Substring.slice (suf, 1, NONE)))
110 end
111
112val yourDomain = yourDomainHost
113
114fun validUser s = size s > 0 andalso size s < 20
115 andalso CharVector.all Char.isAlphaNum s
116
117fun validEmailUser s =
118 size s > 0 andalso size s < 50
119 andalso CharVector.all (fn ch => Char.isAlphaNum ch
120 orelse ch = #"."
121 orelse ch = #"_"
122 orelse ch = #"-"
123 orelse ch = #"+") s
124
125val validGroup = validUser
126
127val _ = Env.type_one "no_spaces"
128 Env.string
129 (CharVector.all (fn ch => Char.isPrint ch andalso not (Char.isSpace ch)
130 andalso ch <> #"\"" andalso ch <> #"'"))
131val _ = Env.type_one "no_newlines"
132 Env.string
133 (CharVector.all (fn ch => Char.isPrint ch andalso ch <> #"\n" andalso ch <> #"\r"
134 andalso ch <> #"\"" andalso ch <> #"'"))
135
136val _ = Env.type_one "ip"
137 Env.string
138 validIp
139
140val _ = Env.type_one "host"
141 Env.string
142 validHost
143
144val _ = Env.type_one "domain"
145 Env.string
146 validDomain
147
148val _ = Env.type_one "your_domain"
149 Env.string
150 yourDomain
151
152val _ = Env.type_one "your_domain_host"
153 Env.string
154 yourDomainHost
155
156val _ = Env.type_one "user"
157 Env.string
158 validUser
159
160val _ = Env.type_one "group"
161 Env.string
162 validGroup
163
164val _ = Env.type_one "your_user"
165 Env.string
166 yourUser
167
168val _ = Env.type_one "your_group"
169 Env.string
170 yourGroup
171
172val _ = Env.type_one "your_path"
173 Env.string
174 yourPath
175
176val _ = Env.type_one "readable_path"
177 Env.string
178 readablePath
179
180val _ = Env.type_one "node"
181 Env.string
182 validNode
183
184val _ = Env.registerFunction ("dns_node_to_node",
185 fn [e] => SOME e
186 | _ => NONE)
187
188val _ = Env.registerFunction ("mail_node_to_node",
189 fn [e] => SOME e
190 | _ => NONE)
191open Ast
192
193val dl = ErrorMsg.dummyLoc
194
195val nsD = (EString Config.defaultNs, dl)
196val serialD = (EVar "serialAuto", dl)
197val refD = (EInt Config.defaultRefresh, dl)
198val retD = (EInt Config.defaultRetry, dl)
199val expD = (EInt Config.defaultExpiry, dl)
200val minD = (EInt Config.defaultMinimum, dl)
201
202val soaD = multiApp ((EVar "soa", dl),
203 dl,
204 [nsD, serialD, refD, retD, expD, minD])
205
206val masterD = (EApp ((EVar "internalMaster", dl),
207 (EString Config.masterNode, dl)),
208 dl)
209
210val slavesD = (EList (map (fn s => (EString s, dl)) Config.slaveNodes), dl)
211
212val _ = Defaults.registerDefault ("Aliases",
213 (TList (TBase "your_domain", dl), dl),
214 (fn () => (EList [], dl)))
215
216val _ = Defaults.registerDefault ("Mailbox",
217 (TBase "email", dl),
218 (fn () => (EString (getUser ()), dl)))
219
220val _ = Defaults.registerDefault ("DNS",
221 (TBase "dnsKind", dl),
222 (fn () => multiApp ((EVar "useDns", dl),
223 dl,
224 [soaD, masterD, slavesD])))
225
226val _ = Defaults.registerDefault ("TTL",
227 (TBase "int", dl),
228 (fn () => (EInt Config.Bind.defaultTTL, dl)))
229
230type soa = {ns : string,
231 serial : int option,
232 ref : int,
233 ret : int,
234 exp : int,
235 min : int}
236
237val serial = fn (EVar "serialAuto", _) => SOME NONE
238 | (EApp ((EVar "serialConst", _), n), _) => Option.map SOME (Env.int n)
239 | _ => NONE
240
241val soa = fn (EApp ((EApp ((EApp ((EApp ((EApp ((EApp
242 ((EVar "soa", _), ns), _),
243 sl), _),
244 rf), _),
245 ret), _),
246 exp), _),
247 min), _) =>
248 (case (Env.string ns, serial sl, Env.int rf,
249 Env.int ret, Env.int exp, Env.int min) of
250 (SOME ns, SOME sl, SOME rf,
251 SOME ret, SOME exp, SOME min) =>
252 SOME {ns = ns,
253 serial = sl,
254 ref = rf,
255 ret = ret,
256 exp = exp,
257 min = min}
258 | _ => NONE)
259 | _ => NONE
260
261datatype master =
262 ExternalMaster of string
263 | InternalMaster of string
264
265val ip = Env.string
266
267val _ = Env.registerFunction ("ip_of_node",
268 fn [(EString node, _)] => SOME (EString (nodeIp node), dl)
269 | _ => NONE)
270
271val master = fn (EApp ((EVar "externalMaster", _), e), _) => Option.map ExternalMaster (ip e)
272 | (EApp ((EVar "internalMaster", _), e), _) => Option.map InternalMaster (Env.string e)
273 | _ => NONE
274
275datatype dnsKind =
276 UseDns of {soa : soa,
277 master : master,
278 slaves : string list}
279 | NoDns
280
281val dnsKind = fn (EApp ((EApp ((EApp
282 ((EVar "useDns", _), sa), _),
283 mstr), _),
284 slaves), _) =>
285 (case (soa sa, master mstr, Env.list Env.string slaves) of
286 (SOME sa, SOME mstr, SOME slaves) =>
287 SOME (UseDns {soa = sa,
288 master = mstr,
289 slaves = slaves})
290 | _ => NONE)
291 | (EVar "noDns", _) => SOME NoDns
292 | _ => NONE
293
294val befores = ref (fn (_ : string) => ())
295val afters = ref (fn (_ : string) => ())
296
297fun registerBefore f =
298 let
299 val old = !befores
300 in
301 befores := (fn x => (old x; f x))
302 end
303
304fun registerAfter f =
305 let
306 val old = !afters
307 in
308 afters := (fn x => (old x; f x))
309 end
310
311val globals = ref (fn () => ())
312val locals = ref (fn () => ())
313
314fun registerResetGlobal f =
315 let
316 val old = !globals
317 in
318 globals := (fn x => (old x; f x))
319 end
320
321fun registerResetLocal f =
322 let
323 val old = !locals
324 in
325 locals := (fn x => (old x; f x))
326 end
327
328fun resetGlobal () = (!globals ();
329 ignore (OS.Process.system (Config.rm ^ " -rf " ^ Config.resultRoot ^ "/*")))
330fun resetLocal () = !locals ()
331
332val current = ref ""
333val currentPath = ref (fn (_ : string) => "")
334val currentPathAli = ref (fn (_ : string, _ : string) => "")
335
336val scratch = ref ""
337
338fun currentDomain () = !current
339
340val currentsAli = ref ([] : string list)
341
342fun currentAliasDomains () = !currentsAli
343fun currentDomains () = currentDomain () :: currentAliasDomains ()
344
345fun domainFile {node, name} = ((*print ("Opening " ^ !currentPath node ^ name ^ "\n");*)
346 TextIO.openOut (!currentPath node ^ name))
347
348type files = {write : string -> unit,
349 writeDom : unit -> unit,
350 close : unit -> unit}
351
352fun domainsFile {node, name} =
353 let
354 val doms = currentDomains ()
355 val files = map (fn dom => (dom, TextIO.openOut (!currentPathAli (dom, node) ^ name))) doms
356 in
357 {write = fn s => app (fn (_, outf) => TextIO.output (outf, s)) files,
358 writeDom = fn () => app (fn (dom, outf) => TextIO.output (outf, dom)) files,
359 close = fn () => app (fn (_, outf) => TextIO.closeOut outf) files}
360 end
361
362fun getPath domain =
363 let
364 val toks = String.fields (fn ch => ch = #".") domain
365
366 val elems = foldr (fn (piece, elems) =>
367 let
368 val elems = piece :: elems
369
370 fun doNode node =
371 let
372 val path = String.concatWith "/"
373 (Config.resultRoot :: node :: rev elems)
374 val tmpPath = String.concatWith "/"
375 (Config.tmpDir :: node :: rev elems)
376 in
377 (if Posix.FileSys.ST.isDir
378 (Posix.FileSys.stat path) then
379 ()
380 else
381 (OS.FileSys.remove path;
382 OS.FileSys.mkDir path))
383 handle OS.SysErr _ => OS.FileSys.mkDir path;
384
385 (if Posix.FileSys.ST.isDir
386 (Posix.FileSys.stat tmpPath) then
387 ()
388 else
389 (OS.FileSys.remove tmpPath;
390 OS.FileSys.mkDir tmpPath))
391 handle OS.SysErr _ => OS.FileSys.mkDir tmpPath
392 end
393 in
394 app doNode nodes;
395 elems
396 end) [] toks
397 in
398 fn (root, site) => String.concatWith "/" (root :: site :: rev ("" :: elems))
399 end
400
401datatype file_action' =
402 Add' of {src : string, dst : string}
403 | Delete' of string
404 | Modify' of {src : string, dst : string}
405
406fun findDiffs (site, dom, acts) =
407 let
408 val gp = getPath dom
409 val realPath = gp (Config.resultRoot, site)
410 val tmpPath = gp (Config.tmpDir, site)
411
412 (*val _ = print ("getDiffs(" ^ site ^ ", " ^ dom ^ ")... " ^ realPath ^ "; " ^ tmpPath ^ "\n")*)
413
414 val dir = Posix.FileSys.opendir realPath
415
416 fun loopReal acts =
417 case Posix.FileSys.readdir dir of
418 NONE => (Posix.FileSys.closedir dir;
419 acts)
420 | SOME fname =>
421 let
422 val real = OS.Path.joinDirFile {dir = realPath,
423 file = fname}
424 val tmp = OS.Path.joinDirFile {dir = tmpPath,
425 file = fname}
426 in
427 if Posix.FileSys.ST.isDir (Posix.FileSys.stat real) then
428 loopReal acts
429 else if Posix.FileSys.access (tmp, []) then
430 if Slave.shell [Config.diff, " ", real, " ", tmp] then
431 loopReal acts
432 else
433 loopReal ((site, dom, realPath, Modify' {src = tmp, dst = real}) :: acts)
434 else
435 loopReal ((site, dom, realPath, Delete' real) :: acts)
436 end
437
438 val acts = loopReal acts
439
440 val dir = Posix.FileSys.opendir tmpPath
441
442 fun loopTmp acts =
443 case Posix.FileSys.readdir dir of
444 NONE => (Posix.FileSys.closedir dir;
445 acts)
446 | SOME fname =>
447 let
448 val real = OS.Path.joinDirFile {dir = realPath,
449 file = fname}
450 val tmp = OS.Path.joinDirFile {dir = tmpPath,
451 file = fname}
452 in
453 if Posix.FileSys.ST.isDir (Posix.FileSys.stat tmp) then
454 loopTmp acts
455 else if Posix.FileSys.access (real, []) then
456 loopTmp acts
457 else
458 loopTmp ((site, dom, realPath, Add' {src = tmp, dst = real}) :: acts)
459 end
460
461 val acts = loopTmp acts
462 in
463 acts
464 end
465
466fun findAllDiffs () =
467 let
468 val dir = Posix.FileSys.opendir Config.tmpDir
469 val len = length (String.fields (fn ch => ch = #"/") Config.tmpDir) + 1
470
471 fun exploreSites diffs =
472 case Posix.FileSys.readdir dir of
473 NONE => diffs
474 | SOME site =>
475 let
476 fun explore (dname, diffs) =
477 let
478 val dir = Posix.FileSys.opendir dname
479
480 fun loop diffs =
481 case Posix.FileSys.readdir dir of
482 NONE => diffs
483 | SOME name =>
484 let
485 val fname = OS.Path.joinDirFile {dir = dname,
486 file = name}
487 in
488 loop (if Posix.FileSys.ST.isDir (Posix.FileSys.stat fname) then
489 let
490 val dom = String.fields (fn ch => ch = #"/") fname
491 val dom = List.drop (dom, len)
492 val dom = String.concatWith "." (rev dom)
493
494 val dname' = OS.Path.joinDirFile {dir = dname,
495 file = name}
496 in
497 explore (dname',
498 findDiffs (site, dom, diffs))
499 end
500 else
501 diffs)
502 end
503 in
504 loop diffs
505 before Posix.FileSys.closedir dir
506 end
507 in
508 exploreSites (explore (OS.Path.joinDirFile {dir = Config.tmpDir,
509 file = site}, diffs))
510 end
511 in
512 exploreSites []
513 before Posix.FileSys.closedir dir
514 end
515
516val masterNode : string option ref = ref NONE
517fun dnsMaster () = !masterNode
518
519val _ = Env.containerV_one "domain"
520 ("domain", Env.string)
521 (fn (evs, dom) =>
522 let
523 val kind = Env.env dnsKind (evs, "DNS")
524 val ttl = Env.env Env.int (evs, "TTL")
525 val aliases = Env.env (Env.list Env.string) (evs, "Aliases")
526
527 val path = getPath dom
528
529 val () = (current := dom;
530 currentsAli := Slave.remove (Slave.removeDups aliases, dom);
531 currentPath := (fn site => path (Config.tmpDir, site));
532 currentPathAli := (fn (dom, site) => getPath dom (Config.tmpDir, site)))
533
534 fun saveSoa (kind, soa : soa) node =
535 let
536 val {write, writeDom, close} = domainsFile {node = node, name = "soa"}
537 in
538 write kind;
539 write "\n";
540 write (Int.toString ttl);
541 write "\n";
542 write (#ns soa);
543 write "\n";
544 case #serial soa of
545 NONE => ()
546 | SOME n => write (Int.toString n);
547 write "\n";
548 write (Int.toString (#ref soa));
549 write "\n";
550 write (Int.toString (#ret soa));
551 write "\n";
552 write (Int.toString (#exp soa));
553 write "\n";
554 write (Int.toString (#min soa));
555 write "\n";
556 close ()
557 end
558
559 fun saveNamed (kind, soa : soa, masterIp, slaveIps) node =
560 if dom = "localhost" then
561 ()
562 else let
563 val {write, writeDom, close} = domainsFile {node = node, name = "named.conf"}
564 in
565 write "\nzone \"";
566 writeDom ();
567 write "\" {\n\ttype ";
568 write kind;
569 write ";\n\tfile \"";
570 write Config.Bind.zonePath_real;
571 write "/";
572 writeDom ();
573 write ".zone\";\n";
574 case kind of
575 "master" => (write "\tallow-transfer {\n";
576 app (fn ip => (write "\t\t";
577 write ip;
578 write ";\n")) slaveIps;
579 write "\t};\n")
580 | _ => (write "\tmasters { ";
581 write masterIp;
582 write "; };\n");
583 write "};\n";
584 close ()
585 end
586 in
587 case kind of
588 NoDns => masterNode := NONE
589 | UseDns dns =>
590 let
591 val masterIp =
592 case #master dns of
593 InternalMaster node => nodeIp node
594 | ExternalMaster ip => ip
595
596 val slaveIps = map nodeIp (#slaves dns)
597 in
598 app (saveSoa ("slave", #soa dns)) (#slaves dns);
599 app (saveNamed ("slave", #soa dns, masterIp, slaveIps)) (#slaves dns);
600 case #master dns of
601 InternalMaster node =>
602 (masterNode := SOME node;
603 saveSoa ("master", #soa dns) node;
604 saveNamed ("master", #soa dns, masterIp, slaveIps) node)
605 | _ => masterNode := NONE
606 end;
607 !befores dom
608 end,
609 fn () => !afters (!current))
610
611val () = Env.registerPre (fn () => (ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, ""],
612 fn cl => "Temp file cleanup failed: " ^ cl));
613 OS.FileSys.mkDir Config.tmpDir;
614 app (fn node => OS.FileSys.mkDir
615 (OS.Path.joinDirFile {dir = Config.tmpDir,
616 file = node}))
617 nodes;
618 app (fn node => OS.FileSys.mkDir
619 (OS.Path.joinDirFile {dir = Config.resultRoot,
620 file = node})
621 handle OS.SysErr _ => ())
622 nodes))
623
624fun handleSite (site, files) =
625 let
626
627 in
628 print ("New configuration for node " ^ site ^ "\n");
629 if site = Config.defaultNode then
630 Slave.handleChanges files
631 else let
632 val bio = OpenSSL.connect (valOf (!ssl_context),
633 nodeIp site
634 ^ ":"
635 ^ Int.toString Config.slavePort)
636 in
637 app (fn file => Msg.send (bio, MsgFile file)) files;
638 Msg.send (bio, MsgDoFiles);
639 case Msg.recv bio of
640 NONE => print "Slave closed connection unexpectedly\n"
641 | SOME m =>
642 case m of
643 MsgOk => print ("Slave " ^ site ^ " finished\n")
644 | MsgError s => print ("Slave " ^ site
645 ^ " returned error: " ^
646 s ^ "\n")
647 | _ => print ("Slave " ^ site
648 ^ " returned unexpected command\n");
649 OpenSSL.close bio
650 end
651 end
652
653val () = Env.registerPost (fn () =>
654 let
655 val diffs = findAllDiffs ()
656
657 val diffs = map (fn (site, dom, dir, Add' {src, dst}) =>
658 (Slave.shellF ([Config.cp, " ", src, " ", dst],
659 fn cl => "Copy failed: " ^ cl);
660 (site,
661 {action = Slave.Add,
662 domain = dom,
663 dir = dir,
664 file = dst}))
665 | (site, dom, dir, Delete' dst) =>
666 (OS.FileSys.remove dst
667 handle OS.SysErr _ =>
668 ErrorMsg.error NONE ("Delete failed for " ^ dst);
669 (site,
670 {action = Slave.Delete,
671 domain = dom,
672 dir = dir,
673 file = dst}))
674 | (site, dom, dir, Modify' {src, dst}) =>
675 (Slave.shellF ([Config.cp, " ", src, " ", dst],
676 fn cl => "Copy failed: " ^ cl);
677 (site,
678 {action = Slave.Modify,
679 domain = dom,
680 dir = dir,
681 file = dst}))) diffs
682 in
683 if !ErrorMsg.anyErrors then
684 ()
685 else let
686 val changed = foldl (fn ((site, file), changed) =>
687 let
688 val ls = case SM.find (changed, site) of
689 NONE => []
690 | SOME ls => ls
691 in
692 SM.insert (changed, site, file :: ls)
693 end) SM.empty diffs
694 in
695 SM.appi handleSite changed
696 end;
697 ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, ""],
698 fn cl => "Temp file cleanup failed: " ^ cl))
699 end)
700
701fun hasPriv priv = Acl.query {user = getUser (), class = "priv", value = "all"}
702 orelse Acl.query {user = getUser (), class = "priv", value = priv}
703
704val _ = Env.type_one "dns_node"
705 Env.string
706 (fn node =>
707 List.exists (fn x => x = node) Config.dnsNodes_all
708 orelse (hasPriv "dns"
709 andalso List.exists (fn x => x = node) Config.dnsNodes_admin))
710
711val _ = Env.type_one "mail_node"
712 Env.string
713 (fn node =>
714 List.exists (fn x => x = node) Config.mailNodes_all
715 orelse (hasPriv "mail"
716 andalso List.exists (fn x => x = node) Config.mailNodes_admin))
717
718fun rmdom doms =
719 let
720 fun doNode (node, _) =
721 let
722 val dname = OS.Path.joinDirFile {dir = Config.resultRoot,
723 file = node}
724
725 fun doDom (dom, actions) =
726 let
727 val domPath = String.concatWith "/" (rev (String.fields (fn ch => ch = #".") dom))
728 val dname = OS.Path.concat (dname, domPath)
729
730 fun visitDom (dom, dname, actions) =
731 let
732 val dir = Posix.FileSys.opendir dname
733
734 fun loop actions =
735 case Posix.FileSys.readdir dir of
736 NONE => actions
737 | SOME fname =>
738 let
739 val fnameFull = OS.Path.joinDirFile {dir = dname,
740 file = fname}
741 in
742 if Posix.FileSys.ST.isDir (Posix.FileSys.stat fnameFull) then
743 loop (visitDom (fname ^ "." ^ dom,
744 fnameFull,
745 actions))
746 else
747 loop ({action = Slave.Delete,
748 domain = dom,
749 dir = dname,
750 file = fnameFull} :: actions)
751 end
752 in
753 loop actions
754 before Posix.FileSys.closedir dir
755 end
756 handle OS.SysErr _ =>
757 (print ("Warning: System error deleting domain " ^ dom ^ " on " ^ node ^ ".\n");
758 actions)
759 in
760 visitDom (dom, dname, actions)
761 end
762
763 val actions = foldl doDom [] doms
764 in
765 handleSite (node, actions)
766 end
767 handle IO.Io _ => print ("Warning: IO error deleting domains on " ^ node ^ ".\n")
768
769 fun cleanupNode (node, _) =
770 let
771 fun doDom dom =
772 let
773 val domPath = String.concatWith "/" (rev (String.fields (fn ch => ch = #".") dom))
774 val dname = OS.Path.joinDirFile {dir = Config.resultRoot,
775 file = node}
776 val dname = OS.Path.concat (dname, domPath)
777 in
778 ignore (OS.Process.system (Config.rm ^ " -rf " ^ dname))
779 end
780 in
781 app doDom doms
782 end
783 in
784 app doNode Config.nodeIps;
785 app cleanupNode Config.nodeIps
786 end
787
788fun homedirOf uname =
789 Posix.SysDB.Passwd.home (Posix.SysDB.getpwnam uname)
790
791fun homedir () = homedirOf (getUser ())
792
793end
Unnamed repository; edit this file to name it for gitweb.