[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)
	       | (EVar "noDns", _) => SOME NoDns
	       | _ => NONE

val befores = ref (fn (_ : string) => ())
val afters = ref (fn (_ : string) => ())

fun registerBefore f =
    let
	val old = !befores
    in
	befores := (fn x => (old x; f x))
    end

fun registerAfter f =
    let
	val old = !afters
    in
	afters := (fn x => (old x; f x))
    end

val current = ref ""
val currentPath = ref (fn (_ : string) => "")

val scratch = ref ""

fun currentDomain () = !current

fun domainFile {node, name} = ((*print ("Opening " ^ !currentPath node ^ name ^ "\n");*)
			       TextIO.openOut (!currentPath node ^ name))

fun getPath domain =
    let
	val toks = String.fields (fn ch => ch = #".") domain

	val elems = foldr (fn (piece, elems) =>
			      let
				  val elems = piece :: elems

				  fun doNode node =
				      let
					  val path = String.concatWith "/"
								       (Config.resultRoot :: node :: rev elems)
					  val tmpPath = String.concatWith "/"
									  (Config.tmpDir :: node :: rev elems)
				      in
					  (if Posix.FileSys.ST.isDir
						  (Posix.FileSys.stat path) then
					       ()
					   else
					       (OS.FileSys.remove path;
						OS.FileSys.mkDir path))
					  handle OS.SysErr _ => OS.FileSys.mkDir path;

					  (if Posix.FileSys.ST.isDir
						  (Posix.FileSys.stat tmpPath) then
					       ()
					   else
					       (OS.FileSys.remove tmpPath;
						OS.FileSys.mkDir tmpPath))
					  handle OS.SysErr _ => OS.FileSys.mkDir tmpPath
				      end
			      in
				  app doNode nodes;
				  elems
			      end) [] toks
    in
	fn (root, site) => String.concatWith "/" (root :: site :: rev ("" :: elems))
    end

datatype file_action' =
	 Add' of {src : string, dst : string}
       | Delete' of string
       | Modify' of {src : string, dst : string}

fun findDiffs (site, dom, acts) =
    let
	val gp = getPath dom
	val realPath = gp (Config.resultRoot, site)
	val tmpPath = gp (Config.tmpDir, site)

	(*val _ = print ("getDiffs(" ^ site ^ ", " ^ dom ^ ")... " ^ realPath ^ "; " ^ tmpPath ^ "\n")*)

	val dir = Posix.FileSys.opendir realPath

	fun loopReal acts =
	    case Posix.FileSys.readdir dir of
		NONE => (Posix.FileSys.closedir dir;
			 acts)
	      | SOME fname =>
		let
		    val real = OS.Path.joinDirFile {dir = realPath,
						    file = fname}
		    val tmp = OS.Path.joinDirFile {dir = tmpPath,
						   file = fname}
		in
		    if Posix.FileSys.ST.isDir (Posix.FileSys.stat real) then
			loopReal acts
		    else if Posix.FileSys.access (tmp, []) then
			if Slave.shell [Config.diff, " ", real, " ",  tmp] then
			    loopReal acts
			else
			    loopReal ((site, dom, realPath, Modify' {src = tmp, dst = real}) :: acts)
		    else
			loopReal ((site, dom, realPath, Delete' real) :: acts)
		end

	val acts = loopReal acts

	val dir = Posix.FileSys.opendir tmpPath

	fun loopTmp acts =
	    case Posix.FileSys.readdir dir of
		NONE => (Posix.FileSys.closedir dir;
			 acts)
	      | SOME fname =>
		let
		    val real = OS.Path.joinDirFile {dir = realPath,
						    file = fname}
		    val tmp = OS.Path.joinDirFile {dir = tmpPath,
						   file = fname}
		in
		    if Posix.FileSys.ST.isDir (Posix.FileSys.stat tmp) then
			loopTmp acts
		    else if Posix.FileSys.access (real, []) then
			loopTmp acts
		    else
			loopTmp ((site, dom, realPath, Add' {src = tmp, dst = real}) :: acts)
		end

	val acts = loopTmp acts
    in
	acts
    end

fun findAllDiffs () =
    let
	val dir = Posix.FileSys.opendir Config.tmpDir
	val len = length (String.fields (fn ch => ch = #"/") Config.tmpDir) + 1

	fun exploreSites diffs =
	    case Posix.FileSys.readdir dir of
		NONE => diffs
	      | SOME site =>
		let
		    fun explore (dname, diffs) =
			let
			    val dir = Posix.FileSys.opendir dname

			    fun loop diffs =
				case Posix.FileSys.readdir dir of
				    NONE => diffs
				  | SOME name =>
				    let
					val fname = OS.Path.joinDirFile {dir = dname,
									 file = name}
				    in
					loop (if Posix.FileSys.ST.isDir (Posix.FileSys.stat fname) then
						  let
						      val dom = String.fields (fn ch => ch = #"/") fname
						      val dom = List.drop (dom, len)
						      val dom = String.concatWith "." (rev dom)

						      val dname' = OS.Path.joinDirFile {dir = dname,
											file = name}
						  in
						      explore (dname',
							       findDiffs (site, dom, diffs))
						  end
					      else
						  diffs)
				    end
			in
			    loop diffs
			    before Posix.FileSys.closedir dir
			end
		in
		    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)
325285ab	225	\| (EVar "noDns", _) => SOME NoDns
6ae327f8 AC	226	\| _ => NONE
6ae327f8 AC	227
a3698041 AC	228	val befores = ref (fn (_ : string) => ())
	229	val afters = ref (fn (_ : string) => ())
	230
	231	fun registerBefore f =
	232	let
	233	val old = !befores
	234	in
	235	befores := (fn x => (old x; f x))
	236	end
	237
	238	fun registerAfter f =
	239	let
	240	val old = !afters
	241	in
	242	afters := (fn x => (old x; f x))
	243	end
	244
	245	val current = ref ""
e0b0abd2	246	val currentPath = ref (fn (_ : string) => "")
dac62e84	247
d612d62c AC	248	val scratch = ref ""
d612d62c AC	249
dac62e84 AC	250	fun currentDomain () = !current
dac62e84 AC	251
e0b0abd2 AC	252	fun domainFile {node, name} = ((print ("Opening " ^ !currentPath node ^ name ^ "\n");)
e0b0abd2 AC	253	TextIO.openOut (!currentPath node ^ name))
dac62e84 AC	254
	255	fun getPath domain =
	256	let
	257	val toks = String.fields (fn ch => ch = #".") domain
	258
	259	val elems = foldr (fn (piece, elems) =>
	260	let
	261	val elems = piece :: elems
d612d62c	262
e0b0abd2 AC	263	fun doNode node =
	264	let
	265	val path = String.concatWith "/"
	266	(Config.resultRoot :: node :: rev elems)
	267	val tmpPath = String.concatWith "/"
	268	(Config.tmpDir :: node :: rev elems)
	269	in
	270	(if Posix.FileSys.ST.isDir
	271	(Posix.FileSys.stat path) then
	272	()
	273	else
	274	(OS.FileSys.remove path;
	275	OS.FileSys.mkDir path))
	276	handle OS.SysErr _ => OS.FileSys.mkDir path;
	277
	278	(if Posix.FileSys.ST.isDir
	279	(Posix.FileSys.stat tmpPath) then
	280	()
	281	else
	282	(OS.FileSys.remove tmpPath;
	283	OS.FileSys.mkDir tmpPath))
	284	handle OS.SysErr _ => OS.FileSys.mkDir tmpPath
	285	end
	286	in
2ed6d0e5	287	app doNode nodes;
dac62e84 AC	288	elems
	289	end) [] toks
	290	in
e0b0abd2	291	fn (root, site) => String.concatWith "/" (root :: site :: rev ("" :: elems))
d612d62c AC	292	end
	293
	294	datatype file_action' =
	295	Add' of {src : string, dst : string}
	296	\| Delete' of string
	297	\| Modify' of {src : string, dst : string}
	298
e0b0abd2	299	fun findDiffs (site, dom, acts) =
d612d62c	300	let
e0b0abd2 AC	301	val gp = getPath dom
	302	val realPath = gp (Config.resultRoot, site)
	303	val tmpPath = gp (Config.tmpDir, site)
	304
	305	(val _ = print ("getDiffs(" ^ site ^ ", " ^ dom ^ ")... " ^ realPath ^ "; " ^ tmpPath ^ "\n"))
d612d62c AC	306
	307	val dir = Posix.FileSys.opendir realPath
	308
	309	fun loopReal acts =
	310	case Posix.FileSys.readdir dir of
	311	NONE => (Posix.FileSys.closedir dir;
	312	acts)
	313	\| SOME fname =>
	314	let
	315	val real = OS.Path.joinDirFile {dir = realPath,
	316	file = fname}
	317	val tmp = OS.Path.joinDirFile {dir = tmpPath,
	318	file = fname}
	319	in
	320	if Posix.FileSys.ST.isDir (Posix.FileSys.stat real) then
	321	loopReal acts
	322	else if Posix.FileSys.access (tmp, []) then
8df2e702	323	if Slave.shell [Config.diff, " ", real, " ", tmp] then
d612d62c AC	324	loopReal acts
d612d62c AC	325	else
e0b0abd2	326	loopReal ((site, dom, realPath, Modify' {src = tmp, dst = real}) :: acts)
d612d62c	327	else
e0b0abd2	328	loopReal ((site, dom, realPath, Delete' real) :: acts)
d612d62c AC	329	end
d612d62c AC	330
e0b0abd2	331	val acts = loopReal acts
d612d62c	332
8df2e702	333	val dir = Posix.FileSys.opendir tmpPath
d612d62c AC	334
	335	fun loopTmp acts =
	336	case Posix.FileSys.readdir dir of
	337	NONE => (Posix.FileSys.closedir dir;
	338	acts)
	339	\| SOME fname =>
	340	let
	341	val real = OS.Path.joinDirFile {dir = realPath,
	342	file = fname}
	343	val tmp = OS.Path.joinDirFile {dir = tmpPath,
	344	file = fname}
	345	in
	346	if Posix.FileSys.ST.isDir (Posix.FileSys.stat tmp) then
	347	loopTmp acts
	348	else if Posix.FileSys.access (real, []) then
	349	loopTmp acts
	350	else
e0b0abd2	351	loopTmp ((site, dom, realPath, Add' {src = tmp, dst = real}) :: acts)
d612d62c AC	352	end
	353
	354	val acts = loopTmp acts
	355	in
	356	acts
dac62e84	357	end
a3698041	358
e0b0abd2 AC	359	fun findAllDiffs () =
	360	let
	361	val dir = Posix.FileSys.opendir Config.tmpDir
	362	val len = length (String.fields (fn ch => ch = #"/") Config.tmpDir) + 1
	363
	364	fun exploreSites diffs =
	365	case Posix.FileSys.readdir dir of
	366	NONE => diffs
	367	\| SOME site =>
	368	let
	369	fun explore (dname, diffs) =
	370	let
	371	val dir = Posix.FileSys.opendir dname
	372
	373	fun loop diffs =
	374	case Posix.FileSys.readdir dir of
	375	NONE => diffs
	376	\| SOME name =>
	377	let
	378	val fname = OS.Path.joinDirFile {dir = dname,
	379	file = name}
	380	in
	381	loop (if Posix.FileSys.ST.isDir (Posix.FileSys.stat fname) then
	382	let
	383	val dom = String.fields (fn ch => ch = #"/") fname
	384	val dom = List.drop (dom, len)
	385	val dom = String.concatWith "." (rev dom)
	386
	387	val dname' = OS.Path.joinDirFile {dir = dname,
	388	file = name}
	389	in
	390	explore (dname',
	391	findDiffs (site, dom, diffs))
	392	end
	393	else
	394	diffs)
	395	end
	396	in
	397	loop diffs
	398	before Posix.FileSys.closedir dir
	399	end
	400	in
	401	explore (OS.Path.joinDirFile {dir = Config.tmpDir,
	402	file = site}, diffs)
	403	end
	404	in
	405	exploreSites []
	406	before Posix.FileSys.closedir dir
	407	end
	408
	409	val masterNode : string option ref = ref NONE
	410	fun dnsMaster () = !masterNode
	411
6ae327f8 AC	412	val _ = Env.containerV_one "domain"
	413	("domain", Env.string)
	414	(fn (evs, dom) =>
	415	let
	416	val kind = Env.env dnsKind (evs, "DNS")
	417	val ttl = Env.env Env.int (evs, "TTL")
	418
e0b0abd2	419	val path = getPath dom
6ae327f8 AC	420
6ae327f8 AC	421	val () = (current := dom;
e0b0abd2	422	currentPath := (fn site => path (Config.tmpDir, site)))
6ae327f8	423
e0b0abd2	424	fun saveSoa (kind, soa : soa) node =
6ae327f8	425	let
e0b0abd2	426	val outf = domainFile {node = node, name = "soa"}
6ae327f8 AC	427	in
	428	TextIO.output (outf, kind);
	429	TextIO.output (outf, "\n");
	430	TextIO.output (outf, Int.toString ttl);
	431	TextIO.output (outf, "\n");
	432	TextIO.output (outf, #ns soa);
	433	TextIO.output (outf, "\n");
	434	case #serial soa of
	435	NONE => ()
	436	\| SOME n => TextIO.output (outf, Int.toString n);
	437	TextIO.output (outf, "\n");
	438	TextIO.output (outf, Int.toString (#ref soa));
	439	TextIO.output (outf, "\n");
	440	TextIO.output (outf, Int.toString (#ret soa));
	441	TextIO.output (outf, "\n");
	442	TextIO.output (outf, Int.toString (#exp soa));
	443	TextIO.output (outf, "\n");
	444	TextIO.output (outf, Int.toString (#min soa));
	445	TextIO.output (outf, "\n");
	446	TextIO.closeOut outf
	447	end
	448
2ed6d0e5	449	fun saveNamed (kind, soa : soa, masterIp) node =
6ae327f8	450	let
e0b0abd2	451	val outf = domainFile {node = node, name = "named.conf"}
6ae327f8 AC	452	in
	453	TextIO.output (outf, "\nzone \"");
	454	TextIO.output (outf, dom);
	455	TextIO.output (outf, "\" IN {\n\ttype ");
	456	TextIO.output (outf, kind);
	457	TextIO.output (outf, ";\n\tfile \"");
	458	TextIO.output (outf, Config.Bind.zonePath);
	459	TextIO.output (outf, "/");
	460	TextIO.output (outf, dom);
	461	TextIO.output (outf, ".zone\";\n");
	462	case kind of
	463	"master" => TextIO.output (outf, "\tallow-update { none; };\n")
2ed6d0e5 AC	464	\| _ => (TextIO.output (outf, "\tmasters { ");
	465	TextIO.output (outf, masterIp);
	466	TextIO.output (outf, " };\n"));
	467	TextIO.output (outf, "};\n");
6ae327f8 AC	468	TextIO.closeOut outf
6ae327f8 AC	469	end
6ae327f8 AC	470	in
6ae327f8 AC	471	case kind of
e0b0abd2 AC	472	NoDns => masterNode := NONE
e0b0abd2 AC	473	\| UseDns dns =>
2ed6d0e5 AC	474	let
	475	val masterIp =
	476	case #master dns of
	477	InternalMaster node => valOf (SM.find (nodeMap, node))
	478	\| ExternalMaster ip => ip
	479	in
	480	app (saveSoa ("slave", #soa dns)) (#slaves dns);
	481	app (saveNamed ("slave", #soa dns, masterIp)) (#slaves dns);
	482	case #master dns of
	483	InternalMaster node =>
	484	(masterNode := SOME node;
	485	saveSoa ("master", #soa dns) node;
	486	saveNamed ("master", #soa dns, masterIp) node)
	487	\| _ => masterNode := NONE;
	488	!befores dom
	489	end
6ae327f8	490	end,
e0b0abd2 AC	491	fn () => !afters (!current))
e0b0abd2 AC	492
12adf55a AC	493	val () = Env.registerPreTycheck (fn () => (setUser Config.testUser;
	494	Acl.read Config.aclFile;
	495	your_doms := Acl.class {user = getUser (),
8a7c40fa AC	496	class = "domain"};
	497	your_usrs := Acl.class {user = getUser (),
	498	class = "user"};
	499	your_grps := Acl.class {user = getUser (),
	500	class = "group"};
	501	your_pths := Acl.class {user = getUser (),
	502	class = "path"}))
12adf55a	503
e0b0abd2 AC	504	val () = Env.registerPre (fn () => (ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, ""],
	505	fn cl => "Temp file cleanup failed: " ^ cl));
	506	OS.FileSys.mkDir Config.tmpDir;
	507	app (fn node => OS.FileSys.mkDir
	508	(OS.Path.joinDirFile {dir = Config.tmpDir,
	509	file = node}))
2ed6d0e5	510	nodes;
e0b0abd2 AC	511	app (fn node => OS.FileSys.mkDir
	512	(OS.Path.joinDirFile {dir = Config.resultRoot,
	513	file = node})
	514	handle OS.SysErr _ => ())
2ed6d0e5	515	nodes))
e0b0abd2 AC	516
	517	val () = Env.registerPost (fn () =>
	518	let
	519	val diffs = findAllDiffs ()
6ae327f8	520
e0b0abd2 AC	521	val diffs = map (fn (site, dom, dir, Add' {src, dst}) =>
	522	(Slave.shellF ([Config.cp, " ", src, " ", dst],
	523	fn cl => "Copy failed: " ^ cl);
	524	(site,
6ae327f8 AC	525	{action = Slave.Add,
	526	domain = dom,
	527	dir = dir,
e0b0abd2 AC	528	file = dst}))
	529	\| (site, dom, dir, Delete' dst) =>
	530	(OS.FileSys.remove dst
	531	handle OS.SysErr _ =>
	532	ErrorMsg.error NONE ("Delete failed for " ^ dst);
	533	(site,
6ae327f8 AC	534	{action = Slave.Delete,
	535	domain = dom,
	536	dir = dir,
e0b0abd2 AC	537	file = dst}))
	538	\| (site, dom, dir, Modify' {src, dst}) =>
	539	(Slave.shellF ([Config.cp, " ", src, " ", dst],
	540	fn cl => "Copy failed: " ^ cl);
	541	(site,
6ae327f8 AC	542	{action = Slave.Modify,
	543	domain = dom,
	544	dir = dir,
e0b0abd2 AC	545	file = dst}))) diffs
	546	in
	547	if !ErrorMsg.anyErrors then
	548	()
	549	else
559e89e9	550	Slave.handleChanges (map #2 diffs);
e0b0abd2	551	ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, ""],
559e89e9	552	fn cl => "Temp file cleanup failed: " ^ cl))
e0b0abd2	553	end)
6ae327f8 AC	554
6ae327f8 AC	555
a3698041 AC	556
a3698041 AC	557	end