X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/blobdiff_plain/a3698041b3521c3cb17b3546ecdc08ba101c788a..976657583f419a6a204400ea90f9758d15243acb:/src/domain.sml

diff --git a/src/domain.sml b/src/domain.sml
index e38ea4a..15903a2 100644
--- a/src/domain.sml
+++ b/src/domain.sml
@@ -14,14 +14,239 @@
  * 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.defaultNode, dl)),
+	       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, (EList [], dl)])))
+
+val _ = Defaults.registerDefault ("TTL",
+				  (TBase "int", dl),
+				  (fn () => (EInt Config.Bind.defaultTTL, dl)))
+
+type soa = {ns : string,
+	    serial : int option,
+	    ref : int,
+	    ret : int,
+	    exp : int,
+	    min : int}
+
+val serial = fn (EVar "serialAuto", _) => SOME NONE
+	      | (EApp ((EVar "serialConst", _), n), _) => Option.map SOME (Env.int n)
+	      | _ => NONE
+
+val soa = fn (EApp ((EApp ((EApp ((EApp ((EApp ((EApp 
+						     ((EVar "soa", _), ns), _),
+						sl), _),
+					 rf), _),
+				  ret), _),
+			   exp), _),
+		    min), _) =>
+	     (case (Env.string ns, serial sl, Env.int rf,
+		    Env.int ret, Env.int exp, Env.int min) of
+		  (SOME ns, SOME sl, SOME rf,
+		   SOME ret, SOME exp, SOME min) =>
+		  SOME {ns = ns,
+			serial = sl,
+			ref = rf,
+			ret = ret,
+			exp = exp,
+			min = min}
+		| _ => NONE)
+	   | _ => NONE
+
+datatype master =
+	 ExternalMaster of string
+       | InternalMaster of string
+
+val ip = fn (EApp ((EVar "ip_of_node", _), e), _) => Option.map nodeIp (Env.string e)
+	  | e => Env.string e
+
+val master = fn (EApp ((EVar "externalMaster", _), e), _) => Option.map ExternalMaster (ip e)
+	      | (EApp ((EVar "internalMaster", _), e), _) => Option.map InternalMaster (ip 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) => ())
 
@@ -40,12 +265,341 @@ fun registerAfter f =
     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 _ = Env.registerContainer ("domain",
-			    fn (_, [(EString dom, _)]) => (current := dom;
-							   !befores dom;
-							   StringMap.empty)
-			     | _ => Env.badArgs "domain",
+	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