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

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)

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

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

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

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 _ = Main.registerDefault ("DNS",
			      (TBase "dnsKind", dl),
			      (EApp ((EVar "master", dl),
				     soaD), dl))

val _ = Main.registerDefault ("TTL",
			      (TBase "int", dl),
			      (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 dnsKind =
	 Master of soa
       | Slave of soa
       | NoDns

val dnsKind = fn (EApp ((EVar "master", _), e), _) => Option.map Master (soa e)
	       | (EApp ((EVar "slave", _), e), _) => Option.map Slave (soa e)
	       | (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 ""

val scratch = ref ""

fun currentDomain () = !current

fun domainFile name = TextIO.openOut (!currentPath ^ name)

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

	val elems = foldr (fn (piece, elems) =>
			      let
				  val elems = piece :: elems
				  val path = String.concatWith "/" (Config.resultRoot :: rev elems)
				  val tmpPath = String.concatWith "/" (Config.tmpDir :: 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;

				  elems
			      end) [] toks
    in
	fn root => String.concatWith "/" (root :: rev ("" :: elems))
    end

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

fun findDiffs dom =
    let
	val realPath = getPath dom Config.resultRoot
	val tmpPath = !currentPath

	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 (Modify' {src = tmp, dst = real} :: acts)
		    else
			loopReal (Delete' real :: acts)
		end

	val acts = loopReal []

	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 (Add' {src = tmp, dst = real} :: acts)
		end

	val acts = loopTmp acts
    in
	acts
    end

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 Config.tmpDir

				   val () = (current := dom;
					     currentPath := path;
					     !befores dom)

				   fun saveSoa (kind, soa : soa) =
				       let
					   val outf = domainFile "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) =
				       let
					   val outf = domainFile "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 { 1.2.3.4; };\n");
					   TextIO.output (outf, "}\n");
					   TextIO.closeOut outf
				       end

				   fun saveBoth ks = (saveSoa ks; saveNamed ks)
			       in
				   case kind of
				       NoDns => ()
				     | Master soa => saveBoth ("master", soa)
				     | Slave soa => saveBoth ("slave", soa)
			       end,
			    fn () =>
			       let
				   val dom = !current
				   val () = !afters dom

				   val diffs = findDiffs dom

				   val dir = getPath dom Config.resultRoot

				   val diffs = map (fn Add' {src, dst} =>
						       (Slave.shellF ([Config.cp, " ", src, " ", dst],
								   fn cl => "Copy failed: " ^ cl);
							{action = Slave.Add,
							 domain = dom,
							 dir = dir,
							 file = dst})
						     | Delete' dst =>
						       (OS.FileSys.remove dst
							handle OS.SysErr _ =>
							       ErrorMsg.error NONE ("Delete failed for " ^ dst);
							{action = Slave.Delete,
							 domain = dom,
							 dir = dir,
							 file = dst})
						     | Modify' {src, dst} =>
						       (Slave.shellF ([Config.cp, " ", src, " ", dst],
								   fn cl => "Copy failed: " ^ cl);
							{action = Slave.Modify,
							 domain = dom,
							 dir = dir,
							 file = dst})) diffs
			       in
				   if !ErrorMsg.anyErrors then
				       ()
				   else
				       Slave.handleChanges diffs;
				   ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, "/*"],
						      fn cl => "Temp file cleanup failed: " ^ cl))
			       end)


end
Commit	Line	Data
	1	(* HCoop Domtool (http://hcoop.sourceforge.net/)
	2	* Copyright (c) 2006, Adam Chlipala
	3	*
	4	* This program is free software; you can redistribute it and/or
	5	* modify it under the terms of the GNU General Public License
	6	* as published by the Free Software Foundation; either version 2
	7	* of the License, or (at your option) any later version.
	8	*
	9	* This program is distributed in the hope that it will be useful,
	10	* but WITHOUT ANY WARRANTY; without even the implied warranty of
	11	* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	12	* GNU General Public License for more details.
	13	*
	14	* You should have received a copy of the GNU General Public License
	15	* along with this program; if not, write to the Free Software
	16	* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
	17	*)
	18
	19	(* Domain-related primitive actions *)
	20
	21	structure Domain :> DOMAIN = struct
	22
	23	fun validIp s =
	24	case map Int.fromString (String.fields (fn ch => ch = #".") s) of
	25	[SOME n1, SOME n2, SOME n3, SOME n4] =>
	26	n1 >= 0 andalso n1 < 256 andalso n2 >= 0 andalso n2 < 256 andalso n3 >= 0 andalso n3 < 256 andalso n4 >= 0 andalso n4 < 256
	27	\| _ => false
	28
	29	fun isIdent ch = Char.isLower ch orelse Char.isDigit ch
	30
	31	fun validHost s =
	32	size s > 0 andalso size s < 20
	33	andalso CharVector.all (fn ch => isIdent ch orelse ch = #"-") s
	34
	35	fun validDomain s =
	36	size s > 0 andalso size s < 100
	37	andalso List.all validHost (String.fields (fn ch => ch = #".") s)
	38
	39	val _ = Env.type_one "ip"
	40	Env.string
	41	validIp
	42
	43	val _ = Env.type_one "host"
	44	Env.string
	45	validHost
	46
	47	val _ = Env.type_one "domain"
	48	Env.string
	49	validDomain
	50
	51	open Ast
	52
	53	val dl = ErrorMsg.dummyLoc
	54
	55	val nsD = (EString Config.defaultNs, dl)
	56	val serialD = (EVar "serialAuto", dl)
	57	val refD = (EInt Config.defaultRefresh, dl)
	58	val retD = (EInt Config.defaultRetry, dl)
	59	val expD = (EInt Config.defaultExpiry, dl)
	60	val minD = (EInt Config.defaultMinimum, dl)
	61
	62	val soaD = multiApp ((EVar "soa", dl),
	63	dl,
	64	[nsD, serialD, refD, retD, expD, minD])
	65
	66	val _ = Main.registerDefault ("DNS",
	67	(TBase "dnsKind", dl),
	68	(EApp ((EVar "master", dl),
	69	soaD), dl))
	70
	71	val _ = Main.registerDefault ("TTL",
	72	(TBase "int", dl),
	73	(EInt Config.Bind.defaultTTL, dl))
	74
	75	type soa = {ns : string,
	76	serial : int option,
	77	ref : int,
	78	ret : int,
	79	exp : int,
	80	min : int}
	81
	82	val serial = fn (EVar "serialAuto", _) => SOME NONE
	83	\| (EApp ((EVar "serialConst", _), n), _) => Option.map SOME (Env.int n)
	84	\| _ => NONE
	85
	86	val soa = fn (EApp ((EApp ((EApp ((EApp ((EApp ((EApp
	87	((EVar "soa", _), ns), _),
	88	sl), _),
	89	rf), _),
	90	ret), _),
	91	exp), _),
	92	min), _) =>
	93	(case (Env.string ns, serial sl, Env.int rf,
	94	Env.int ret, Env.int exp, Env.int min) of
	95	(SOME ns, SOME sl, SOME rf,
	96	SOME ret, SOME exp, SOME min) =>
	97	SOME {ns = ns,
	98	serial = sl,
	99	ref = rf,
	100	ret = ret,
	101	exp = exp,
	102	min = min}
	103	\| _ => NONE)
	104	\| _ => NONE
	105
	106	datatype dnsKind =
	107	Master of soa
	108	\| Slave of soa
	109	\| NoDns
	110
	111	val dnsKind = fn (EApp ((EVar "master", _), e), _) => Option.map Master (soa e)
	112	\| (EApp ((EVar "slave", _), e), _) => Option.map Slave (soa e)
	113	\| (EVar "noDns", _) => SOME NoDns
	114	\| _ => NONE
	115
	116	val befores = ref (fn (_ : string) => ())
	117	val afters = ref (fn (_ : string) => ())
	118
	119	fun registerBefore f =
	120	let
	121	val old = !befores
	122	in
	123	befores := (fn x => (old x; f x))
	124	end
	125
	126	fun registerAfter f =
	127	let
	128	val old = !afters
	129	in
	130	afters := (fn x => (old x; f x))
	131	end
	132
	133	val current = ref ""
	134	val currentPath = ref ""
	135
	136	val scratch = ref ""
	137
	138	fun currentDomain () = !current
	139
	140	fun domainFile name = TextIO.openOut (!currentPath ^ name)
	141
	142	fun getPath domain =
	143	let
	144	val toks = String.fields (fn ch => ch = #".") domain
	145
	146	val elems = foldr (fn (piece, elems) =>
	147	let
	148	val elems = piece :: elems
	149	val path = String.concatWith "/" (Config.resultRoot :: rev elems)
	150	val tmpPath = String.concatWith "/" (Config.tmpDir :: rev elems)
	151	in
	152	(if Posix.FileSys.ST.isDir
	153	(Posix.FileSys.stat path) then
	154	()
	155	else
	156	(OS.FileSys.remove path;
	157	OS.FileSys.mkDir path))
	158	handle OS.SysErr _ => OS.FileSys.mkDir path;
	159
	160	(if Posix.FileSys.ST.isDir
	161	(Posix.FileSys.stat tmpPath) then
	162	()
	163	else
	164	(OS.FileSys.remove tmpPath;
	165	OS.FileSys.mkDir tmpPath))
	166	handle OS.SysErr _ => OS.FileSys.mkDir tmpPath;
	167
	168	elems
	169	end) [] toks
	170	in
	171	fn root => String.concatWith "/" (root :: rev ("" :: elems))
	172	end
	173
	174	datatype file_action' =
	175	Add' of {src : string, dst : string}
	176	\| Delete' of string
	177	\| Modify' of {src : string, dst : string}
	178
	179	fun findDiffs dom =
	180	let
	181	val realPath = getPath dom Config.resultRoot
	182	val tmpPath = !currentPath
	183
	184	val dir = Posix.FileSys.opendir realPath
	185
	186	fun loopReal acts =
	187	case Posix.FileSys.readdir dir of
	188	NONE => (Posix.FileSys.closedir dir;
	189	acts)
	190	\| SOME fname =>
	191	let
	192	val real = OS.Path.joinDirFile {dir = realPath,
	193	file = fname}
	194	val tmp = OS.Path.joinDirFile {dir = tmpPath,
	195	file = fname}
	196	in
	197	if Posix.FileSys.ST.isDir (Posix.FileSys.stat real) then
	198	loopReal acts
	199	else if Posix.FileSys.access (tmp, []) then
	200	if Slave.shell [Config.diff, " ", real, " ", tmp] then
	201	loopReal acts
	202	else
	203	loopReal (Modify' {src = tmp, dst = real} :: acts)
	204	else
	205	loopReal (Delete' real :: acts)
	206	end
	207
	208	val acts = loopReal []
	209
	210	val dir = Posix.FileSys.opendir tmpPath
	211
	212	fun loopTmp acts =
	213	case Posix.FileSys.readdir dir of
	214	NONE => (Posix.FileSys.closedir dir;
	215	acts)
	216	\| SOME fname =>
	217	let
	218	val real = OS.Path.joinDirFile {dir = realPath,
	219	file = fname}
	220	val tmp = OS.Path.joinDirFile {dir = tmpPath,
	221	file = fname}
	222	in
	223	if Posix.FileSys.ST.isDir (Posix.FileSys.stat tmp) then
	224	loopTmp acts
	225	else if Posix.FileSys.access (real, []) then
	226	loopTmp acts
	227	else
	228	loopTmp (Add' {src = tmp, dst = real} :: acts)
	229	end
	230
	231	val acts = loopTmp acts
	232	in
	233	acts
	234	end
	235
	236	val _ = Env.containerV_one "domain"
	237	("domain", Env.string)
	238	(fn (evs, dom) =>
	239	let
	240	val kind = Env.env dnsKind (evs, "DNS")
	241	val ttl = Env.env Env.int (evs, "TTL")
	242
	243	val path = getPath dom Config.tmpDir
	244
	245	val () = (current := dom;
	246	currentPath := path;
	247	!befores dom)
	248
	249	fun saveSoa (kind, soa : soa) =
	250	let
	251	val outf = domainFile "soa"
	252	in
	253	TextIO.output (outf, kind);
	254	TextIO.output (outf, "\n");
	255	TextIO.output (outf, Int.toString ttl);
	256	TextIO.output (outf, "\n");
	257	TextIO.output (outf, #ns soa);
	258	TextIO.output (outf, "\n");
	259	case #serial soa of
	260	NONE => ()
	261	\| SOME n => TextIO.output (outf, Int.toString n);
	262	TextIO.output (outf, "\n");
	263	TextIO.output (outf, Int.toString (#ref soa));
	264	TextIO.output (outf, "\n");
	265	TextIO.output (outf, Int.toString (#ret soa));
	266	TextIO.output (outf, "\n");
	267	TextIO.output (outf, Int.toString (#exp soa));
	268	TextIO.output (outf, "\n");
	269	TextIO.output (outf, Int.toString (#min soa));
	270	TextIO.output (outf, "\n");
	271	TextIO.closeOut outf
	272	end
	273
	274	fun saveNamed (kind, soa : soa) =
	275	let
	276	val outf = domainFile "named.conf"
	277	in
	278	TextIO.output (outf, "\nzone \"");
	279	TextIO.output (outf, dom);
	280	TextIO.output (outf, "\" IN {\n\ttype ");
	281	TextIO.output (outf, kind);
	282	TextIO.output (outf, ";\n\tfile \"");
	283	TextIO.output (outf, Config.Bind.zonePath);
	284	TextIO.output (outf, "/");
	285	TextIO.output (outf, dom);
	286	TextIO.output (outf, ".zone\";\n");
	287	case kind of
	288	"master" => TextIO.output (outf, "\tallow-update { none; };\n")
	289	\| _ => TextIO.output (outf, "\tmasters { 1.2.3.4; };\n");
	290	TextIO.output (outf, "}\n");
	291	TextIO.closeOut outf
	292	end
	293
	294	fun saveBoth ks = (saveSoa ks; saveNamed ks)
	295	in
	296	case kind of
	297	NoDns => ()
	298	\| Master soa => saveBoth ("master", soa)
	299	\| Slave soa => saveBoth ("slave", soa)
	300	end,
	301	fn () =>
	302	let
	303	val dom = !current
	304	val () = !afters dom
	305
	306	val diffs = findDiffs dom
	307
	308	val dir = getPath dom Config.resultRoot
	309
	310	val diffs = map (fn Add' {src, dst} =>
	311	(Slave.shellF ([Config.cp, " ", src, " ", dst],
	312	fn cl => "Copy failed: " ^ cl);
	313	{action = Slave.Add,
	314	domain = dom,
	315	dir = dir,
	316	file = dst})
	317	\| Delete' dst =>
	318	(OS.FileSys.remove dst
	319	handle OS.SysErr _ =>
	320	ErrorMsg.error NONE ("Delete failed for " ^ dst);
	321	{action = Slave.Delete,
	322	domain = dom,
	323	dir = dir,
	324	file = dst})
	325	\| Modify' {src, dst} =>
	326	(Slave.shellF ([Config.cp, " ", src, " ", dst],
	327	fn cl => "Copy failed: " ^ cl);
	328	{action = Slave.Modify,
	329	domain = dom,
	330	dir = dir,
	331	file = dst})) diffs
	332	in
	333	if !ErrorMsg.anyErrors then
	334	()
	335	else
	336	Slave.handleChanges diffs;
	337	ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, "/*"],
	338	fn cl => "Temp file cleanup failed: " ^ cl))
	339	end)
	340
	341
	342
	343	end