src/domain.sml

(* HCoop Domtool (http://hcoop.sourceforge.net/)
 * Copyright (c) 2006-2007, Adam Chlipala
 *
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
 *)

(* Domain-related primitive actions *)

structure Domain :> DOMAIN = struct

open MsgTypes

structure SM = DataStructures.StringMap
structure SS = DataStructures.StringSet

val ssl_context = ref (NONE : OpenSSL.context option)
fun set_context ctx = ssl_context := SOME ctx

val nodes = map #1 Config.nodeIps
val nodeMap = foldl (fn ((node, ip), mp) => SM.insert (mp, node, ip))
		    SM.empty Config.nodeIps
fun nodeIp node = valOf (SM.find (nodeMap, node))

val usr = ref ""
fun getUser () = !usr

val your_doms = ref SS.empty
fun your_domains () = !your_doms

val your_usrs = ref SS.empty
fun your_users () = !your_usrs

val your_grps = ref SS.empty
fun your_groups () = !your_grps

val your_pths = ref SS.empty
fun your_paths () = !your_pths

fun setUser user =
    (usr := user;
     your_doms := Acl.class {user = getUser (),
			     class = "domain"};
     your_usrs := Acl.class {user = getUser (),
			     class = "user"};
     your_grps := Acl.class {user = getUser (),
			     class = "group"};
     your_pths := Acl.class {user = getUser (),
			     class = "path"})

fun validIp s =
    case map Int.fromString (String.fields (fn ch => ch = #".") s) of
	[SOME n1, SOME n2, SOME n3, SOME n4] =>
	n1 >= 0 andalso n1 < 256 andalso n2 >= 0 andalso n2 < 256 andalso n3 >= 0 andalso n3 < 256 andalso n4 >= 0 andalso n4 < 256
      | _ => false

fun isIdent ch = Char.isLower ch orelse Char.isDigit ch

fun validHost s =
    size s > 0 andalso size s < 20
    andalso CharVector.all (fn ch => isIdent ch orelse ch = #"-") s

fun validDomain s =
    size s > 0 andalso size s < 100
    andalso List.all validHost (String.fields (fn ch => ch = #".") s)

fun validNode s = List.exists (fn s' => s = s') nodes

fun yourDomain s = SS.member (your_domains (), s)
fun yourUser s = SS.member (your_users (), s)
fun yourGroup s = SS.member (your_groups (), s)
fun yourPath path =
    List.all (fn s => s <> "..") (String.fields (fn ch => ch = #"/") path)
    andalso CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"." orelse ch = #"/"
				     orelse ch = #"-" orelse ch = #"_") path
    andalso SS.exists (fn s' => path = s' orelse String.isPrefix (s' ^ "/") path) (your_paths ())

fun yourDomainHost s =
    yourDomain s
    orelse let
	val (pref, suf) = Substring.splitl (fn ch => ch <> #".") (Substring.full s)
    in
	Substring.size suf > 0
	andalso validHost (Substring.string pref)
	andalso yourDomain (Substring.string
				(Substring.slice (suf, 1, NONE)))
    end

val yourDomain = yourDomainHost

fun validUser s = size s > 0 andalso size s < 20
		  andalso CharVector.all Char.isAlphaNum s

fun validEmailUser s =
    size s > 0 andalso size s < 50
    andalso CharVector.all (fn ch => Char.isAlphaNum ch
				     orelse ch = #"."
				     orelse ch = #"_"
				     orelse ch = #"-"
				     orelse ch = #"+") s

val validGroup = validUser

val _ = Env.type_one "no_spaces"
		     Env.string
		     (CharVector.all (fn ch => Char.isPrint ch andalso not (Char.isSpace ch)
					       andalso ch <> #"\"" andalso ch <> #"'"))
val _ = Env.type_one "no_newlines"
		     Env.string
		     (CharVector.all (fn ch => Char.isPrint ch andalso ch <> #"\n" andalso ch <> #"\r"
					       andalso ch <> #"\"" andalso ch <> #"'"))

val _ = Env.type_one "ip"
	Env.string
	validIp

val _ = Env.type_one "host"
	Env.string
	validHost

val _ = Env.type_one "domain"
	Env.string
	validDomain

val _ = Env.type_one "your_domain"
	Env.string
	yourDomain

val _ = Env.type_one "your_domain_host"
	Env.string
	yourDomainHost

val _ = Env.type_one "user"
	Env.string
	validUser

val _ = Env.type_one "group"
	Env.string
	validGroup

val _ = Env.type_one "your_user"
	Env.string
	yourUser

val _ = Env.type_one "your_group"
	Env.string
	yourGroup

val _ = Env.type_one "your_path"
	Env.string
	yourPath

val _ = Env.type_one "node"
	Env.string
	validNode

val _ = Env.registerFunction ("dns_node_to_node",
			      fn [e] => SOME e
			       | _ => NONE)

val _ = Env.registerFunction ("mail_node_to_node",
			      fn [e] => SOME e
			       | _ => NONE)
open Ast

val dl = ErrorMsg.dummyLoc

val nsD = (EString Config.defaultNs, dl)
val serialD = (EVar "serialAuto", dl)
val refD = (EInt Config.defaultRefresh, dl)
val retD = (EInt Config.defaultRetry, dl)
val expD = (EInt Config.defaultExpiry, dl)
val minD = (EInt Config.defaultMinimum, dl)

val soaD = multiApp ((EVar "soa", dl),
		     dl,
		     [nsD, serialD, refD, retD, expD, minD])

val masterD = (EApp ((EVar "internalMaster", dl),
		     (EString Config.masterNode, dl)),
	       dl)

val slavesD = (EList (map (fn s => (EString s, dl)) Config.slaveNodes), dl)

val _ = Defaults.registerDefault ("Aliases",
				  (TList (TBase "your_domain", dl), dl),
				  (fn () => (EList [], dl)))

val _ = Defaults.registerDefault ("Mailbox",
				  (TBase "email", dl),
				  (fn () => (EString (getUser ()), dl)))

val _ = Defaults.registerDefault ("DNS",
				  (TBase "dnsKind", dl),
				  (fn () => multiApp ((EVar "useDns", dl),
						      dl,
						      [soaD, masterD, slavesD])))

val _ = Defaults.registerDefault ("TTL",
				  (TBase "int", dl),
				  (fn () => (EInt Config.Bind.defaultTTL, dl)))

type soa = {ns : string,
	    serial : int option,
	    ref : int,
	    ret : int,
	    exp : int,
	    min : int}

val serial = fn (EVar "serialAuto", _) => SOME NONE
	      | (EApp ((EVar "serialConst", _), n), _) => Option.map SOME (Env.int n)
	      | _ => NONE

val soa = fn (EApp ((EApp ((EApp ((EApp ((EApp ((EApp
						     ((EVar "soa", _), ns), _),
						sl), _),
					 rf), _),
				  ret), _),
			   exp), _),
		    min), _) =>
	     (case (Env.string ns, serial sl, Env.int rf,
		    Env.int ret, Env.int exp, Env.int min) of
		  (SOME ns, SOME sl, SOME rf,
		   SOME ret, SOME exp, SOME min) =>
		  SOME {ns = ns,
			serial = sl,
			ref = rf,
			ret = ret,
			exp = exp,
			min = min}
		| _ => NONE)
	   | _ => NONE

datatype master =
	 ExternalMaster of string
       | InternalMaster of string

val ip = Env.string

val _ = Env.registerFunction ("ip_of_node",
			      fn [(EString node, _)] => SOME (EString (nodeIp node), dl)
			       | _ => NONE)

val master = fn (EApp ((EVar "externalMaster", _), e), _) => Option.map ExternalMaster (ip e)
	      | (EApp ((EVar "internalMaster", _), e), _) => Option.map InternalMaster (Env.string e)
	      | _ => NONE

datatype dnsKind =
	 UseDns of {soa : soa,
		    master : master,
		    slaves : string list}
       | NoDns

val dnsKind = fn (EApp ((EApp ((EApp
				    ((EVar "useDns", _), sa), _),
			       mstr), _),
			slaves), _) =>
		 (case (soa sa, master mstr, Env.list Env.string slaves) of
		      (SOME sa, SOME mstr, SOME slaves) =>
		      SOME (UseDns {soa = sa,
				    master = mstr,
				    slaves = slaves})
		    | _ => NONE)
	       | (EVar "noDns", _) => SOME NoDns
	       | _ => NONE

val befores = ref (fn (_ : string) => ())
val afters = ref (fn (_ : string) => ())

fun registerBefore f =
    let
	val old = !befores
    in
	befores := (fn x => (old x; f x))
    end

fun registerAfter f =
    let
	val old = !afters
    in
	afters := (fn x => (old x; f x))
    end

val globals = ref (fn () => ())
val locals = ref (fn () => ())

fun registerResetGlobal f =
    let
	val old = !globals
    in
	globals := (fn x => (old x; f x))
    end

fun registerResetLocal f =
    let
	val old = !locals
    in
	locals := (fn x => (old x; f x))
    end

fun resetGlobal () = (!globals ();
		      ignore (OS.Process.system (Config.rm ^ " -rf " ^ Config.resultRoot ^ "/*")))
fun resetLocal () = !locals ()

val current = ref ""
val currentPath = ref (fn (_ : string) => "")
val currentPathAli = ref (fn (_ : string, _ : string) => "")

val scratch = ref ""

fun currentDomain () = !current

val currentsAli = ref ([] : string list)

fun currentAliasDomains () = !currentsAli
fun currentDomains () = currentDomain () :: currentAliasDomains ()

fun domainFile {node, name} = ((*print ("Opening " ^ !currentPath node ^ name ^ "\n");*)
			       TextIO.openOut (!currentPath node ^ name))

type files = {write : string -> unit,
	      writeDom : unit -> unit,
	      close : unit -> unit}

fun domainsFile {node, name} =
    let
	val doms = currentDomains ()
	val files = map (fn dom => (dom, TextIO.openOut (!currentPathAli (dom, node) ^ name))) doms
    in
	{write = fn s => app (fn (_, outf) => TextIO.output (outf, s)) files,
	 writeDom = fn () => app (fn (dom, outf) => TextIO.output (outf, dom)) files,
	 close = fn () => app (fn (_, outf) => TextIO.closeOut outf) files}
    end

fun getPath domain =
    let
	val toks = String.fields (fn ch => ch = #".") domain

	val elems = foldr (fn (piece, elems) =>
			      let
				  val elems = piece :: elems

				  fun doNode node =
				      let
					  val path = String.concatWith "/"
								       (Config.resultRoot :: node :: rev elems)
					  val tmpPath = String.concatWith "/"
									  (Config.tmpDir :: node :: rev elems)
				      in
					  (if Posix.FileSys.ST.isDir
						  (Posix.FileSys.stat path) then
					       ()
					   else
					       (OS.FileSys.remove path;
						OS.FileSys.mkDir path))
					  handle OS.SysErr _ => OS.FileSys.mkDir path;

					  (if Posix.FileSys.ST.isDir
						  (Posix.FileSys.stat tmpPath) then
					       ()
					   else
					       (OS.FileSys.remove tmpPath;
						OS.FileSys.mkDir tmpPath))
					  handle OS.SysErr _ => OS.FileSys.mkDir tmpPath
				      end
			      in
				  app doNode nodes;
				  elems
			      end) [] toks
    in
	fn (root, site) => String.concatWith "/" (root :: site :: rev ("" :: elems))
    end

datatype file_action' =
	 Add' of {src : string, dst : string}
       | Delete' of string
       | Modify' of {src : string, dst : string}

fun findDiffs (site, dom, acts) =
    let
	val gp = getPath dom
	val realPath = gp (Config.resultRoot, site)
	val tmpPath = gp (Config.tmpDir, site)

	(*val _ = print ("getDiffs(" ^ site ^ ", " ^ dom ^ ")... " ^ realPath ^ "; " ^ tmpPath ^ "\n")*)

	val dir = Posix.FileSys.opendir realPath

	fun loopReal acts =
	    case Posix.FileSys.readdir dir of
		NONE => (Posix.FileSys.closedir dir;
			 acts)
	      | SOME fname =>
		let
		    val real = OS.Path.joinDirFile {dir = realPath,
						    file = fname}
		    val tmp = OS.Path.joinDirFile {dir = tmpPath,
						   file = fname}
		in
		    if Posix.FileSys.ST.isDir (Posix.FileSys.stat real) then
			loopReal acts
		    else if Posix.FileSys.access (tmp, []) then
			if Slave.shell [Config.diff, " ", real, " ",  tmp] then
			    loopReal acts
			else
			    loopReal ((site, dom, realPath, Modify' {src = tmp, dst = real}) :: acts)
		    else
			loopReal ((site, dom, realPath, Delete' real) :: acts)
		end

	val acts = loopReal acts

	val dir = Posix.FileSys.opendir tmpPath

	fun loopTmp acts =
	    case Posix.FileSys.readdir dir of
		NONE => (Posix.FileSys.closedir dir;
			 acts)
	      | SOME fname =>
		let
		    val real = OS.Path.joinDirFile {dir = realPath,
						    file = fname}
		    val tmp = OS.Path.joinDirFile {dir = tmpPath,
						   file = fname}
		in
		    if Posix.FileSys.ST.isDir (Posix.FileSys.stat tmp) then
			loopTmp acts
		    else if Posix.FileSys.access (real, []) then
			loopTmp acts
		    else
			loopTmp ((site, dom, realPath, Add' {src = tmp, dst = real}) :: acts)
		end

	val acts = loopTmp acts
    in
	acts
    end

fun findAllDiffs () =
    let
	val dir = Posix.FileSys.opendir Config.tmpDir
	val len = length (String.fields (fn ch => ch = #"/") Config.tmpDir) + 1

	fun exploreSites diffs =
	    case Posix.FileSys.readdir dir of
		NONE => diffs
	      | SOME site =>
		let
		    fun explore (dname, diffs) =
			let
			    val dir = Posix.FileSys.opendir dname

			    fun loop diffs =
				case Posix.FileSys.readdir dir of
				    NONE => diffs
				  | SOME name =>
				    let
					val fname = OS.Path.joinDirFile {dir = dname,
									 file = name}
				    in
					loop (if Posix.FileSys.ST.isDir (Posix.FileSys.stat fname) then
						  let
						      val dom = String.fields (fn ch => ch = #"/") fname
						      val dom = List.drop (dom, len)
						      val dom = String.concatWith "." (rev dom)

						      val dname' = OS.Path.joinDirFile {dir = dname,
											file = name}
						  in
						      explore (dname',
							       findDiffs (site, dom, diffs))
						  end
					      else
						  diffs)
				    end
			in
			    loop diffs
			    before Posix.FileSys.closedir dir
			end
		in
		    exploreSites (explore (OS.Path.joinDirFile {dir = Config.tmpDir,
								file = site}, diffs))
		end
    in
	exploreSites []
	before Posix.FileSys.closedir dir
    end

val masterNode : string option ref = ref NONE
fun dnsMaster () = !masterNode

val _ = Env.containerV_one "domain"
			   ("domain", Env.string)
			   (fn (evs, dom) =>
			       let
				   val kind = Env.env dnsKind (evs, "DNS")
				   val ttl = Env.env Env.int (evs, "TTL")
				   val aliases = Env.env (Env.list Env.string) (evs, "Aliases")

				   val path = getPath dom

				   val () = (current := dom;
					     currentsAli := Slave.remove (Slave.removeDups aliases, dom);
					     currentPath := (fn site => path (Config.tmpDir, site));
					     currentPathAli := (fn (dom, site) => getPath dom (Config.tmpDir, site)))

				   fun saveSoa (kind, soa : soa) node =
				       let
					   val {write, writeDom, close} = domainsFile {node = node, name = "soa"}
				       in
					   write kind;
					   write "\n";
					   write (Int.toString ttl);
					   write "\n";
					   write (#ns soa);
					   write "\n";
					   case #serial soa of
					       NONE => ()
					     | SOME n => write (Int.toString n);
					   write "\n";
					   write (Int.toString (#ref soa));
					   write "\n";
					   write (Int.toString (#ret soa));
					   write "\n";
					   write (Int.toString (#exp soa));
					   write "\n";
					   write (Int.toString (#min soa));
					   write "\n";
					   close ()
				       end

				   fun saveNamed (kind, soa : soa, masterIp, slaveIps) node =
				       if dom = "localhost" then
					   ()
				       else let
					       val {write, writeDom, close} = domainsFile {node = node, name = "named.conf"}
					   in
					       write "\nzone \"";
					       writeDom ();
					       write "\" {\n\ttype ";
					       write kind;
					       write ";\n\tfile \"";
					       write Config.Bind.zonePath_real;
					       write "/";
					       writeDom ();
					       write ".zone\";\n";
					       case kind of
						   "master" => (write "\tallow-transfer {\n";
								app (fn ip => (write "\t\t";
									       write ip;
									       write ";\n")) slaveIps;
								write "\t};\n")
						 | _ => (write "\tmasters { ";
							 write masterIp;
							 write "; };\n");
					       write "};\n";
					       close ()
					   end
			       in
				   case kind of
				       NoDns => masterNode := NONE
				     | UseDns dns =>
				       let
					   val masterIp =
					       case #master dns of
						   InternalMaster node => nodeIp node
						 | ExternalMaster ip => ip

					   val slaveIps = map nodeIp (#slaves dns)
				       in
					   app (saveSoa ("slave", #soa dns)) (#slaves dns);
					   app (saveNamed ("slave", #soa dns, masterIp, slaveIps)) (#slaves dns);
					   case #master dns of
					       InternalMaster node =>
					       (masterNode := SOME node;
						saveSoa ("master", #soa dns) node;
						saveNamed ("master", #soa dns, masterIp, slaveIps) node)
					     | _ => masterNode := NONE
				       end;
				   !befores dom
			       end,
			    fn () => !afters (!current))

val () = Env.registerPre (fn () => (ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, ""],
						       fn cl => "Temp file cleanup failed: " ^ cl));
				    OS.FileSys.mkDir Config.tmpDir;
				    app (fn node => OS.FileSys.mkDir
							(OS.Path.joinDirFile {dir = Config.tmpDir,
									      file = node}))
					nodes;
				    app (fn node => OS.FileSys.mkDir
							(OS.Path.joinDirFile {dir = Config.resultRoot,
									      file = node})
					    handle OS.SysErr _ => ())
					nodes))

fun handleSite (site, files) =
    let

    in
	print ("New configuration for node " ^ site ^ "\n");
	if site = Config.defaultNode then
	    Slave.handleChanges files
	else let
		val bio = OpenSSL.connect (valOf (!ssl_context),
					   nodeIp site
					   ^ ":"
					   ^ Int.toString Config.slavePort)
	    in
		app (fn file => Msg.send (bio, MsgFile file)) files;
		Msg.send (bio, MsgDoFiles);
		case Msg.recv bio of
		    NONE => print "Slave closed connection unexpectedly\n"
		  | SOME m =>
		    case m of
			MsgOk => print ("Slave " ^ site ^ " finished\n")
		      | MsgError s => print ("Slave " ^ site
					     ^ " returned error: " ^
					     s ^ "\n")
		      | _ => print ("Slave " ^ site
				    ^ " returned unexpected command\n");
		OpenSSL.close bio
	    end
    end

val () = Env.registerPost (fn () =>
			      let
				  val diffs = findAllDiffs ()

				  val diffs = map (fn (site, dom, dir, Add' {src, dst}) =>
						      (Slave.shellF ([Config.cp, " ", src, " ", dst],
								  fn cl => "Copy failed: " ^ cl);
						       (site,
							{action = Slave.Add,
							 domain = dom,
							 dir = dir,
							 file = dst}))
						    | (site, dom, dir, Delete' dst) =>
						      (OS.FileSys.remove dst
						       handle OS.SysErr _ =>
							      ErrorMsg.error NONE ("Delete failed for " ^ dst);
						       (site,
							{action = Slave.Delete,
							 domain = dom,
							 dir = dir,
							 file = dst}))
						    | (site, dom, dir, Modify' {src, dst}) =>
						      (Slave.shellF ([Config.cp, " ", src, " ", dst],
								  fn cl => "Copy failed: " ^ cl);
						       (site,
							{action = Slave.Modify,
							 domain = dom,
							 dir = dir,
							 file = dst}))) diffs
			      in
				  if !ErrorMsg.anyErrors then
				      ()
				  else let
					  val changed = foldl (fn ((site, file), changed) =>
								  let
								      val ls = case SM.find (changed, site) of
										   NONE => []
										 | SOME ls => ls
								  in
								      SM.insert (changed, site, file :: ls)
								  end) SM.empty diffs
				      in
					  SM.appi handleSite changed
				      end;
				  ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, ""],
						     fn cl => "Temp file cleanup failed: " ^ cl))
			      end)

fun hasPriv priv = Acl.query {user = getUser (), class = "priv", value = "all"}
		   orelse Acl.query {user = getUser (), class = "priv", value = priv}

val _ = Env.type_one "dns_node"
	Env.string
	(fn node =>
	    List.exists (fn x => x = node) Config.dnsNodes_all
	    orelse (hasPriv "dns"
		    andalso List.exists (fn x => x = node) Config.dnsNodes_admin))

val _ = Env.type_one "mail_node"
	Env.string
	(fn node =>
	    List.exists (fn x => x = node) Config.mailNodes_all
	    orelse (hasPriv "mail"
		    andalso List.exists (fn x => x = node) Config.mailNodes_admin))

fun rmdom doms =
    let
	fun doNode (node, _) =
	    let
		val dname = OS.Path.joinDirFile {dir = Config.resultRoot,
						 file = node}

		fun doDom (dom, actions) =
		    let
			val domPath = String.concatWith "/" (rev (String.fields (fn ch => ch = #".") dom))
			val dname = OS.Path.concat (dname, domPath)

			fun visitDom (dom, dname, actions) =
			    let
				val dir = Posix.FileSys.opendir dname

				fun loop actions =
				    case Posix.FileSys.readdir dir of
					NONE => actions
				      | SOME fname =>
					let
					    val fnameFull = OS.Path.joinDirFile {dir = dname,
										 file = fname}
					in
					    if Posix.FileSys.ST.isDir (Posix.FileSys.stat fnameFull) then
						loop (visitDom (fname ^ "." ^ dom,
								fnameFull,
								actions))
					    else
						loop ({action = Slave.Delete,
						       domain = dom,
						       dir = dname,
						       file = fnameFull} :: actions)
					end
			    in
				loop actions
				before Posix.FileSys.closedir dir
			    end
				handle OS.SysErr _ =>
				       (print ("Warning: System error deleting domain " ^ dom ^ " on " ^ node ^ ".\n");
					actions)
		    in
			visitDom (dom, dname, actions)
		    end

		val actions = foldl doDom [] doms
	    in
		handleSite (node, actions)
	    end
		handle IO.Io _ => print ("Warning: IO error deleting domains on " ^ node ^ ".\n")

	fun cleanupNode (node, _) =
	    let
		fun doDom dom =
		    let
			val domPath = String.concatWith "/" (rev (String.fields (fn ch => ch = #".") dom))
			val dname = OS.Path.joinDirFile {dir = Config.resultRoot,
							 file = node}
			val dname = OS.Path.concat (dname, domPath)
		    in
			ignore (OS.Process.system (Config.rm ^ " -rf " ^ dname))
		    end
	    in
		app doDom doms
	    end
    in
	app doNode Config.nodeIps;
	app cleanupNode Config.nodeIps
    end

fun homedirOf uname =
    Posix.SysDB.Passwd.home (Posix.SysDB.getpwnam uname)

fun homedir () = homedirOf (getUser ())

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