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 := Config.testUser;
     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.defaultNode, dl)),
	       dl)

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

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