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