[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 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 setUser user =
    (usr := Config.testUser;
     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"})

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

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