X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/blobdiff_plain/a09d0e829dadfe9c59724b1f953f50d148747f99..fb6fac97106809e2b90f16e9f1d6176c329a5d40:/src/main.sml

diff --git a/src/main.sml b/src/main.sml
index 87f2869..164297f 100644
--- a/src/main.sml
+++ b/src/main.sml
@@ -442,6 +442,21 @@ fun requestRegen () =
 	OpenSSL.close bio
     end
 
+fun requestRegenTc () =
+    let
+	val (_, bio) = requestBio (fn () => ())
+    in
+	Msg.send (bio, MsgRegenerateTc);
+	case Msg.recv bio of
+	    NONE => print "Server closed connection unexpectedly.\n"
+	  | SOME m =>
+	    case m of
+		MsgOk => print "All configuration validated.\n"
+	      | MsgError s => print ("Configuration validation failed: " ^ s ^ "\n")
+	      | _ => print "Unexpected server reply.\n";
+	OpenSSL.close bio
+    end
+
 fun requestRmdom dom =
     let
 	val (_, bio) = requestBio (fn () => ())
@@ -815,6 +830,8 @@ fun regenerate context =
 
 	val () = Domain.resetGlobal ()
 
+	val ok = ref true
+ 
 	fun contactNode (node, ip) =
 	    if node = Config.defaultNode then
 		Domain.resetLocal ()
@@ -845,40 +862,106 @@ fun regenerate context =
 		val _ = ErrorMsg.reset ()
 
 		val dname = Config.domtoolDir user
+	    in
+		if Posix.FileSys.access (dname, []) then
+		    let
+			val dir = Posix.FileSys.opendir dname
+
+			fun loop files =
+			    case Posix.FileSys.readdir dir of
+				NONE => (Posix.FileSys.closedir dir;
+					 files)
+			      | SOME fname =>
+				if notTmp fname then
+				    loop (OS.Path.joinDirFile {dir = dname,
+							       file = fname}
+					  :: files)
+				else
+				    loop files
 
-		val dir = Posix.FileSys.opendir dname
-
-		fun loop files =
-		    case Posix.FileSys.readdir dir of
-			NONE => (Posix.FileSys.closedir dir;
-				 files)
-		      | SOME fname =>
-			if notTmp fname then
-			    loop (OS.Path.joinDirFile {dir = dname,
-						       file = fname}
-				  :: files)
+			val files = loop []
+			val (_, files) = Order.order (SOME b) files
+		    in
+			if !ErrorMsg.anyErrors then
+			    (ErrorMsg.reset ();
+			     print ("User " ^ user ^ "'s configuration has errors!\n"))
 			else
-			    loop files
-
-		val files = loop []
-		val (_, files) = Order.order (SOME b) files
-	    in
-		if !ErrorMsg.anyErrors then
-		    (ErrorMsg.reset ();
-		     print ("User " ^ user ^ "'s configuration has errors!\n"))
+			    app eval' files
+		    end
 		else
-		    app eval' files
+		    ()
 	    end
-		handle IO.Io _ => ()
-		     | OS.SysErr (s, _) => print ("System error processing user " ^ user ^ ": " ^ s ^ "\n")
-		     | ErrorMsg.Error => (ErrorMsg.reset ();
-					  print ("User " ^ user ^ " had a compilation error.\n"))
-		     | _ => print "Unknown exception during regeneration!\n"
+	    handle IO.Io _ => ()
+		 | OS.SysErr (s, _) => (print ("System error processing user " ^ user ^ ": " ^ s ^ "\n");
+					ok := false)
+		 | ErrorMsg.Error => (ErrorMsg.reset ();
+				      print ("User " ^ user ^ " had a compilation error.\n");
+				      ok := false)
+		 | _ => (print "Unknown exception during regeneration!\n";
+			 ok := false)
     in
 	app contactNode Config.nodeIps;
 	Env.pre ();
 	app doUser (Acl.users ());
-	Env.post ()
+	Env.post ();
+	!ok
+    end
+
+fun regenerateTc context =
+    let
+	val _ = ErrorMsg.reset ()
+
+	val b = basis ()
+	val () = Tycheck.disallowExterns ()
+
+	val () = Domain.resetGlobal ()
+
+	val ok = ref true
+
+	fun doUser user =
+	    let
+		val _ = Domain.setUser user
+		val _ = ErrorMsg.reset ()
+
+		val dname = Config.domtoolDir user
+	    in
+		if Posix.FileSys.access (dname, []) then
+		    let
+			val dir = Posix.FileSys.opendir dname
+
+			fun loop files =
+			    case Posix.FileSys.readdir dir of
+				NONE => (Posix.FileSys.closedir dir;
+					 files)
+			      | SOME fname =>
+				if notTmp fname then
+				    loop (OS.Path.joinDirFile {dir = dname,
+							       file = fname}
+					  :: files)
+				else
+				    loop files
+
+			val files = loop []
+			val (_, files) = Order.order (SOME b) files
+		    in
+			if !ErrorMsg.anyErrors then
+			    (ErrorMsg.reset ();
+			     print ("User " ^ user ^ "'s configuration has errors!\n");
+			     ok := false)
+			else
+			    app (ignore o check) files
+		    end
+		else
+		    ()
+	    end
+	    handle IO.Io _ => ()
+		 | OS.SysErr (s, _) => print ("System error processing user " ^ user ^ ": " ^ s ^ "\n")
+		 | ErrorMsg.Error => (ErrorMsg.reset ();
+				      print ("User " ^ user ^ " had a compilation error.\n"))
+		 | _ => print "Unknown exception during -tc regeneration!\n"
+    in
+	app doUser (Acl.users ());
+	!ok
     end
 
 fun rmuser user =
@@ -1086,14 +1169,32 @@ fun service () =
 				doIt (fn () =>
 					 if Acl.query {user = user, class = "priv", value = "regen"}
 					    orelse Acl.query {user = user, class = "priv", value = "all"} then
-					     (regenerate context;
-					      ("Regenerated all configuration.",
-					       NONE))
+					     (if regenerate context then
+						  ("Regenerated all configuration.",
+						   NONE)
+					      else
+						  ("Error regenerating configuration!",
+						   SOME "Error regenerating configuration!  Consult /var/log/domtool.log."))
 					 else
 					     ("Unauthorized user asked to regenerate!",
 					      SOME "Not authorized to regenerate"))
 				     (fn () => ())
 
+			      | MsgRegenerateTc =>
+				doIt (fn () =>
+					 if Acl.query {user = user, class = "priv", value = "regen"}
+					    orelse Acl.query {user = user, class = "priv", value = "all"} then
+					     (if regenerateTc context then
+						  ("Checked all configuration.",
+						   NONE)
+					      else
+						  ("Found a compilation error!",
+						   SOME "Found a compilation error!  Consult /var/log/domtool.log."))
+					 else
+					     ("Unauthorized user asked to regenerate -tc!",
+					      SOME "Not authorized to regenerate -tc"))
+				     (fn () => ())
+
 			      | MsgRmuser user' =>
 				doIt (fn () =>
 					 if Acl.query {user = user, class = "priv", value = "all"} then