X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/blobdiff_plain/f19ba3232998ecde9c4fb818278444474f4fce66..86e132be99dcdbf2271119267cea6b91eb8207c3:/src/main.sml

diff --git a/src/main.sml b/src/main.sml
index 4539b65..f32fa2d 100644
--- a/src/main.sml
+++ b/src/main.sml
@@ -96,7 +96,24 @@ fun notTmp s =
     String.sub (s, 0) <> #"."
     andalso CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"." orelse ch = #"_" orelse ch = #"-") s
 
-fun checkDir dname =
+fun setupUser () =
+    let
+	val user =
+	    case Posix.ProcEnv.getenv "DOMTOOL_USER" of
+		NONE =>
+		let
+		    val uid = Posix.ProcEnv.getuid ()
+		in
+		    Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid uid)
+		end
+	      | SOME user => user
+    in
+	Acl.read Config.aclFile;
+	Domain.setUser user;
+	user
+    end
+
+fun checkDir' dname =
     let
 	val b = basis ()
 
@@ -127,6 +144,10 @@ fun checkDir dname =
 		 ())
     end
 
+fun checkDir dname =
+    (setupUser ();
+     checkDir' dname)
+
 fun reduce fname =
     let
 	val (G, body) = check fname
@@ -180,23 +201,6 @@ fun context x =
 	    print ("Additional information: " ^ s ^ "\n");
 	    raise e)
 
-fun setupUser () =
-    let
-	val user =
-	    case Posix.ProcEnv.getenv "DOMTOOL_USER" of
-		NONE =>
-		let
-		    val uid = Posix.ProcEnv.getuid ()
-		in
-		    Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid uid)
-		end
-	      | SOME user => user
-    in
-	Acl.read Config.aclFile;
-	Domain.setUser user;
-	user
-    end
-
 fun requestContext f =
     let
 	val user = setupUser ()
@@ -262,7 +266,7 @@ fun requestDir dname =
 
 	val _ = ErrorMsg.reset ()
 
-	val (user, bio) = requestBio (fn () => checkDir dname)
+	val (user, bio) = requestBio (fn () => checkDir' dname)
 
 	val b = basis ()
 
@@ -524,7 +528,7 @@ fun requestDbTable p =
     let
 	val (user, bio) = requestBio (fn () => ())
     in
-	Msg.send (bio, MsgCreateDbTable p);
+	Msg.send (bio, MsgCreateDb p);
 	case Msg.recv bio of
 	    NONE => print "Server closed connection unexpectedly.\n"
 	  | SOME m =>
@@ -869,14 +873,20 @@ fun requestFirewall {node, uname} =
 	before OpenSSL.close bio
     end
 
-fun regenerate context =
+fun regenerateEither tc checker context =
     let
+	fun ifReal f =
+	    if tc then
+		()
+	    else
+		f ()
+
 	val _ = ErrorMsg.reset ()
 
 	val b = basis ()
 	val () = Tycheck.disallowExterns ()
 
-	val () = Domain.resetGlobal ()
+	val () = ifReal Domain.resetGlobal
 
 	val ok = ref true
  
@@ -934,7 +944,7 @@ fun regenerate context =
 			    (ErrorMsg.reset ();
 			     print ("User " ^ user ^ "'s configuration has errors!\n"))
 			else
-			    app eval' files
+			    app checker files
 		    end
 		else
 		    ()
@@ -942,77 +952,23 @@ fun regenerate context =
 	    handle IO.Io {name, function, ...} =>
 		   (print ("IO error processing user " ^ user ^ ": " ^ function ^ ": " ^ name ^ "\n");
 		    ok := false)
-		 | OS.SysErr (s, _) => (print ("System error processing user " ^ user ^ ": " ^ s ^ "\n");
-					ok := false)
+		 | exn as 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 ();
+	ifReal (fn () => (app contactNode Config.nodeIps;
+			  Env.pre ()));
 	app doUser (Acl.users ());
-	Env.post ();
+	ifReal 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
+val regenerate = regenerateEither false eval'
+val regenerateTc = regenerateEither true (ignore o check)
 
 fun rmuser user =
     let
@@ -1285,7 +1241,7 @@ fun service () =
 						   SOME ("Error adding user: " ^ msg)))
 				      (fn () => ())
 
-			       | MsgCreateDbTable {dbtype, dbname} =>
+			       | MsgCreateDb {dbtype, dbname} =>
 				 doIt (fn () =>
 					  if Dbms.validDbname dbname then
 					      case Dbms.lookup dbtype of