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

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

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