src/domain.sml

(* HCoop Domtool (http://hcoop.sourceforge.net/)
 * Copyright (c) 2006, 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

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

val validGroup = validUser

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

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 ("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 scratch = ref ""

fun currentDomain () = !current

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

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 path = getPath dom

				   val () = (current := dom;
					     currentPath := (fn site => path (Config.tmpDir, site)))

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

				   fun saveNamed (kind, soa : soa, masterIp) node =
				       let
					   val outf = domainFile {node = node, name = "named.conf"}
				       in
					   TextIO.output (outf, "\nzone \"");
					   TextIO.output (outf, dom);
					   TextIO.output (outf, "\" IN {\n\ttype ");
					   TextIO.output (outf, kind);
					   TextIO.output (outf, ";\n\tfile \"");
					   TextIO.output (outf, Config.Bind.zonePath_real);
					   TextIO.output (outf, "/");
					   TextIO.output (outf, dom);
					   TextIO.output (outf, ".zone\";\n");
					   case kind of
					       "master" => TextIO.output (outf, "\tallow-update { none; };\n")
					     | _ => (TextIO.output (outf, "\tmasters { ");
						     TextIO.output (outf, masterIp);
						     TextIO.output (outf, "; };\n"));
					   TextIO.output (outf, "};\n");
					   TextIO.closeOut outf
				       end
			       in
				   case kind of
				       NoDns => masterNode := NONE
				     | UseDns dns =>
				       let
					   val masterIp =
					       case #master dns of
						   InternalMaster node => valOf (SM.find (nodeMap, node))
						 | ExternalMaster ip => ip
				       in
					   app (saveSoa ("slave", #soa dns)) (#slaves dns);
					   app (saveNamed ("slave", #soa dns, masterIp)) (#slaves dns);
					   case #master dns of
					       InternalMaster node =>
					       (masterNode := SOME node;
						saveSoa ("master", #soa dns) node;
						saveNamed ("master", #soa dns, masterIp) node)
					     | _ => masterNode := NONE;
					   !befores dom
				       end
			       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 dom =
    let
	val domPath = String.concatWith "/" (rev (String.fields (fn ch => ch = #".") dom))

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

		val dir = Posix.FileSys.opendir dname

		fun loop actions =
		    case Posix.FileSys.readdir dir of
			NONE => actions
		      | SOME fname => loop ({action = Slave.Delete,
					     domain = dom,
					     dir = dname,
					     file = OS.Path.joinDirFile {dir = dname,
									 file = fname}} :: actions)

		val actions = loop []
	    in
		Posix.FileSys.closedir dir;
		handleSite (node, actions)
	    end
		handle IO.Io _ => print ("Warning: IO error deleting domain " ^ dom ^ " on " ^ node ^ ".\n")

	fun cleanupNode (node, _) =
	    let
		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 doNode Config.nodeIps;
	app cleanupNode Config.nodeIps
    end

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