[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 =
    yourDomain s
    orelse let
	val (pref, suf) = Substring.splitl (fn ch => ch <> #".") (Substring.full s)
    in
	Substring.size suf > 0
	andalso validHost (Substring.string pref)
	andalso yourDomain (Substring.string
				(Substring.slice (suf, 1, NONE)))
    end

fun validUser s = size s > 0 andalso size s < 20
		  andalso CharVector.all Char.isAlphaNum s

val validGroup = validUser

val _ = Env.type_one "no_spaces"
		     Env.string
		     (CharVector.all (fn ch => not (Char.isSpace ch)))
val _ = Env.type_one "no_newlines"
		     Env.string
		     (CharVector.all (fn ch => ch <> #"\n" andalso ch <> #"\r"))

val _ = Env.type_one "ip"
	Env.string
	validIp

val _ = Env.type_one "host"
	Env.string
	validHost

val _ = Env.type_one "domain"
	Env.string
	validDomain

val _ = Env.type_one "your_domain"
	Env.string
	yourDomain

val _ = Env.type_one "your_domain_host"
	Env.string
	yourDomainHost

val _ = Env.type_one "user"
	Env.string
	validUser

val _ = Env.type_one "group"
	Env.string
	validGroup

val _ = Env.type_one "your_user"
	Env.string
	yourUser

val _ = Env.type_one "your_group"
	Env.string
	yourGroup

val _ = Env.type_one "your_path"
	Env.string
	yourPath

val _ = Env.type_one "node"
	Env.string
	validNode

open Ast

val dl = ErrorMsg.dummyLoc

val nsD = (EString Config.defaultNs, dl)
val serialD = (EVar "serialAuto", dl)
val refD = (EInt Config.defaultRefresh, dl)
val retD = (EInt Config.defaultRetry, dl)
val expD = (EInt Config.defaultExpiry, dl)
val minD = (EInt Config.defaultMinimum, dl)

val soaD = multiApp ((EVar "soa", dl),
		     dl,
		     [nsD, serialD, refD, retD, expD, minD])

val masterD = (EApp ((EVar "internalMaster", dl),
		     (EString Config.defaultNode, dl)),
	       dl)

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