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

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 = fn (EApp ((EVar "ip_of_node", _), e), _) => Option.map nodeIp (Env.string e)
	  | e => Env.string e

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 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))

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

					  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
				      in
					  SM.appi handleSite changed
				      end;
				  ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, ""],
						     fn cl => "Temp file cleanup failed: " ^ cl))
			      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	open Ast
	157
	158	val dl = ErrorMsg.dummyLoc
	159
	160	val nsD = (EString Config.defaultNs, dl)
	161	val serialD = (EVar "serialAuto", dl)
	162	val refD = (EInt Config.defaultRefresh, dl)
	163	val retD = (EInt Config.defaultRetry, dl)
	164	val expD = (EInt Config.defaultExpiry, dl)
	165	val minD = (EInt Config.defaultMinimum, dl)
	166
	167	val soaD = multiApp ((EVar "soa", dl),
	168	dl,
	169	[nsD, serialD, refD, retD, expD, minD])
	170
	171	val masterD = (EApp ((EVar "internalMaster", dl),
	172	(EString Config.masterNode, dl)),
	173	dl)
	174
	175	val slavesD = (EList (map (fn s => (EString s, dl)) Config.slaveNodes), dl)
	176
	177	val _ = Defaults.registerDefault ("Mailbox",
	178	(TBase "email", dl),
	179	(fn () => (EString (getUser ()), dl)))
	180
	181	val _ = Defaults.registerDefault ("DNS",
	182	(TBase "dnsKind", dl),
	183	(fn () => multiApp ((EVar "useDns", dl),
	184	dl,
	185	[soaD, masterD, slavesD])))
	186
	187	val _ = Defaults.registerDefault ("TTL",
	188	(TBase "int", dl),
	189	(fn () => (EInt Config.Bind.defaultTTL, dl)))
	190
	191	type soa = {ns : string,
	192	serial : int option,
	193	ref : int,
	194	ret : int,
	195	exp : int,
	196	min : int}
	197
	198	val serial = fn (EVar "serialAuto", _) => SOME NONE
	199	\| (EApp ((EVar "serialConst", _), n), _) => Option.map SOME (Env.int n)
	200	\| _ => NONE
	201
	202	val soa = fn (EApp ((EApp ((EApp ((EApp ((EApp ((EApp
	203	((EVar "soa", _), ns), _),
	204	sl), _),
	205	rf), _),
	206	ret), _),
	207	exp), _),
	208	min), _) =>
	209	(case (Env.string ns, serial sl, Env.int rf,
	210	Env.int ret, Env.int exp, Env.int min) of
	211	(SOME ns, SOME sl, SOME rf,
	212	SOME ret, SOME exp, SOME min) =>
	213	SOME {ns = ns,
	214	serial = sl,
	215	ref = rf,
	216	ret = ret,
	217	exp = exp,
	218	min = min}
	219	\| _ => NONE)
	220	\| _ => NONE
	221
	222	datatype master =
	223	ExternalMaster of string
	224	\| InternalMaster of string
	225
	226	val ip = fn (EApp ((EVar "ip_of_node", _), e), _) => Option.map nodeIp (Env.string e)
	227	\| e => Env.string e
	228
	229	val master = fn (EApp ((EVar "externalMaster", _), e), _) => Option.map ExternalMaster (ip e)
	230	\| (EApp ((EVar "internalMaster", _), e), _) => Option.map InternalMaster (Env.string e)
	231	\| _ => NONE
	232
	233	datatype dnsKind =
	234	UseDns of {soa : soa,
	235	master : master,
	236	slaves : string list}
	237	\| NoDns
	238
	239	val dnsKind = fn (EApp ((EApp ((EApp
	240	((EVar "useDns", _), sa), _),
	241	mstr), _),
	242	slaves), _) =>
	243	(case (soa sa, master mstr, Env.list Env.string slaves) of
	244	(SOME sa, SOME mstr, SOME slaves) =>
	245	SOME (UseDns {soa = sa,
	246	master = mstr,
	247	slaves = slaves})
	248	\| _ => NONE)
	249	\| (EVar "noDns", _) => SOME NoDns
	250	\| _ => NONE
	251
	252	val befores = ref (fn (_ : string) => ())
	253	val afters = ref (fn (_ : string) => ())
	254
	255	fun registerBefore f =
	256	let
	257	val old = !befores
	258	in
	259	befores := (fn x => (old x; f x))
	260	end
	261
	262	fun registerAfter f =
	263	let
	264	val old = !afters
	265	in
	266	afters := (fn x => (old x; f x))
	267	end
	268
	269	val current = ref ""
	270	val currentPath = ref (fn (_ : string) => "")
	271
	272	val scratch = ref ""
	273
	274	fun currentDomain () = !current
	275
	276	fun domainFile {node, name} = ((print ("Opening " ^ !currentPath node ^ name ^ "\n");)
	277	TextIO.openOut (!currentPath node ^ name))
	278
	279	fun getPath domain =
	280	let
	281	val toks = String.fields (fn ch => ch = #".") domain
	282
	283	val elems = foldr (fn (piece, elems) =>
	284	let
	285	val elems = piece :: elems
	286
	287	fun doNode node =
	288	let
	289	val path = String.concatWith "/"
	290	(Config.resultRoot :: node :: rev elems)
	291	val tmpPath = String.concatWith "/"
	292	(Config.tmpDir :: node :: rev elems)
	293	in
	294	(if Posix.FileSys.ST.isDir
	295	(Posix.FileSys.stat path) then
	296	()
	297	else
	298	(OS.FileSys.remove path;
	299	OS.FileSys.mkDir path))
	300	handle OS.SysErr _ => OS.FileSys.mkDir path;
	301
	302	(if Posix.FileSys.ST.isDir
	303	(Posix.FileSys.stat tmpPath) then
	304	()
	305	else
	306	(OS.FileSys.remove tmpPath;
	307	OS.FileSys.mkDir tmpPath))
	308	handle OS.SysErr _ => OS.FileSys.mkDir tmpPath
	309	end
	310	in
	311	app doNode nodes;
	312	elems
	313	end) [] toks
	314	in
	315	fn (root, site) => String.concatWith "/" (root :: site :: rev ("" :: elems))
	316	end
	317
	318	datatype file_action' =
	319	Add' of {src : string, dst : string}
	320	\| Delete' of string
	321	\| Modify' of {src : string, dst : string}
	322
	323	fun findDiffs (site, dom, acts) =
	324	let
	325	val gp = getPath dom
	326	val realPath = gp (Config.resultRoot, site)
	327	val tmpPath = gp (Config.tmpDir, site)
	328
	329	(val _ = print ("getDiffs(" ^ site ^ ", " ^ dom ^ ")... " ^ realPath ^ "; " ^ tmpPath ^ "\n"))
	330
	331	val dir = Posix.FileSys.opendir realPath
	332
	333	fun loopReal acts =
	334	case Posix.FileSys.readdir dir of
	335	NONE => (Posix.FileSys.closedir dir;
	336	acts)
	337	\| SOME fname =>
	338	let
	339	val real = OS.Path.joinDirFile {dir = realPath,
	340	file = fname}
	341	val tmp = OS.Path.joinDirFile {dir = tmpPath,
	342	file = fname}
	343	in
	344	if Posix.FileSys.ST.isDir (Posix.FileSys.stat real) then
	345	loopReal acts
	346	else if Posix.FileSys.access (tmp, []) then
	347	if Slave.shell [Config.diff, " ", real, " ", tmp] then
	348	loopReal acts
	349	else
	350	loopReal ((site, dom, realPath, Modify' {src = tmp, dst = real}) :: acts)
	351	else
	352	loopReal ((site, dom, realPath, Delete' real) :: acts)
	353	end
	354
	355	val acts = loopReal acts
	356
	357	val dir = Posix.FileSys.opendir tmpPath
	358
	359	fun loopTmp acts =
	360	case Posix.FileSys.readdir dir of
	361	NONE => (Posix.FileSys.closedir dir;
	362	acts)
	363	\| SOME fname =>
	364	let
	365	val real = OS.Path.joinDirFile {dir = realPath,
	366	file = fname}
	367	val tmp = OS.Path.joinDirFile {dir = tmpPath,
	368	file = fname}
	369	in
	370	if Posix.FileSys.ST.isDir (Posix.FileSys.stat tmp) then
	371	loopTmp acts
	372	else if Posix.FileSys.access (real, []) then
	373	loopTmp acts
	374	else
	375	loopTmp ((site, dom, realPath, Add' {src = tmp, dst = real}) :: acts)
	376	end
	377
	378	val acts = loopTmp acts
	379	in
	380	acts
	381	end
	382
	383	fun findAllDiffs () =
	384	let
	385	val dir = Posix.FileSys.opendir Config.tmpDir
	386	val len = length (String.fields (fn ch => ch = #"/") Config.tmpDir) + 1
	387
	388	fun exploreSites diffs =
	389	case Posix.FileSys.readdir dir of
	390	NONE => diffs
	391	\| SOME site =>
	392	let
	393	fun explore (dname, diffs) =
	394	let
	395	val dir = Posix.FileSys.opendir dname
	396
	397	fun loop diffs =
	398	case Posix.FileSys.readdir dir of
	399	NONE => diffs
	400	\| SOME name =>
	401	let
	402	val fname = OS.Path.joinDirFile {dir = dname,
	403	file = name}
	404	in
	405	loop (if Posix.FileSys.ST.isDir (Posix.FileSys.stat fname) then
	406	let
	407	val dom = String.fields (fn ch => ch = #"/") fname
	408	val dom = List.drop (dom, len)
	409	val dom = String.concatWith "." (rev dom)
	410
	411	val dname' = OS.Path.joinDirFile {dir = dname,
	412	file = name}
	413	in
	414	explore (dname',
	415	findDiffs (site, dom, diffs))
	416	end
	417	else
	418	diffs)
	419	end
	420	in
	421	loop diffs
	422	before Posix.FileSys.closedir dir
	423	end
	424	in
	425	exploreSites (explore (OS.Path.joinDirFile {dir = Config.tmpDir,
	426	file = site}, diffs))
	427	end
	428	in
	429	exploreSites []
	430	before Posix.FileSys.closedir dir
	431	end
	432
	433	val masterNode : string option ref = ref NONE
	434	fun dnsMaster () = !masterNode
	435
	436	val _ = Env.containerV_one "domain"
	437	("domain", Env.string)
	438	(fn (evs, dom) =>
	439	let
	440	val kind = Env.env dnsKind (evs, "DNS")
	441	val ttl = Env.env Env.int (evs, "TTL")
	442
	443	val path = getPath dom
	444
	445	val () = (current := dom;
	446	currentPath := (fn site => path (Config.tmpDir, site)))
	447
	448	fun saveSoa (kind, soa : soa) node =
	449	let
	450	val outf = domainFile {node = node, name = "soa"}
	451	in
	452	TextIO.output (outf, kind);
	453	TextIO.output (outf, "\n");
	454	TextIO.output (outf, Int.toString ttl);
	455	TextIO.output (outf, "\n");
	456	TextIO.output (outf, #ns soa);
	457	TextIO.output (outf, "\n");
	458	case #serial soa of
	459	NONE => ()
	460	\| SOME n => TextIO.output (outf, Int.toString n);
	461	TextIO.output (outf, "\n");
	462	TextIO.output (outf, Int.toString (#ref soa));
	463	TextIO.output (outf, "\n");
	464	TextIO.output (outf, Int.toString (#ret soa));
	465	TextIO.output (outf, "\n");
	466	TextIO.output (outf, Int.toString (#exp soa));
	467	TextIO.output (outf, "\n");
	468	TextIO.output (outf, Int.toString (#min soa));
	469	TextIO.output (outf, "\n");
	470	TextIO.closeOut outf
	471	end
	472
	473	fun saveNamed (kind, soa : soa, masterIp) node =
	474	let
	475	val outf = domainFile {node = node, name = "named.conf"}
	476	in
	477	TextIO.output (outf, "\nzone \"");
	478	TextIO.output (outf, dom);
	479	TextIO.output (outf, "\" IN {\n\ttype ");
	480	TextIO.output (outf, kind);
	481	TextIO.output (outf, ";\n\tfile \"");
	482	TextIO.output (outf, Config.Bind.zonePath_real);
	483	TextIO.output (outf, "/");
	484	TextIO.output (outf, dom);
	485	TextIO.output (outf, ".zone\";\n");
	486	case kind of
	487	"master" => TextIO.output (outf, "\tallow-update { none; };\n")
	488	\| _ => (TextIO.output (outf, "\tmasters { ");
	489	TextIO.output (outf, masterIp);
	490	TextIO.output (outf, " };\n"));
	491	TextIO.output (outf, "};\n");
	492	TextIO.closeOut outf
	493	end
	494	in
	495	case kind of
	496	NoDns => masterNode := NONE
	497	\| UseDns dns =>
	498	let
	499	val masterIp =
	500	case #master dns of
	501	InternalMaster node => valOf (SM.find (nodeMap, node))
	502	\| ExternalMaster ip => ip
	503	in
	504	app (saveSoa ("slave", #soa dns)) (#slaves dns);
	505	app (saveNamed ("slave", #soa dns, masterIp)) (#slaves dns);
	506	case #master dns of
	507	InternalMaster node =>
	508	(masterNode := SOME node;
	509	saveSoa ("master", #soa dns) node;
	510	saveNamed ("master", #soa dns, masterIp) node)
	511	\| _ => masterNode := NONE;
	512	!befores dom
	513	end
	514	end,
	515	fn () => !afters (!current))
	516
	517	val () = Env.registerPre (fn () => (ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, ""],
	518	fn cl => "Temp file cleanup failed: " ^ cl));
	519	OS.FileSys.mkDir Config.tmpDir;
	520	app (fn node => OS.FileSys.mkDir
	521	(OS.Path.joinDirFile {dir = Config.tmpDir,
	522	file = node}))
	523	nodes;
	524	app (fn node => OS.FileSys.mkDir
	525	(OS.Path.joinDirFile {dir = Config.resultRoot,
	526	file = node})
	527	handle OS.SysErr _ => ())
	528	nodes))
	529
	530	val () = Env.registerPost (fn () =>
	531	let
	532	val diffs = findAllDiffs ()
	533
	534	val diffs = map (fn (site, dom, dir, Add' {src, dst}) =>
	535	(Slave.shellF ([Config.cp, " ", src, " ", dst],
	536	fn cl => "Copy failed: " ^ cl);
	537	(site,
	538	{action = Slave.Add,
	539	domain = dom,
	540	dir = dir,
	541	file = dst}))
	542	\| (site, dom, dir, Delete' dst) =>
	543	(OS.FileSys.remove dst
	544	handle OS.SysErr _ =>
	545	ErrorMsg.error NONE ("Delete failed for " ^ dst);
	546	(site,
	547	{action = Slave.Delete,
	548	domain = dom,
	549	dir = dir,
	550	file = dst}))
	551	\| (site, dom, dir, Modify' {src, dst}) =>
	552	(Slave.shellF ([Config.cp, " ", src, " ", dst],
	553	fn cl => "Copy failed: " ^ cl);
	554	(site,
	555	{action = Slave.Modify,
	556	domain = dom,
	557	dir = dir,
	558	file = dst}))) diffs
	559	in
	560	if !ErrorMsg.anyErrors then
	561	()
	562	else let
	563	val changed = foldl (fn ((site, file), changed) =>
	564	let
	565	val ls = case SM.find (changed, site) of
	566	NONE => []
	567	\| SOME ls => ls
	568	in
	569	SM.insert (changed, site, file :: ls)
	570	end) SM.empty diffs
	571
	572	fun handleSite (site, files) =
	573	let
	574
	575	in
	576	print ("New configuration for node " ^ site ^ "\n");
	577	if site = Config.defaultNode then
	578	Slave.handleChanges files
	579	else let
	580	val bio = OpenSSL.connect (valOf (!ssl_context),
	581	nodeIp site
	582	^ ":"
	583	^ Int.toString Config.slavePort)
	584	in
	585	app (fn file => Msg.send (bio, MsgFile file)) files;
	586	Msg.send (bio, MsgDoFiles);
	587	case Msg.recv bio of
	588	NONE => print "Slave closed connection unexpectedly\n"
	589	\| SOME m =>
	590	case m of
	591	MsgOk => print ("Slave " ^ site ^ " finished\n")
	592	\| MsgError s => print ("Slave " ^ site
	593	^ " returned error: " ^
	594	s ^ "\n")
	595	\| _ => print ("Slave " ^ site
	596	^ " returned unexpected command\n");
	597	OpenSSL.close bio
	598	end
	599	end
	600	in
	601	SM.appi handleSite changed
	602	end;
	603	ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, ""],
	604	fn cl => "Temp file cleanup failed: " ^ cl))
	605	end)
	606
	607	end