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

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

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 setUser ur = usr := ur
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 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 ())

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_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 _ = Main.registerDefault ("DNS",
			      (TBase "dnsKind", dl),
			      (fn () => multiApp ((EVar "useDns", dl),
					 dl,
					 [soaD, masterD, (EList [], dl)])))

val _ = Main.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)
	       | _ => 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
		    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.registerPreTycheck (fn () => (setUser Config.testUser;
					   Acl.read Config.aclFile;
					   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"}))

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
				      Slave.handleChanges (map #2 diffs)(*;
				  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	structure SM = DataStructures.StringMap
	24	structure SS = DataStructures.StringSet
	25
	26	val nodes = map #1 Config.nodeIps
	27	val nodeMap = foldl (fn ((node, ip), mp) => SM.insert (mp, node, ip))
	28	SM.empty Config.nodeIps
	29	fun nodeIp node = valOf (SM.find (nodeMap, node))
	30
	31	val usr = ref ""
	32	fun setUser ur = usr := ur
	33	fun getUser () = !usr
	34
	35	val your_doms = ref SS.empty
	36	fun your_domains () = !your_doms
	37
	38	val your_usrs = ref SS.empty
	39	fun your_users () = !your_usrs
	40
	41	val your_grps = ref SS.empty
	42	fun your_groups () = !your_grps
	43
	44	val your_pths = ref SS.empty
	45	fun your_paths () = !your_pths
	46
	47	fun validIp s =
	48	case map Int.fromString (String.fields (fn ch => ch = #".") s) of
	49	[SOME n1, SOME n2, SOME n3, SOME n4] =>
	50	n1 >= 0 andalso n1 < 256 andalso n2 >= 0 andalso n2 < 256 andalso n3 >= 0 andalso n3 < 256 andalso n4 >= 0 andalso n4 < 256
	51	\| _ => false
	52
	53	fun isIdent ch = Char.isLower ch orelse Char.isDigit ch
	54
	55	fun validHost s =
	56	size s > 0 andalso size s < 20
	57	andalso CharVector.all (fn ch => isIdent ch orelse ch = #"-") s
	58
	59	fun validDomain s =
	60	size s > 0 andalso size s < 100
	61	andalso List.all validHost (String.fields (fn ch => ch = #".") s)
	62
	63	fun validNode s = List.exists (fn s' => s = s') nodes
	64
	65	fun yourDomain s = SS.member (your_domains (), s)
	66	fun yourUser s = SS.member (your_users (), s)
	67	fun yourGroup s = SS.member (your_groups (), s)
	68	fun yourPath path =
	69	List.all (fn s => s <> "..") (String.fields (fn ch => ch = #"/") path)
	70	andalso CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"." orelse ch = #"/"
	71	orelse ch = #"-" orelse ch = #"_") path
	72	andalso SS.exists (fn s' => path = s' orelse String.isPrefix (s' ^ "/") path) (your_paths ())
	73
	74	val _ = Env.type_one "no_spaces"
	75	Env.string
	76	(CharVector.all (fn ch => not (Char.isSpace ch)))
	77	val _ = Env.type_one "no_newlines"
	78	Env.string
	79	(CharVector.all (fn ch => ch <> #"\n" andalso ch <> #"\r"))
	80
	81	val _ = Env.type_one "ip"
	82	Env.string
	83	validIp
	84
	85	val _ = Env.type_one "host"
	86	Env.string
	87	validHost
	88
	89	val _ = Env.type_one "domain"
	90	Env.string
	91	validDomain
	92
	93	val _ = Env.type_one "your_domain"
	94	Env.string
	95	yourDomain
	96
	97	val _ = Env.type_one "your_user"
	98	Env.string
	99	yourUser
	100
	101	val _ = Env.type_one "your_group"
	102	Env.string
	103	yourGroup
	104
	105	val _ = Env.type_one "your_path"
	106	Env.string
	107	yourPath
	108
	109	val _ = Env.type_one "node"
	110	Env.string
	111	validNode
	112
	113	open Ast
	114
	115	val dl = ErrorMsg.dummyLoc
	116
	117	val nsD = (EString Config.defaultNs, dl)
	118	val serialD = (EVar "serialAuto", dl)
	119	val refD = (EInt Config.defaultRefresh, dl)
	120	val retD = (EInt Config.defaultRetry, dl)
	121	val expD = (EInt Config.defaultExpiry, dl)
	122	val minD = (EInt Config.defaultMinimum, dl)
	123
	124	val soaD = multiApp ((EVar "soa", dl),
	125	dl,
	126	[nsD, serialD, refD, retD, expD, minD])
	127
	128	val masterD = (EApp ((EVar "internalMaster", dl),
	129	(EString Config.defaultNode, dl)),
	130	dl)
	131
	132	val _ = Main.registerDefault ("DNS",
	133	(TBase "dnsKind", dl),
	134	(fn () => multiApp ((EVar "useDns", dl),
	135	dl,
	136	[soaD, masterD, (EList [], dl)])))
	137
	138	val _ = Main.registerDefault ("TTL",
	139	(TBase "int", dl),
	140	(fn () => (EInt Config.Bind.defaultTTL, dl)))
	141
	142	type soa = {ns : string,
	143	serial : int option,
	144	ref : int,
	145	ret : int,
	146	exp : int,
	147	min : int}
	148
	149	val serial = fn (EVar "serialAuto", _) => SOME NONE
	150	\| (EApp ((EVar "serialConst", _), n), _) => Option.map SOME (Env.int n)
	151	\| _ => NONE
	152
	153	val soa = fn (EApp ((EApp ((EApp ((EApp ((EApp ((EApp
	154	((EVar "soa", _), ns), _),
	155	sl), _),
	156	rf), _),
	157	ret), _),
	158	exp), _),
	159	min), _) =>
	160	(case (Env.string ns, serial sl, Env.int rf,
	161	Env.int ret, Env.int exp, Env.int min) of
	162	(SOME ns, SOME sl, SOME rf,
	163	SOME ret, SOME exp, SOME min) =>
	164	SOME {ns = ns,
	165	serial = sl,
	166	ref = rf,
	167	ret = ret,
	168	exp = exp,
	169	min = min}
	170	\| _ => NONE)
	171	\| _ => NONE
	172
	173	datatype master =
	174	ExternalMaster of string
	175	\| InternalMaster of string
	176
	177	val master = fn (EApp ((EVar "externalMaster", _), e), _) => Option.map ExternalMaster (Env.string e)
	178	\| (EApp ((EVar "internalMaster", _), e), _) => Option.map InternalMaster (Env.string e)
	179	\| _ => NONE
	180
	181	datatype dnsKind =
	182	UseDns of {soa : soa,
	183	master : master,
	184	slaves : string list}
	185	\| NoDns
	186
	187	val dnsKind = fn (EApp ((EApp ((EApp
	188	((EVar "useDns", _), sa), _),
	189	mstr), _),
	190	slaves), _) =>
	191	(case (soa sa, master mstr, Env.list Env.string slaves) of
	192	(SOME sa, SOME mstr, SOME slaves) =>
	193	SOME (UseDns {soa = sa,
	194	master = mstr,
	195	slaves = slaves})
	196	\| _ => NONE)
	197	\| _ => NONE
	198
	199	val befores = ref (fn (_ : string) => ())
	200	val afters = ref (fn (_ : string) => ())
	201
	202	fun registerBefore f =
	203	let
	204	val old = !befores
	205	in
	206	befores := (fn x => (old x; f x))
	207	end
	208
	209	fun registerAfter f =
	210	let
	211	val old = !afters
	212	in
	213	afters := (fn x => (old x; f x))
	214	end
	215
	216	val current = ref ""
	217	val currentPath = ref (fn (_ : string) => "")
	218
	219	val scratch = ref ""
	220
	221	fun currentDomain () = !current
	222
	223	fun domainFile {node, name} = ((print ("Opening " ^ !currentPath node ^ name ^ "\n");)
	224	TextIO.openOut (!currentPath node ^ name))
	225
	226	fun getPath domain =
	227	let
	228	val toks = String.fields (fn ch => ch = #".") domain
	229
	230	val elems = foldr (fn (piece, elems) =>
	231	let
	232	val elems = piece :: elems
	233
	234	fun doNode node =
	235	let
	236	val path = String.concatWith "/"
	237	(Config.resultRoot :: node :: rev elems)
	238	val tmpPath = String.concatWith "/"
	239	(Config.tmpDir :: node :: rev elems)
	240	in
	241	(if Posix.FileSys.ST.isDir
	242	(Posix.FileSys.stat path) then
	243	()
	244	else
	245	(OS.FileSys.remove path;
	246	OS.FileSys.mkDir path))
	247	handle OS.SysErr _ => OS.FileSys.mkDir path;
	248
	249	(if Posix.FileSys.ST.isDir
	250	(Posix.FileSys.stat tmpPath) then
	251	()
	252	else
	253	(OS.FileSys.remove tmpPath;
	254	OS.FileSys.mkDir tmpPath))
	255	handle OS.SysErr _ => OS.FileSys.mkDir tmpPath
	256	end
	257	in
	258	app doNode nodes;
	259	elems
	260	end) [] toks
	261	in
	262	fn (root, site) => String.concatWith "/" (root :: site :: rev ("" :: elems))
	263	end
	264
	265	datatype file_action' =
	266	Add' of {src : string, dst : string}
	267	\| Delete' of string
	268	\| Modify' of {src : string, dst : string}
	269
	270	fun findDiffs (site, dom, acts) =
	271	let
	272	val gp = getPath dom
	273	val realPath = gp (Config.resultRoot, site)
	274	val tmpPath = gp (Config.tmpDir, site)
	275
	276	(val _ = print ("getDiffs(" ^ site ^ ", " ^ dom ^ ")... " ^ realPath ^ "; " ^ tmpPath ^ "\n"))
	277
	278	val dir = Posix.FileSys.opendir realPath
	279
	280	fun loopReal acts =
	281	case Posix.FileSys.readdir dir of
	282	NONE => (Posix.FileSys.closedir dir;
	283	acts)
	284	\| SOME fname =>
	285	let
	286	val real = OS.Path.joinDirFile {dir = realPath,
	287	file = fname}
	288	val tmp = OS.Path.joinDirFile {dir = tmpPath,
	289	file = fname}
	290	in
	291	if Posix.FileSys.ST.isDir (Posix.FileSys.stat real) then
	292	loopReal acts
	293	else if Posix.FileSys.access (tmp, []) then
	294	if Slave.shell [Config.diff, " ", real, " ", tmp] then
	295	loopReal acts
	296	else
	297	loopReal ((site, dom, realPath, Modify' {src = tmp, dst = real}) :: acts)
	298	else
	299	loopReal ((site, dom, realPath, Delete' real) :: acts)
	300	end
	301
	302	val acts = loopReal acts
	303
	304	val dir = Posix.FileSys.opendir tmpPath
	305
	306	fun loopTmp acts =
	307	case Posix.FileSys.readdir dir of
	308	NONE => (Posix.FileSys.closedir dir;
	309	acts)
	310	\| SOME fname =>
	311	let
	312	val real = OS.Path.joinDirFile {dir = realPath,
	313	file = fname}
	314	val tmp = OS.Path.joinDirFile {dir = tmpPath,
	315	file = fname}
	316	in
	317	if Posix.FileSys.ST.isDir (Posix.FileSys.stat tmp) then
	318	loopTmp acts
	319	else if Posix.FileSys.access (real, []) then
	320	loopTmp acts
	321	else
	322	loopTmp ((site, dom, realPath, Add' {src = tmp, dst = real}) :: acts)
	323	end
	324
	325	val acts = loopTmp acts
	326	in
	327	acts
	328	end
	329
	330	fun findAllDiffs () =
	331	let
	332	val dir = Posix.FileSys.opendir Config.tmpDir
	333	val len = length (String.fields (fn ch => ch = #"/") Config.tmpDir) + 1
	334
	335	fun exploreSites diffs =
	336	case Posix.FileSys.readdir dir of
	337	NONE => diffs
	338	\| SOME site =>
	339	let
	340	fun explore (dname, diffs) =
	341	let
	342	val dir = Posix.FileSys.opendir dname
	343
	344	fun loop diffs =
	345	case Posix.FileSys.readdir dir of
	346	NONE => diffs
	347	\| SOME name =>
	348	let
	349	val fname = OS.Path.joinDirFile {dir = dname,
	350	file = name}
	351	in
	352	loop (if Posix.FileSys.ST.isDir (Posix.FileSys.stat fname) then
	353	let
	354	val dom = String.fields (fn ch => ch = #"/") fname
	355	val dom = List.drop (dom, len)
	356	val dom = String.concatWith "." (rev dom)
	357
	358	val dname' = OS.Path.joinDirFile {dir = dname,
	359	file = name}
	360	in
	361	explore (dname',
	362	findDiffs (site, dom, diffs))
	363	end
	364	else
	365	diffs)
	366	end
	367	in
	368	loop diffs
	369	before Posix.FileSys.closedir dir
	370	end
	371	in
	372	explore (OS.Path.joinDirFile {dir = Config.tmpDir,
	373	file = site}, diffs)
	374	end
	375	in
	376	exploreSites []
	377	before Posix.FileSys.closedir dir
	378	end
	379
	380	val masterNode : string option ref = ref NONE
	381	fun dnsMaster () = !masterNode
	382
	383	val _ = Env.containerV_one "domain"
	384	("domain", Env.string)
	385	(fn (evs, dom) =>
	386	let
	387	val kind = Env.env dnsKind (evs, "DNS")
	388	val ttl = Env.env Env.int (evs, "TTL")
	389
	390	val path = getPath dom
	391
	392	val () = (current := dom;
	393	currentPath := (fn site => path (Config.tmpDir, site)))
	394
	395	fun saveSoa (kind, soa : soa) node =
	396	let
	397	val outf = domainFile {node = node, name = "soa"}
	398	in
	399	TextIO.output (outf, kind);
	400	TextIO.output (outf, "\n");
	401	TextIO.output (outf, Int.toString ttl);
	402	TextIO.output (outf, "\n");
	403	TextIO.output (outf, #ns soa);
	404	TextIO.output (outf, "\n");
	405	case #serial soa of
	406	NONE => ()
	407	\| SOME n => TextIO.output (outf, Int.toString n);
	408	TextIO.output (outf, "\n");
	409	TextIO.output (outf, Int.toString (#ref soa));
	410	TextIO.output (outf, "\n");
	411	TextIO.output (outf, Int.toString (#ret soa));
	412	TextIO.output (outf, "\n");
	413	TextIO.output (outf, Int.toString (#exp soa));
	414	TextIO.output (outf, "\n");
	415	TextIO.output (outf, Int.toString (#min soa));
	416	TextIO.output (outf, "\n");
	417	TextIO.closeOut outf
	418	end
	419
	420	fun saveNamed (kind, soa : soa, masterIp) node =
	421	let
	422	val outf = domainFile {node = node, name = "named.conf"}
	423	in
	424	TextIO.output (outf, "\nzone \"");
	425	TextIO.output (outf, dom);
	426	TextIO.output (outf, "\" IN {\n\ttype ");
	427	TextIO.output (outf, kind);
	428	TextIO.output (outf, ";\n\tfile \"");
	429	TextIO.output (outf, Config.Bind.zonePath);
	430	TextIO.output (outf, "/");
	431	TextIO.output (outf, dom);
	432	TextIO.output (outf, ".zone\";\n");
	433	case kind of
	434	"master" => TextIO.output (outf, "\tallow-update { none; };\n")
	435	\| _ => (TextIO.output (outf, "\tmasters { ");
	436	TextIO.output (outf, masterIp);
	437	TextIO.output (outf, " };\n"));
	438	TextIO.output (outf, "};\n");
	439	TextIO.closeOut outf
	440	end
	441	in
	442	case kind of
	443	NoDns => masterNode := NONE
	444	\| UseDns dns =>
	445	let
	446	val masterIp =
	447	case #master dns of
	448	InternalMaster node => valOf (SM.find (nodeMap, node))
	449	\| ExternalMaster ip => ip
	450	in
	451	app (saveSoa ("slave", #soa dns)) (#slaves dns);
	452	app (saveNamed ("slave", #soa dns, masterIp)) (#slaves dns);
	453	case #master dns of
	454	InternalMaster node =>
	455	(masterNode := SOME node;
	456	saveSoa ("master", #soa dns) node;
	457	saveNamed ("master", #soa dns, masterIp) node)
	458	\| _ => masterNode := NONE;
	459	!befores dom
	460	end
	461	end,
	462	fn () => !afters (!current))
	463
	464	val () = Env.registerPreTycheck (fn () => (setUser Config.testUser;
	465	Acl.read Config.aclFile;
	466	your_doms := Acl.class {user = getUser (),
	467	class = "domain"};
	468	your_usrs := Acl.class {user = getUser (),
	469	class = "user"};
	470	your_grps := Acl.class {user = getUser (),
	471	class = "group"};
	472	your_pths := Acl.class {user = getUser (),
	473	class = "path"}))
	474
	475	val () = Env.registerPre (fn () => (ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, ""],
	476	fn cl => "Temp file cleanup failed: " ^ cl));
	477	OS.FileSys.mkDir Config.tmpDir;
	478	app (fn node => OS.FileSys.mkDir
	479	(OS.Path.joinDirFile {dir = Config.tmpDir,
	480	file = node}))
	481	nodes;
	482	app (fn node => OS.FileSys.mkDir
	483	(OS.Path.joinDirFile {dir = Config.resultRoot,
	484	file = node})
	485	handle OS.SysErr _ => ())
	486	nodes))
	487
	488	val () = Env.registerPost (fn () =>
	489	let
	490	val diffs = findAllDiffs ()
	491
	492	val diffs = map (fn (site, dom, dir, Add' {src, dst}) =>
	493	(Slave.shellF ([Config.cp, " ", src, " ", dst],
	494	fn cl => "Copy failed: " ^ cl);
	495	(site,
	496	{action = Slave.Add,
	497	domain = dom,
	498	dir = dir,
	499	file = dst}))
	500	\| (site, dom, dir, Delete' dst) =>
	501	(OS.FileSys.remove dst
	502	handle OS.SysErr _ =>
	503	ErrorMsg.error NONE ("Delete failed for " ^ dst);
	504	(site,
	505	{action = Slave.Delete,
	506	domain = dom,
	507	dir = dir,
	508	file = dst}))
	509	\| (site, dom, dir, Modify' {src, dst}) =>
	510	(Slave.shellF ([Config.cp, " ", src, " ", dst],
	511	fn cl => "Copy failed: " ^ cl);
	512	(site,
	513	{action = Slave.Modify,
	514	domain = dom,
	515	dir = dir,
	516	file = dst}))) diffs
	517	in
	518	if !ErrorMsg.anyErrors then
	519	()
	520	else
	521	Slave.handleChanges (map #2 diffs)(*;
	522	ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, ""],
	523	fn cl => "Temp file cleanup failed: " ^ cl))*)
	524	end)
	525
	526
	527
	528	end