[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

val _ = Env.registerFunction ("web_node_to_node",
			      fn [e] => SOME e
			       | _ => NONE)
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)

fun hasPriv priv = Acl.query {user = getUser (), class = "priv", value = "all"}
		   orelse Acl.query {user = getUser (), class = "priv", value = priv}

val _ = Env.type_one "dns_node"
	Env.string
	(fn node =>
	    List.exists (fn x => x = node) Config.dnsNodes_all
	    orelse (hasPriv "dns"
		    andalso List.exists (fn x => x = node) Config.dnsNodes_admin))

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
be1bea4c AC	156	val _ = Env.registerFunction ("web_node_to_node",
	157	fn [e] => SOME e
	158	\| _ => NONE)
a3698041 AC	159	open Ast
a3698041 AC	160
6ae327f8 AC	161	val dl = ErrorMsg.dummyLoc
	162
	163	val nsD = (EString Config.defaultNs, dl)
	164	val serialD = (EVar "serialAuto", dl)
	165	val refD = (EInt Config.defaultRefresh, dl)
	166	val retD = (EInt Config.defaultRetry, dl)
	167	val expD = (EInt Config.defaultExpiry, dl)
	168	val minD = (EInt Config.defaultMinimum, dl)
	169
	170	val soaD = multiApp ((EVar "soa", dl),
	171	dl,
	172	[nsD, serialD, refD, retD, expD, minD])
	173
e0b0abd2	174	val masterD = (EApp ((EVar "internalMaster", dl),
8b84db5b	175	(EString Config.masterNode, dl)),
e0b0abd2 AC	176	dl)
e0b0abd2 AC	177
8b84db5b AC	178	val slavesD = (EList (map (fn s => (EString s, dl)) Config.slaveNodes), dl)
8b84db5b AC	179
6bb366c5 AC	180	val _ = Defaults.registerDefault ("Mailbox",
	181	(TBase "email", dl),
	182	(fn () => (EString (getUser ()), dl)))
	183
aa56e112 AC	184	val _ = Defaults.registerDefault ("DNS",
	185	(TBase "dnsKind", dl),
	186	(fn () => multiApp ((EVar "useDns", dl),
	187	dl,
8b84db5b	188	[soaD, masterD, slavesD])))
6ae327f8	189
aa56e112 AC	190	val _ = Defaults.registerDefault ("TTL",
	191	(TBase "int", dl),
	192	(fn () => (EInt Config.Bind.defaultTTL, dl)))
6ae327f8 AC	193
	194	type soa = {ns : string,
	195	serial : int option,
	196	ref : int,
	197	ret : int,
	198	exp : int,
	199	min : int}
	200
	201	val serial = fn (EVar "serialAuto", _) => SOME NONE
	202	\| (EApp ((EVar "serialConst", _), n), _) => Option.map SOME (Env.int n)
	203	\| _ => NONE
	204
	205	val soa = fn (EApp ((EApp ((EApp ((EApp ((EApp ((EApp
	206	((EVar "soa", _), ns), _),
	207	sl), _),
	208	rf), _),
	209	ret), _),
	210	exp), _),
	211	min), _) =>
	212	(case (Env.string ns, serial sl, Env.int rf,
	213	Env.int ret, Env.int exp, Env.int min) of
	214	(SOME ns, SOME sl, SOME rf,
	215	SOME ret, SOME exp, SOME min) =>
	216	SOME {ns = ns,
	217	serial = sl,
	218	ref = rf,
	219	ret = ret,
	220	exp = exp,
	221	min = min}
	222	\| _ => NONE)
	223	\| _ => NONE
	224
e0b0abd2 AC	225	datatype master =
	226	ExternalMaster of string
	227	\| InternalMaster of string
	228
cf879b4f AC	229	val ip = Env.string
	230
	231	val _ = Env.registerFunction ("ip_of_node",
	232	fn [(EString node, _)] => SOME (EString (nodeIp node), dl)
	233	\| _ => NONE)
97665758 AC	234
97665758 AC	235	val master = fn (EApp ((EVar "externalMaster", _), e), _) => Option.map ExternalMaster (ip e)
8b84db5b	236	\| (EApp ((EVar "internalMaster", _), e), _) => Option.map InternalMaster (Env.string e)
e0b0abd2 AC	237	\| _ => NONE
e0b0abd2 AC	238
6ae327f8	239	datatype dnsKind =
e0b0abd2 AC	240	UseDns of {soa : soa,
	241	master : master,
	242	slaves : string list}
6ae327f8 AC	243	\| NoDns
6ae327f8 AC	244
e0b0abd2 AC	245	val dnsKind = fn (EApp ((EApp ((EApp
	246	((EVar "useDns", _), sa), _),
	247	mstr), _),
	248	slaves), _) =>
	249	(case (soa sa, master mstr, Env.list Env.string slaves) of
	250	(SOME sa, SOME mstr, SOME slaves) =>
	251	SOME (UseDns {soa = sa,
	252	master = mstr,
	253	slaves = slaves})
	254	\| _ => NONE)
325285ab	255	\| (EVar "noDns", _) => SOME NoDns
6ae327f8 AC	256	\| _ => NONE
6ae327f8 AC	257
a3698041 AC	258	val befores = ref (fn (_ : string) => ())
	259	val afters = ref (fn (_ : string) => ())
	260
	261	fun registerBefore f =
	262	let
	263	val old = !befores
	264	in
	265	befores := (fn x => (old x; f x))
	266	end
	267
	268	fun registerAfter f =
	269	let
	270	val old = !afters
	271	in
	272	afters := (fn x => (old x; f x))
	273	end
	274
	275	val current = ref ""
e0b0abd2	276	val currentPath = ref (fn (_ : string) => "")
dac62e84	277
d612d62c AC	278	val scratch = ref ""
d612d62c AC	279
dac62e84 AC	280	fun currentDomain () = !current
dac62e84 AC	281
e0b0abd2 AC	282	fun domainFile {node, name} = ((print ("Opening " ^ !currentPath node ^ name ^ "\n");)
e0b0abd2 AC	283	TextIO.openOut (!currentPath node ^ name))
dac62e84 AC	284
	285	fun getPath domain =
	286	let
	287	val toks = String.fields (fn ch => ch = #".") domain
	288
	289	val elems = foldr (fn (piece, elems) =>
	290	let
	291	val elems = piece :: elems
d612d62c	292
e0b0abd2 AC	293	fun doNode node =
	294	let
	295	val path = String.concatWith "/"
	296	(Config.resultRoot :: node :: rev elems)
	297	val tmpPath = String.concatWith "/"
	298	(Config.tmpDir :: node :: rev elems)
	299	in
	300	(if Posix.FileSys.ST.isDir
	301	(Posix.FileSys.stat path) then
	302	()
	303	else
	304	(OS.FileSys.remove path;
	305	OS.FileSys.mkDir path))
	306	handle OS.SysErr _ => OS.FileSys.mkDir path;
	307
	308	(if Posix.FileSys.ST.isDir
	309	(Posix.FileSys.stat tmpPath) then
	310	()
	311	else
	312	(OS.FileSys.remove tmpPath;
	313	OS.FileSys.mkDir tmpPath))
	314	handle OS.SysErr _ => OS.FileSys.mkDir tmpPath
	315	end
	316	in
2ed6d0e5	317	app doNode nodes;
dac62e84 AC	318	elems
	319	end) [] toks
	320	in
e0b0abd2	321	fn (root, site) => String.concatWith "/" (root :: site :: rev ("" :: elems))
d612d62c AC	322	end
	323
	324	datatype file_action' =
	325	Add' of {src : string, dst : string}
	326	\| Delete' of string
	327	\| Modify' of {src : string, dst : string}
	328
e0b0abd2	329	fun findDiffs (site, dom, acts) =
d612d62c	330	let
e0b0abd2 AC	331	val gp = getPath dom
	332	val realPath = gp (Config.resultRoot, site)
	333	val tmpPath = gp (Config.tmpDir, site)
	334
	335	(val _ = print ("getDiffs(" ^ site ^ ", " ^ dom ^ ")... " ^ realPath ^ "; " ^ tmpPath ^ "\n"))
d612d62c AC	336
	337	val dir = Posix.FileSys.opendir realPath
	338
	339	fun loopReal acts =
	340	case Posix.FileSys.readdir dir of
	341	NONE => (Posix.FileSys.closedir dir;
	342	acts)
	343	\| SOME fname =>
	344	let
	345	val real = OS.Path.joinDirFile {dir = realPath,
	346	file = fname}
	347	val tmp = OS.Path.joinDirFile {dir = tmpPath,
	348	file = fname}
	349	in
	350	if Posix.FileSys.ST.isDir (Posix.FileSys.stat real) then
	351	loopReal acts
	352	else if Posix.FileSys.access (tmp, []) then
8df2e702	353	if Slave.shell [Config.diff, " ", real, " ", tmp] then
d612d62c AC	354	loopReal acts
d612d62c AC	355	else
e0b0abd2	356	loopReal ((site, dom, realPath, Modify' {src = tmp, dst = real}) :: acts)
d612d62c	357	else
e0b0abd2	358	loopReal ((site, dom, realPath, Delete' real) :: acts)
d612d62c AC	359	end
d612d62c AC	360
e0b0abd2	361	val acts = loopReal acts
d612d62c	362
8df2e702	363	val dir = Posix.FileSys.opendir tmpPath
d612d62c AC	364
	365	fun loopTmp acts =
	366	case Posix.FileSys.readdir dir of
	367	NONE => (Posix.FileSys.closedir dir;
	368	acts)
	369	\| SOME fname =>
	370	let
	371	val real = OS.Path.joinDirFile {dir = realPath,
	372	file = fname}
	373	val tmp = OS.Path.joinDirFile {dir = tmpPath,
	374	file = fname}
	375	in
	376	if Posix.FileSys.ST.isDir (Posix.FileSys.stat tmp) then
	377	loopTmp acts
	378	else if Posix.FileSys.access (real, []) then
	379	loopTmp acts
	380	else
e0b0abd2	381	loopTmp ((site, dom, realPath, Add' {src = tmp, dst = real}) :: acts)
d612d62c AC	382	end
	383
	384	val acts = loopTmp acts
	385	in
	386	acts
dac62e84	387	end
a3698041	388
e0b0abd2 AC	389	fun findAllDiffs () =
	390	let
	391	val dir = Posix.FileSys.opendir Config.tmpDir
	392	val len = length (String.fields (fn ch => ch = #"/") Config.tmpDir) + 1
	393
	394	fun exploreSites diffs =
	395	case Posix.FileSys.readdir dir of
	396	NONE => diffs
	397	\| SOME site =>
	398	let
	399	fun explore (dname, diffs) =
	400	let
	401	val dir = Posix.FileSys.opendir dname
	402
	403	fun loop diffs =
	404	case Posix.FileSys.readdir dir of
	405	NONE => diffs
	406	\| SOME name =>
	407	let
	408	val fname = OS.Path.joinDirFile {dir = dname,
	409	file = name}
	410	in
	411	loop (if Posix.FileSys.ST.isDir (Posix.FileSys.stat fname) then
	412	let
	413	val dom = String.fields (fn ch => ch = #"/") fname
	414	val dom = List.drop (dom, len)
	415	val dom = String.concatWith "." (rev dom)
	416
	417	val dname' = OS.Path.joinDirFile {dir = dname,
	418	file = name}
	419	in
	420	explore (dname',
	421	findDiffs (site, dom, diffs))
	422	end
	423	else
	424	diffs)
	425	end
	426	in
	427	loop diffs
	428	before Posix.FileSys.closedir dir
	429	end
	430	in
36e42cb8 AC	431	exploreSites (explore (OS.Path.joinDirFile {dir = Config.tmpDir,
36e42cb8 AC	432	file = site}, diffs))
e0b0abd2 AC	433	end
	434	in
	435	exploreSites []
	436	before Posix.FileSys.closedir dir
	437	end
	438
	439	val masterNode : string option ref = ref NONE
	440	fun dnsMaster () = !masterNode
	441
6ae327f8 AC	442	val _ = Env.containerV_one "domain"
	443	("domain", Env.string)
	444	(fn (evs, dom) =>
	445	let
	446	val kind = Env.env dnsKind (evs, "DNS")
	447	val ttl = Env.env Env.int (evs, "TTL")
	448
e0b0abd2	449	val path = getPath dom
6ae327f8 AC	450
6ae327f8 AC	451	val () = (current := dom;
e0b0abd2	452	currentPath := (fn site => path (Config.tmpDir, site)))
6ae327f8	453
e0b0abd2	454	fun saveSoa (kind, soa : soa) node =
6ae327f8	455	let
e0b0abd2	456	val outf = domainFile {node = node, name = "soa"}
6ae327f8 AC	457	in
	458	TextIO.output (outf, kind);
	459	TextIO.output (outf, "\n");
	460	TextIO.output (outf, Int.toString ttl);
	461	TextIO.output (outf, "\n");
	462	TextIO.output (outf, #ns soa);
	463	TextIO.output (outf, "\n");
	464	case #serial soa of
	465	NONE => ()
	466	\| SOME n => TextIO.output (outf, Int.toString n);
	467	TextIO.output (outf, "\n");
	468	TextIO.output (outf, Int.toString (#ref soa));
	469	TextIO.output (outf, "\n");
	470	TextIO.output (outf, Int.toString (#ret soa));
	471	TextIO.output (outf, "\n");
	472	TextIO.output (outf, Int.toString (#exp soa));
	473	TextIO.output (outf, "\n");
	474	TextIO.output (outf, Int.toString (#min soa));
	475	TextIO.output (outf, "\n");
	476	TextIO.closeOut outf
	477	end
	478
2ed6d0e5	479	fun saveNamed (kind, soa : soa, masterIp) node =
6ae327f8	480	let
e0b0abd2	481	val outf = domainFile {node = node, name = "named.conf"}
6ae327f8 AC	482	in
	483	TextIO.output (outf, "\nzone \"");
	484	TextIO.output (outf, dom);
	485	TextIO.output (outf, "\" IN {\n\ttype ");
	486	TextIO.output (outf, kind);
	487	TextIO.output (outf, ";\n\tfile \"");
27e20924	488	TextIO.output (outf, Config.Bind.zonePath_real);
6ae327f8 AC	489	TextIO.output (outf, "/");
	490	TextIO.output (outf, dom);
	491	TextIO.output (outf, ".zone\";\n");
	492	case kind of
	493	"master" => TextIO.output (outf, "\tallow-update { none; };\n")
2ed6d0e5 AC	494	\| _ => (TextIO.output (outf, "\tmasters { ");
2ed6d0e5 AC	495	TextIO.output (outf, masterIp);
7d042452	496	TextIO.output (outf, "; };\n"));
2ed6d0e5	497	TextIO.output (outf, "};\n");
6ae327f8 AC	498	TextIO.closeOut outf
6ae327f8 AC	499	end
6ae327f8 AC	500	in
6ae327f8 AC	501	case kind of
e0b0abd2 AC	502	NoDns => masterNode := NONE
e0b0abd2 AC	503	\| UseDns dns =>
2ed6d0e5 AC	504	let
	505	val masterIp =
	506	case #master dns of
	507	InternalMaster node => valOf (SM.find (nodeMap, node))
	508	\| ExternalMaster ip => ip
	509	in
	510	app (saveSoa ("slave", #soa dns)) (#slaves dns);
	511	app (saveNamed ("slave", #soa dns, masterIp)) (#slaves dns);
	512	case #master dns of
	513	InternalMaster node =>
	514	(masterNode := SOME node;
	515	saveSoa ("master", #soa dns) node;
	516	saveNamed ("master", #soa dns, masterIp) node)
	517	\| _ => masterNode := NONE;
	518	!befores dom
	519	end
6ae327f8	520	end,
e0b0abd2 AC	521	fn () => !afters (!current))
	522
	523	val () = Env.registerPre (fn () => (ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, ""],
	524	fn cl => "Temp file cleanup failed: " ^ cl));
	525	OS.FileSys.mkDir Config.tmpDir;
	526	app (fn node => OS.FileSys.mkDir
	527	(OS.Path.joinDirFile {dir = Config.tmpDir,
	528	file = node}))
2ed6d0e5	529	nodes;
e0b0abd2 AC	530	app (fn node => OS.FileSys.mkDir
	531	(OS.Path.joinDirFile {dir = Config.resultRoot,
	532	file = node})
	533	handle OS.SysErr _ => ())
2ed6d0e5	534	nodes))
e0b0abd2 AC	535
	536	val () = Env.registerPost (fn () =>
	537	let
	538	val diffs = findAllDiffs ()
6ae327f8	539
e0b0abd2 AC	540	val diffs = map (fn (site, dom, dir, Add' {src, dst}) =>
	541	(Slave.shellF ([Config.cp, " ", src, " ", dst],
	542	fn cl => "Copy failed: " ^ cl);
	543	(site,
6ae327f8 AC	544	{action = Slave.Add,
	545	domain = dom,
	546	dir = dir,
e0b0abd2 AC	547	file = dst}))
	548	\| (site, dom, dir, Delete' dst) =>
	549	(OS.FileSys.remove dst
	550	handle OS.SysErr _ =>
	551	ErrorMsg.error NONE ("Delete failed for " ^ dst);
	552	(site,
6ae327f8 AC	553	{action = Slave.Delete,
	554	domain = dom,
	555	dir = dir,
e0b0abd2 AC	556	file = dst}))
	557	\| (site, dom, dir, Modify' {src, dst}) =>
	558	(Slave.shellF ([Config.cp, " ", src, " ", dst],
	559	fn cl => "Copy failed: " ^ cl);
	560	(site,
6ae327f8 AC	561	{action = Slave.Modify,
	562	domain = dom,
	563	dir = dir,
e0b0abd2 AC	564	file = dst}))) diffs
	565	in
	566	if !ErrorMsg.anyErrors then
	567	()
36e42cb8 AC	568	else let
	569	val changed = foldl (fn ((site, file), changed) =>
	570	let
	571	val ls = case SM.find (changed, site) of
	572	NONE => []
	573	\| SOME ls => ls
	574	in
	575	SM.insert (changed, site, file :: ls)
	576	end) SM.empty diffs
	577
	578	fun handleSite (site, files) =
	579	let
	580
	581	in
	582	print ("New configuration for node " ^ site ^ "\n");
	583	if site = Config.defaultNode then
	584	Slave.handleChanges files
	585	else let
	586	val bio = OpenSSL.connect (valOf (!ssl_context),
	587	nodeIp site
	588	^ ":"
	589	^ Int.toString Config.slavePort)
	590	in
	591	app (fn file => Msg.send (bio, MsgFile file)) files;
	592	Msg.send (bio, MsgDoFiles);
	593	case Msg.recv bio of
	594	NONE => print "Slave closed connection unexpectedly\n"
	595	\| SOME m =>
	596	case m of
	597	MsgOk => print ("Slave " ^ site ^ " finished\n")
	598	\| MsgError s => print ("Slave " ^ site
	599	^ " returned error: " ^
	600	s ^ "\n")
	601	\| _ => print ("Slave " ^ site
	602	^ " returned unexpected command\n");
	603	OpenSSL.close bio
	604	end
	605	end
	606	in
	607	SM.appi handleSite changed
	608	end;
e0b0abd2	609	ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, ""],
559e89e9	610	fn cl => "Temp file cleanup failed: " ^ cl))
e0b0abd2	611	end)
6ae327f8	612
be1bea4c AC	613	fun hasPriv priv = Acl.query {user = getUser (), class = "priv", value = "all"}
	614	orelse Acl.query {user = getUser (), class = "priv", value = priv}
	615
	616	val _ = Env.type_one "dns_node"
	617	Env.string
	618	(fn node =>
	619	List.exists (fn x => x = node) Config.dnsNodes_all
	620	orelse (hasPriv "dns"
	621	andalso List.exists (fn x => x = node) Config.dnsNodes_admin))
60695e99	622
a3698041	623	end