[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

val yourDomain = yourDomainHost

fun validUser s = size s > 0 andalso size s < 20
		  andalso CharVector.all Char.isAlphaNum s

fun validEmailUser s =
    size s > 0 andalso size s < 50
    andalso CharVector.all (fn ch => Char.isAlphaNum ch
				     orelse ch = #"."
				     orelse ch = #"_"
				     orelse ch = #"-"
				     orelse ch = #"+") 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 ("dns_node_to_node",
			      fn [e] => SOME e
			       | _ => NONE)

val _ = Env.registerFunction ("mail_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 ("Aliases",
				  (TList (TBase "your_domain", dl), dl),
				  (fn () => (EList [], 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 globals = ref (fn () => ())
val locals = ref (fn () => ())

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

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

fun resetGlobal () = (!globals ();
		      ignore (OS.Process.system (Config.rm ^ " -rf " ^ Config.resultRoot ^ "/*")))
fun resetLocal () = !locals ()

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

val scratch = ref ""

fun currentDomain () = !current

val currentsAli = ref ([] : string list)

fun currentAliasDomains () = !currentsAli
fun currentDomains () = currentDomain () :: currentAliasDomains ()

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

type files = {write : string -> unit,
	      writeDom : unit -> unit,
	      close : unit -> unit}

fun domainsFile {node, name} =
    let
	val doms = currentDomains ()
	val files = map (fn dom => (dom, TextIO.openOut (!currentPathAli (dom, node) ^ name))) doms
    in
	{write = fn s => app (fn (_, outf) => TextIO.output (outf, s)) files,
	 writeDom = fn () => app (fn (dom, outf) => TextIO.output (outf, dom)) files,
	 close = fn () => app (fn (_, outf) => TextIO.closeOut outf) files}
    end

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 aliases = Env.env (Env.list Env.string) (evs, "Aliases")

				   val path = getPath dom

				   val () = (current := dom;
					     currentsAli := Slave.remove (Slave.removeDups aliases, dom);
					     currentPath := (fn site => path (Config.tmpDir, site));
					     currentPathAli := (fn (dom, site) => getPath dom (Config.tmpDir, site)))

				   fun saveSoa (kind, soa : soa) node =
				       let
					   val {write, writeDom, close} = domainsFile {node = node, name = "soa"}
				       in
					   write kind;
					   write "\n";
					   write (Int.toString ttl);
					   write "\n";
					   write (#ns soa);
					   write "\n";
					   case #serial soa of
					       NONE => ()
					     | SOME n => write (Int.toString n);
					   write "\n";
					   write (Int.toString (#ref soa));
					   write "\n";
					   write (Int.toString (#ret soa));
					   write "\n";
					   write (Int.toString (#exp soa));
					   write "\n";
					   write (Int.toString (#min soa));
					   write "\n";
					   close ()
				       end

				   fun saveNamed (kind, soa : soa, masterIp) node =
				       if dom = "localhost" then
					   ()
				       else let
					       val {write, writeDom, close} = domainsFile {node = node, name = "named.conf"}
					   in
					       write "\nzone \"";
					       writeDom ();
					       write "\" IN {\n\ttype ";
					       write kind;
					       write ";\n\tfile \"";
					       write Config.Bind.zonePath_real;
					       write "/";
					       writeDom ();
					       write ".zone\";\n";
					       case kind of
						   "master" => write "\tallow-update { none; };\n"
						 | _ => (write "\tmasters { ";
							 write masterIp;
							 write "; };\n");
					       write "};\n";
					       close ()
					   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))

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

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
				      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))

val _ = Env.type_one "mail_node"
	Env.string
	(fn node =>
	    List.exists (fn x => x = node) Config.mailNodes_all
	    orelse (hasPriv "mail"
		    andalso List.exists (fn x => x = node) Config.mailNodes_admin))

fun rmdom doms =
    let
	fun doNode (node, _) =
	    let
		val dname = OS.Path.joinDirFile {dir = Config.resultRoot,
						 file = node}

		fun doDom (dom, actions) =
		    let
			val domPath = String.concatWith "/" (rev (String.fields (fn ch => ch = #".") dom))
			val dname = OS.Path.concat (dname, domPath)

			fun visitDom (dom, dname, actions) =
			    let
				val dir = Posix.FileSys.opendir dname

				fun loop actions =
				    case Posix.FileSys.readdir dir of
					NONE => actions
				      | SOME fname =>
					let
					    val fnameFull = OS.Path.joinDirFile {dir = dname,
										 file = fname}
					in
					    if Posix.FileSys.ST.isDir (Posix.FileSys.stat fnameFull) then
						loop (visitDom (fname ^ "." ^ dom,
								fnameFull,
								actions))
					    else							
						loop ({action = Slave.Delete,
						       domain = dom,
						       dir = dname,
						       file = fnameFull} :: actions)
					end
			    in
				loop actions
				before Posix.FileSys.closedir dir
			    end
				handle OS.SysErr _ =>
				       (print ("Warning: System error deleting domain " ^ dom ^ " on " ^ node ^ ".\n");
					actions)
		    in
			visitDom (dom, dname, actions)
		    end

		val actions = foldl doDom [] doms
	    in
		handleSite (node, actions)
	    end
		handle IO.Io _ => print ("Warning: IO error deleting domains on " ^ node ^ ".\n")

	fun cleanupNode (node, _) =
	    let
		fun doDom dom =
		    let
			val domPath = String.concatWith "/" (rev (String.fields (fn ch => ch = #".") dom))
			val dname = OS.Path.joinDirFile {dir = Config.resultRoot,
							 file = node}
			val dname = OS.Path.concat (dname, domPath)
		    in
			ignore (OS.Process.system (Config.rm ^ " -rf " ^ dname))
		    end
	    in
		app doDom doms
	    end
    in
	app doNode Config.nodeIps;
	app cleanupNode Config.nodeIps
    end

fun homedirOf uname =
    Posix.SysDB.Passwd.home (Posix.SysDB.getpwnam uname)

fun homedir () = homedirOf (getUser ())

end