X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/blobdiff_plain/0da1c677dd0a079c9e985af37688cc9e833fc196..1638d5a206cd79e9619f0d3334fed29eaddc6b51:/src/domain.sml

diff --git a/src/domain.sml b/src/domain.sml
index 7ee4690..064aa3e 100644
--- a/src/domain.sml
+++ b/src/domain.sml
@@ -1,5 +1,5 @@
 (* HCoop Domtool (http://hcoop.sourceforge.net/)
- * Copyright (c) 2006, Adam Chlipala
+ * Copyright (c) 2006-2007, Adam Chlipala
  *
  * This program is free software; you can redistribute it and/or
  * modify it under the terms of the GNU General Public License
@@ -48,16 +48,26 @@ fun your_groups () = !your_grps
 val your_pths = ref SS.empty
 fun your_paths () = !your_pths
 
+val world_readable = SS.addList (SS.empty, Config.worldReadable)
+val readable_pths = ref SS.empty
+fun readable_paths () = !readable_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"})
+    let
+	val () = usr := user
+
+	val your_paths = Acl.class {user = getUser (),
+				    class = "path"}
+    in
+	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 := your_paths;
+	readable_pths := SS.union (your_paths, world_readable)
+    end
 
 fun validIp s =
     case map Int.fromString (String.fields (fn ch => ch = #".") s) of
@@ -80,11 +90,13 @@ 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 =
+fun checkPath paths 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 ())
+    andalso SS.exists (fn s' => path = s' orelse String.isPrefix (s' ^ "/") path) (paths ())
+val yourPath = checkPath your_paths
+val readablePath = checkPath readable_paths
 
 fun yourDomainHost s =
     yourDomain s
@@ -114,10 +126,12 @@ val validGroup = validUser
 
 val _ = Env.type_one "no_spaces"
 		     Env.string
-		     (CharVector.all (fn ch => not (Char.isSpace ch)))
+		     (CharVector.all (fn ch => Char.isPrint ch andalso not (Char.isSpace ch)
+					       andalso ch <> #"\"" andalso ch <> #"'"))
 val _ = Env.type_one "no_newlines"
 		     Env.string
-		     (CharVector.all (fn ch => ch <> #"\n" andalso ch <> #"\r"))
+		     (CharVector.all (fn ch => Char.isPrint ch andalso ch <> #"\n" andalso ch <> #"\r"
+					       andalso ch <> #"\"" andalso ch <> #"'"))
 
 val _ = Env.type_one "ip"
 	Env.string
@@ -159,6 +173,10 @@ val _ = Env.type_one "your_path"
 	Env.string
 	yourPath
 
+val _ = Env.type_one "readable_path"
+	Env.string
+	readablePath
+
 val _ = Env.type_one "node"
 	Env.string
 	validNode
@@ -191,6 +209,10 @@ val masterD = (EApp ((EVar "internalMaster", 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)))
@@ -309,14 +331,34 @@ 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
@@ -480,59 +522,66 @@ val _ = Env.containerV_one "domain"
 			       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;
-					     currentPath := (fn site => path (Config.tmpDir, site)))
+					     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 outf = domainFile {node = node, name = "soa"}
+					   val {write, writeDom, close} = domainsFile {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");
+					   write kind;
+					   write "\n";
+					   write (Int.toString ttl);
+					   write "\n";
+					   write (#ns soa);
+					   write "\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
+					     | 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 =
+				   fun saveNamed (kind, soa : soa, masterIp, slaveIps) node =
 				       if dom = "localhost" then
 					   ()
 				       else let
-					       val outf = domainFile {node = node, name = "named.conf"}
+					       val {write, writeDom, close} = domainsFile {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");
+					       write "\nzone \"";
+					       writeDom ();
+					       write "\" {\n\ttype ";
+					       write kind;
+					       write ";\n\tfile \"";
+					       write Config.Bind.zonePath_real;
+					       write "/";
+					       writeDom ();
+					       write ".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
+						   "master" => (write "\tallow-transfer {\n";
+								app (fn ip => (write "\t\t";
+									       write ip;
+									       write ";\n")) slaveIps;
+								write "\t};\n")
+						 | _ => (write "\tmasters { ";
+							 write masterIp;
+							 write "; };\n");
+					       write "};\n";
+					       close ()
 					   end
 			       in
 				   case kind of
@@ -541,19 +590,21 @@ val _ = Env.containerV_one "domain"
 				       let
 					   val masterIp =
 					       case #master dns of
-						   InternalMaster node => valOf (SM.find (nodeMap, node))
+						   InternalMaster node => nodeIp node
 						 | ExternalMaster ip => ip
+
+					   val slaveIps = map nodeIp (#slaves dns)
 				       in
 					   app (saveSoa ("slave", #soa dns)) (#slaves dns);
-					   app (saveNamed ("slave", #soa dns, masterIp)) (#slaves dns);
+					   app (saveNamed ("slave", #soa dns, masterIp, slaveIps)) (#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
+						saveNamed ("master", #soa dns, masterIp, slaveIps) node)
+					     | _ => masterNode := NONE
+				       end;
+				   !befores dom
 			       end,
 			    fn () => !afters (!current))
 
@@ -616,7 +667,7 @@ val () = Env.registerPost (fn () =>
 						       handle OS.SysErr _ =>
 							      ErrorMsg.error NONE ("Delete failed for " ^ dst);
 						       (site,
-							{action = Slave.Delete,
+							{action = Slave.Delete true,
 							 domain = dom,
 							 dir = dir,
 							 file = dst}))
@@ -664,11 +715,11 @@ val _ = Env.type_one "mail_node"
 	    orelse (hasPriv "mail"
 		    andalso List.exists (fn x => x = node) Config.mailNodes_admin))
 
-fun rmdom doms =
+fun rmdom' delete resultRoot doms =
     let
 	fun doNode (node, _) =
 	    let
-		val dname = OS.Path.joinDirFile {dir = Config.resultRoot,
+		val dname = OS.Path.joinDirFile {dir = resultRoot,
 						 file = node}
 
 		fun doDom (dom, actions) =
@@ -692,18 +743,19 @@ fun rmdom doms =
 						loop (visitDom (fname ^ "." ^ dom,
 								fnameFull,
 								actions))
-					    else							
-						loop ({action = Slave.Delete,
-						       domain = dom,
-						       dir = dname,
-						       file = fnameFull} :: actions)
+					    else			
+						(print ("Kill " ^ fnameFull ^ "\n");
+						 loop ({action = Slave.Delete 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");
+				handle OS.SysErr (s, _) =>
+				       (print ("Warning: System error deleting domain " ^ dom ^ " on " ^ node ^ ": " ^ s ^ "\n");
 					actions)
 		    in
 			visitDom (dom, dname, actions)
@@ -720,11 +772,14 @@ fun rmdom doms =
 		fun doDom dom =
 		    let
 			val domPath = String.concatWith "/" (rev (String.fields (fn ch => ch = #".") dom))
-			val dname = OS.Path.joinDirFile {dir = Config.resultRoot,
+			val dname = OS.Path.joinDirFile {dir = resultRoot,
 							 file = node}
 			val dname = OS.Path.concat (dname, domPath)
 		    in
-			ignore (OS.Process.system (Config.rm ^ " -rf " ^ dname))
+			if delete then
+			    ignore (OS.Process.system (Config.rm ^ " -rf " ^ dname))
+			else
+			    ()
 		    end
 	    in
 		app doDom doms
@@ -734,9 +789,108 @@ fun rmdom doms =
 	app cleanupNode Config.nodeIps
     end
 
+val rmdom = rmdom' true Config.resultRoot
+val rmdom' = rmdom' false
+
 fun homedirOf uname =
     Posix.SysDB.Passwd.home (Posix.SysDB.getpwnam uname)
 
 fun homedir () = homedirOf (getUser ())
 
+type subject = {node : string, domain : string}
+
+val describers : (subject -> string) list ref = ref []
+
+fun registerDescriber f = describers := f :: !describers
+
+fun describeOne arg = String.concat (map (fn f => f arg) (rev (!describers)))
+
+val line = "--------------------------------------------------------------\n"
+val dline = "==============================================================\n"
+
+fun describe dom =
+    String.concat (List.mapPartial
+		       (fn node =>
+			   case describeOne {node = node, domain = dom} of
+			       "" => NONE
+			     | s =>
+			       SOME (String.concat [dline, "Node ", node, "\n", dline, "\n", s]))
+		       nodes)
+
+datatype description =
+	 Filename of { filename : string, heading : string, showEmpty : bool }
+       | Extension of { extension : string, heading : string -> string }
+			
+fun considerAll ds {node, domain} =
+    let
+	val ds = map (fn d => (d, ref [])) ds
+
+	val path = Config.resultRoot
+	val jdf = OS.Path.joinDirFile
+	val path = jdf {dir = path, file = node}
+	val path = foldr (fn (more, path) => jdf {dir = path, file = more})
+			 path (String.tokens (fn ch => ch = #".") domain)
+    in
+	if Posix.FileSys.access (path, []) then
+	    let
+		val dir = Posix.FileSys.opendir path
+
+		fun loop () =
+		    case Posix.FileSys.readdir dir of
+			NONE => ()
+		      | SOME fname =>
+			(app (fn (d, entries) =>
+				 let
+				     fun readFile showEmpty entries' =
+					 let
+					     val fname = OS.Path.joinDirFile {dir = path,
+									      file = fname}
+
+					     val inf = TextIO.openIn fname
+
+					     fun loop (seenOne, entries') =
+						 case TextIO.inputLine inf of
+						     NONE => if seenOne orelse showEmpty then
+								 "\n" :: entries'
+							     else
+								 !entries
+						   | SOME line => loop (true, line :: entries')
+					 in
+					     loop (false, entries')
+					     before TextIO.closeIn inf
+					 end
+				 in
+				     case d of
+					 Filename {filename, heading, showEmpty} =>
+					 if fname = filename then
+					     entries := readFile showEmpty ("\n" :: line :: ":\n" :: heading :: line :: !entries)
+					 else
+					     ()
+				       | Extension {extension, heading} =>
+					 let
+					     val {base, ext} = OS.Path.splitBaseExt fname
+					 in
+					     case ext of
+						 NONE => ()
+					       | SOME extension' =>
+						 if extension' = extension then
+						     entries := readFile true ("\n" :: line :: ":\n" :: heading base :: line :: !entries)
+						 else
+						     ()
+					 end
+				 end) ds;
+			 loop ())
+	    in
+		loop ();
+		Posix.FileSys.closedir dir;
+		String.concat (List.concat (map (fn (_, entries) => rev (!entries)) ds))
+	    end
+	else
+	    ""
+    end
+
+val () = registerDescriber (considerAll [Filename {filename = "soa",
+						   heading = "DNS SOA",
+						   showEmpty = false}])
+
 end