[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

open MsgTypes

structure SM = DataStructures.StringMap
structure SS = DataStructures.StringSet

val ssl_context = ref (NONE : OpenSSL.context option)
fun set_context ctx = ssl_context := SOME ctx

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 := user;
     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.masterNode, dl)),
	       dl)

val slavesD = (EList (map (fn s => (EString s, dl)) Config.slaveNodes), dl)

val _ = Defaults.registerDefault ("Mailbox",
				  (TBase "email", dl),
				  (fn () => (EString (getUser ()), dl)))

val _ = Defaults.registerDefault ("DNS",
				  (TBase "dnsKind", dl),
				  (fn () => multiApp ((EVar "useDns", dl),
						      dl,
						      [soaD, masterD, slavesD])))

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 ip = Env.string

val _ = Env.registerFunction ("ip_of_node",
			      fn [(EString node, _)] => SOME (EString (nodeIp node), dl)
			       | _ => NONE)

val master = fn (EApp ((EVar "externalMaster", _), e), _) => Option.map ExternalMaster (ip 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
		    exploreSites (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_real);
					   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 let
					  val changed = foldl (fn ((site, file), changed) =>
								  let
								      val ls = case SM.find (changed, site) of
										   NONE => []
										 | SOME ls => ls
								  in
								      SM.insert (changed, site, file :: ls)
								  end) SM.empty diffs

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