X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/blobdiff_plain/24248d627b677abd0a21092f71c445b0934f2bdc..c362e4cc29d981936644c90c71e9d2127b5ea6d3:/src/main.sml

diff --git a/src/main.sml b/src/main.sml
index a0f402d..cf53af0 100644
--- a/src/main.sml
+++ b/src/main.sml
@@ -1,5 +1,5 @@
 (* HCoop Domtool (http://hcoop.sourceforge.net/)
- * Copyright (c) 2006-2007, Adam Chlipala
+ * Copyright (c) 2006-2009, Adam Chlipala
  *
  * This program is free software; you can redistribute it and/or
  * modify it under the terms of the GNU General Public License
@@ -46,7 +46,10 @@ fun check' G fname =
 	if !ErrorMsg.anyErrors then
 	    G
 	else
-	    (Option.app (Unused.check G) (#3 prog);
+	    (if isLib fname then
+		 ()
+	     else
+		 Option.app (Unused.check G) (#3 prog);
 	     Tycheck.checkFile G (Defaults.tInit prog) prog)
     end
 
@@ -102,7 +105,10 @@ fun check G fname =
 			if !ErrorMsg.anyErrors then
 			    raise ErrorMsg.Error
 			else
-			    (Option.app (Unused.check G) (#3 prog);
+			    (if isLib fname then
+				 ()
+			     else
+				 Option.app (Unused.check G) (#3 prog);
 			     (G', #3 prog))
 		    end
 	    end
@@ -169,7 +175,7 @@ fun reduce G fname =
 	val (G, body) = check G fname
     in
 	if !ErrorMsg.anyErrors then
-	    NONE
+	    (G, NONE)
 	else
 	    case body of
 		SOME body =>
@@ -180,16 +186,16 @@ fun reduce G fname =
 					 [PD.string "Result:",
 					  PD.space 1,
 					  p_exp body']))*)
-		    SOME (G, body')
+		    (G, SOME body')
 		end
-	      | _ => NONE
+	      | _ => (G, NONE)
     end
 
 (*(Defaults.eInit ())*)
 
 fun eval G evs fname =
     case reduce G fname of
-	SOME (G, body') =>
+	(G, SOME body') =>
 	if !ErrorMsg.anyErrors then
 	    raise ErrorMsg.Error
 	else
@@ -198,7 +204,7 @@ fun eval G evs fname =
 	    in
 		(G, evs')
 	    end
-      | NONE => (G, evs)
+      | (G, NONE) => (G, evs)
 
 val dispatcher =
     Config.dispatcher ^ ":" ^ Int.toString Config.dispatcherPort
@@ -227,35 +233,55 @@ fun requestContext f =
 	(user, context)
     end
 
-fun requestBio f =
+fun requestBio' printErr f =
     let
 	val (user, context) = requestContext f
     in
-	(user, OpenSSL.connect (context, dispatcher))
+	(user, OpenSSL.connect printErr (context, dispatcher))
     end
 
-fun requestSlaveBio () =
+val requestBio = requestBio' true
+
+fun requestSlaveBio' printErr =
     let
 	val (user, context) = requestContext (fn () => ())
     in
-	(user, OpenSSL.connect (context, self))
+	(user, OpenSSL.connect printErr (context, self))
     end
 
-fun request fname =
-    let
-	val (user, bio) = requestBio (fn () => ignore (check (basis ()) fname))
+fun requestSlaveBio () = requestSlaveBio' true
 
-	val inf = TextIO.openIn fname
+fun request (fname, libOpt) =
+    let
+	val (user, bio) = requestBio (fn () =>
+					 let
+					     val env = basis ()
+					     val env = case libOpt of
+							   NONE => env
+							 | SOME lib => #1 (check env lib)
+					 in
+					     ignore (check env fname)
+					 end)
+
+	fun readFile fname =
+	    let
+		val inf = TextIO.openIn fname
 
-	fun loop lines =
-	    case TextIO.inputLine inf of
-		NONE => String.concat (List.rev lines)
-	      | SOME line => loop (line :: lines)
+		fun loop lines =
+		    case TextIO.inputLine inf of
+			NONE => String.concat (rev lines)
+		      | SOME line => loop (line :: lines)
+	    in
+		loop []
+		before TextIO.closeIn inf
+	    end
 
-	val code = loop []
+	val code = readFile fname
+	val msg = case libOpt of
+		      NONE => MsgConfig code
+		    | SOME fname' => MsgMultiConfig [readFile fname', code]
     in
-	TextIO.closeIn inf;
-	Msg.send (bio, MsgConfig code);
+	Msg.send (bio, msg);
 	case Msg.recv bio of
 	    NONE => print "Server closed connection unexpectedly.\n"
 	  | SOME m =>
@@ -301,7 +327,7 @@ fun requestDir dname =
 	val (_, files) = Order.order (SOME b) files
 
 	val _ = if !ErrorMsg.anyErrors then
-		    (print "J\n";raise ErrorMsg.Error)
+		    raise ErrorMsg.Error
 		else
 		    ()
 
@@ -335,7 +361,7 @@ fun requestDir dname =
 
 fun requestPing () =
     let
-	val (_, bio) = requestBio (fn () => ())
+	val (_, bio) = requestBio' false (fn () => ())
     in
 	OpenSSL.close bio;
 	OS.Process.success
@@ -348,7 +374,7 @@ fun requestShutdown () =
     in
 	Msg.send (bio, MsgShutdown);
 	case Msg.recv bio of
-	    NONE => print "Server closed connection unexpectedly.\n"
+	    NONE => ()
 	  | SOME m =>
 	    case m of
 		MsgOk => print "Shutdown begun.\n"
@@ -359,7 +385,7 @@ fun requestShutdown () =
 
 fun requestSlavePing () =
     let
-	val (_, bio) = requestSlaveBio ()
+	val (_, bio) = requestSlaveBio' false
     in
 	OpenSSL.close bio;
 	OS.Process.success
@@ -372,7 +398,7 @@ fun requestSlaveShutdown () =
     in
 	Msg.send (bio, MsgShutdown);
 	case Msg.recv bio of
-	    NONE => print "Server closed connection unexpectedly.\n"
+	    NONE => ()
 	  | SOME m =>
 	    case m of
 		MsgOk => print "Shutdown begun.\n"
@@ -509,7 +535,9 @@ fun requestRmuser user =
 
 fun requestDbUser dbtype =
     let
-	val (_, bio) = requestBio (fn () => ())
+	val (_, context) = requestContext (fn () => ())
+	val bio = OpenSSL.connect true (context,
+					Config.Dbms.dbmsNode ^ ":" ^ Int.toString Config.slavePort)
     in
 	Msg.send (bio, MsgCreateDbUser dbtype);
 	case Msg.recv bio of
@@ -524,7 +552,9 @@ fun requestDbUser dbtype =
 
 fun requestDbPasswd rc =
     let
-	val (_, bio) = requestBio (fn () => ())
+	val (_, context) = requestContext (fn () => ())
+	val bio = OpenSSL.connect true (context,
+					Config.Dbms.dbmsNode ^ ":" ^ Int.toString Config.slavePort)
     in
 	Msg.send (bio, MsgDbPasswd rc);
 	case Msg.recv bio of
@@ -539,7 +569,9 @@ fun requestDbPasswd rc =
 
 fun requestDbTable p =
     let
-	val (user, bio) = requestBio (fn () => ())
+	val (user, context) = requestContext (fn () => ())
+	val bio = OpenSSL.connect true (context,
+					Config.Dbms.dbmsNode ^ ":" ^ Int.toString Config.slavePort)
     in
 	Msg.send (bio, MsgCreateDb p);
 	case Msg.recv bio of
@@ -554,7 +586,9 @@ fun requestDbTable p =
 
 fun requestDbDrop p =
     let
-	val (user, bio) = requestBio (fn () => ())
+	val (user, context) = requestContext (fn () => ())
+	val bio = OpenSSL.connect true (context,
+					Config.Dbms.dbmsNode ^ ":" ^ Int.toString Config.slavePort)
     in
 	Msg.send (bio, MsgDropDb p);
 	case Msg.recv bio of
@@ -569,7 +603,9 @@ fun requestDbDrop p =
 
 fun requestDbGrant p =
     let
-	val (user, bio) = requestBio (fn () => ())
+	val (user, context) = requestContext (fn () => ())
+	val bio = OpenSSL.connect true (context,
+					Config.Dbms.dbmsNode ^ ":" ^ Int.toString Config.slavePort)
     in
 	Msg.send (bio, MsgGrantDb p);
 	case Msg.recv bio of
@@ -715,10 +751,10 @@ fun requestMysqlFixperms () =
 fun requestApt {node, pkg} =
     let
 	val (user, context) = requestContext (fn () => ())
-	val bio = OpenSSL.connect (context, if node = Config.masterNode then
-						dispatcher
-					    else
-						Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
+	val bio = OpenSSL.connect true (context, if node = Config.masterNode then
+						     dispatcher
+						 else
+						     Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
 
 	val _ = Msg.send (bio, MsgQuery (QApt pkg))
 
@@ -744,10 +780,10 @@ fun requestApt {node, pkg} =
 fun requestCron {node, uname} =
     let
 	val (user, context) = requestContext (fn () => ())
-	val bio = OpenSSL.connect (context, if node = Config.masterNode then
-						dispatcher
-					    else
-						Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
+	val bio = OpenSSL.connect true (context, if node = Config.masterNode then
+						     dispatcher
+						 else
+						     Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
 
 	val _ = Msg.send (bio, MsgQuery (QCron uname))
 
@@ -773,10 +809,10 @@ fun requestCron {node, uname} =
 fun requestFtp {node, uname} =
     let
 	val (user, context) = requestContext (fn () => ())
-	val bio = OpenSSL.connect (context, if node = Config.masterNode then
-						dispatcher
-					    else
-						Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
+	val bio = OpenSSL.connect true (context, if node = Config.masterNode then
+						     dispatcher
+						 else
+						     Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
 
 	val _ = Msg.send (bio, MsgQuery (QFtp uname))
 
@@ -802,10 +838,10 @@ fun requestFtp {node, uname} =
 fun requestTrustedPath {node, uname} =
     let
 	val (user, context) = requestContext (fn () => ())
-	val bio = OpenSSL.connect (context, if node = Config.masterNode then
-						dispatcher
-					    else
-						Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
+	val bio = OpenSSL.connect true (context, if node = Config.masterNode then
+						     dispatcher
+						 else
+						     Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
 
 	val _ = Msg.send (bio, MsgQuery (QTrustedPath uname))
 
@@ -831,10 +867,10 @@ fun requestTrustedPath {node, uname} =
 fun requestSocketPerm {node, uname} =
     let
 	val (user, context) = requestContext (fn () => ())
-	val bio = OpenSSL.connect (context, if node = Config.masterNode then
-						dispatcher
-					    else
-						Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
+	val bio = OpenSSL.connect true (context, if node = Config.masterNode then
+						     dispatcher
+						 else
+						     Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
 
 	val _ = Msg.send (bio, MsgQuery (QSocket uname))
 
@@ -862,11 +898,11 @@ fun requestSocketPerm {node, uname} =
 fun requestFirewall {node, uname} =
     let
 	val (user, context) = requestContext (fn () => ())
-	val bio = OpenSSL.connect (context, if node = Config.masterNode then
-						dispatcher
-					    else
-						Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
-
+	val bio = OpenSSL.connect true (context, if node = Config.masterNode then
+						     dispatcher
+						 else
+						     Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
+		  
 	val _ = Msg.send (bio, MsgQuery (QFirewall uname))
 
 	fun loop () =
@@ -901,6 +937,21 @@ fun requestDescribe dom =
 	OpenSSL.close bio
     end
 
+fun requestReUsers () =
+    let
+	val (_, bio) = requestBio (fn () => ())
+    in
+	Msg.send (bio, MsgReUsers);
+	case Msg.recv bio of
+	    NONE => print "Server closed connection unexpectedly.\n"
+	  | SOME m =>
+	    case m of
+		MsgOk => print "Callbacks run.\n"
+	      | MsgError s => print ("Failed: " ^ s ^ "\n")
+	      | _ => print "Unexpected server reply.\n";
+	OpenSSL.close bio
+    end
+
 structure SS = StringSet
 
 fun domainList dname =
@@ -983,10 +1034,10 @@ fun regenerateEither tc checker context =
 	    if node = Config.defaultNode then
 		Domain.resetLocal ()
 	    else let
-		    val bio = OpenSSL.connect (context,
-					       ip
-					       ^ ":"
-					       ^ Int.toString Config.slavePort)
+		    val bio = OpenSSL.connect true (context,
+						    ip
+						    ^ ":"
+						    ^ Int.toString Config.slavePort)
 		in
 		    Msg.send (bio, MsgRegenerate);
 		    case Msg.recv bio of
@@ -1084,6 +1135,10 @@ val regenerateTc = regenerateEither true
 				    (fn G => fn evs => fn file =>
 							  (#1 (check G file), evs))
 
+fun usersChanged () =
+    (Domain.onUsersChange ();
+     ignore (OS.Process.system Config.publish_reusers))
+
 fun rmuser user =
     let
 	val doms = Acl.class {user = user, class = "domain"}
@@ -1093,7 +1148,8 @@ fun rmuser user =
 				     | _ => false) (StringSet.listItems doms)
     in
 	Acl.rmuser user;
-	Domain.rmdom doms
+	Domain.rmdom doms;
+	usersChanged ()
     end
 
 fun now () = Date.toString (Date.fromTimeUniv (Time.now ()))
@@ -1116,12 +1172,51 @@ fun describeQuery q =
       | QSocket user => "Asked about socket permissions for user " ^ user
       | QFirewall user => "Asked about firewall rules for user " ^ user
 
+fun doIt' loop bio f cleanup =
+	       ((case f () of
+		     (msgLocal, SOME msgRemote) => 
+		     (print msgLocal;
+		      print "\n";
+		      Msg.send (bio, MsgError msgRemote))
+		   | (msgLocal, NONE) =>
+		     (print msgLocal;
+		      print "\n";
+		      Msg.send (bio, MsgOk)))
+		handle e as (OpenSSL.OpenSSL s) =>
+		       (print ("OpenSSL error: " ^ s ^ "\n");
+			app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);
+			Msg.send (bio, MsgError ("OpenSSL error: " ^ s))
+			handle OpenSSL.OpenSSL _ => ())
+		     | OS.SysErr (s, _) =>
+		       (print "System error: ";
+			print s;
+			print "\n";
+			Msg.send (bio, MsgError ("System error: " ^ s))
+			handle OpenSSL.OpenSSL _ => ())
+		     | Fail s =>
+		       (print "Failure: ";
+			print s;
+			print "\n";
+			Msg.send (bio, MsgError ("Failure: " ^ s))
+			handle OpenSSL.OpenSSL _ => ())
+		     | ErrorMsg.Error =>
+		       (print "Compilation error\n";
+			Msg.send (bio, MsgError "Error during configuration evaluation")
+			handle OpenSSL.OpenSSL _ => ());
+		(cleanup ();
+		 ignore (OpenSSL.readChar bio);
+		 OpenSSL.close bio)
+		handle OpenSSL.OpenSSL _ => ();
+		loop ())
+
 fun service () =
     let
+	val host = Slave.hostname ()
+
 	val () = Acl.read Config.aclFile
-	
-	val context = context (Config.serverCert,
-			       Config.serverKey,
+
+	val context = context (Config.certDir ^ "/" ^ host ^ ".pem",
+			       Config.keyDir ^ "/" ^ host ^ "/key.pem",
 			       Config.trustStore)
 	val _ = Domain.set_context context
 
@@ -1135,43 +1230,7 @@ fun service () =
 		     val user = OpenSSL.peerCN bio
 		     val () = print ("\nConnection from " ^ user ^ " at " ^ now () ^ "\n")
 		     val () = Domain.setUser user
-
-		     fun doIt f cleanup =
-			 ((case f () of
-			       (msgLocal, SOME msgRemote) => 
-			       (print msgLocal;
-				print "\n";
-				Msg.send (bio, MsgError msgRemote))
-			     | (msgLocal, NONE) =>
-			       (print msgLocal;
-				print "\n";
-				Msg.send (bio, MsgOk)))
-			  handle e as (OpenSSL.OpenSSL s) =>
-				 (print ("OpenSSL error: " ^ s ^ "\n");
-				  app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);
-				  Msg.send (bio, MsgError ("OpenSSL error: " ^ s))
-				  handle OpenSSL.OpenSSL _ => ())
-			       | OS.SysErr (s, _) =>
-				 (print "System error: ";
-				  print s;
-				  print "\n";
-				  Msg.send (bio, MsgError ("System error: " ^ s))
-				  handle OpenSSL.OpenSSL _ => ())
-			       | Fail s =>
-				 (print "Failure: ";
-				  print s;
-				  print "\n";
-				  Msg.send (bio, MsgError ("Failure: " ^ s))
-				  handle OpenSSL.OpenSSL _ => ())
-			       | ErrorMsg.Error =>
-				 (print "Compilation error\n";
-				  Msg.send (bio, MsgError "Error during configuration evaluation")
-				  handle OpenSSL.OpenSSL _ => ());
-                          (cleanup ();
-			   ignore (OpenSSL.readChar bio);
-			   OpenSSL.close bio)
-			  handle OpenSSL.OpenSSL _ => ();
-			  loop ())
+		     val doIt = doIt' loop bio
 
 		     fun doConfig codes =
 			 let
@@ -1237,6 +1296,10 @@ fun service () =
 					  if Acl.query {user = user, class = "priv", value = "all"} then
 					      (Acl.grant acl;
 					       Acl.write Config.aclFile;
+					       if #class acl = "user" then
+						   usersChanged ()
+					       else
+						   ();
 					       ("Granted permission " ^ #value acl ^ " to " ^ #user acl ^ " in " ^ #class acl ^ ".",
 						NONE))
 					  else
@@ -1273,11 +1336,12 @@ fun service () =
 			       | MsgRmdom doms =>
 				 doIt (fn () =>
 					  if Acl.query {user = user, class = "priv", value = "all"}
-					     orelse List.all (fn dom => Acl.query {user = user, class = "domain", value = dom}) doms then
+					     orelse List.all (fn dom => Domain.validDomain dom
+									andalso Acl.queryDomain {user = user, domain = dom}) doms then
 					      (Domain.rmdom doms;
-					       app (fn dom =>
+					       (*app (fn dom =>
 						       Acl.revokeFromAll {class = "domain", value = dom}) doms;
-					       Acl.write Config.aclFile;
+					       Acl.write Config.aclFile;*)
 					       ("Removed domains" ^ foldl (fn (d, s) => s ^ " " ^ d) "" doms ^ ".",
 						NONE))
 					  else
@@ -1327,85 +1391,6 @@ fun service () =
 					       SOME "Not authorized to remove users"))
 				      (fn () => ())
 
-			       | MsgCreateDbUser {dbtype, passwd} =>
-				 doIt (fn () =>
-					  case Dbms.lookup dbtype of
-					      NONE => ("Database user creation request with unknown datatype type " ^ dbtype,
-						       SOME ("Unknown database type " ^ dbtype))
-					    | SOME handler =>
-					      case #adduser handler {user = user, passwd = passwd} of
-						  NONE => ("Added " ^ dbtype ^ " user " ^ user ^ ".",
-							   NONE)
-						| SOME msg =>
-						  ("Error adding a " ^ dbtype ^ " user " ^ user ^ ": " ^ msg,
-						   SOME ("Error adding user: " ^ msg)))
-				      (fn () => ())
-
-			       | MsgDbPasswd {dbtype, passwd} =>
-				 doIt (fn () =>
-					  case Dbms.lookup dbtype of
-					      NONE => ("Database passwd request with unknown datatype type " ^ dbtype,
-						       SOME ("Unknown database type " ^ dbtype))
-					    | SOME handler =>
-					      case #passwd handler {user = user, passwd = passwd} of
-						  NONE => ("Changed " ^ dbtype ^ " password of user " ^ user ^ ".",
-							   NONE)
-						| SOME msg =>
-						  ("Error setting " ^ dbtype ^ " password of user " ^ user ^ ": " ^ msg,
-						   SOME ("Error adding user: " ^ msg)))
-				      (fn () => ())
-
-			       | MsgCreateDb {dbtype, dbname} =>
-				 doIt (fn () =>
-					  if Dbms.validDbname dbname then
-					      case Dbms.lookup dbtype of
-						  NONE => ("Database creation request with unknown datatype type " ^ dbtype,
-							   SOME ("Unknown database type " ^ dbtype))
-						| SOME handler =>
-						  case #createdb handler {user = user, dbname = dbname} of
-						      NONE => ("Created database " ^ user ^ "_" ^ dbname ^ ".",
-							       NONE)
-						    | SOME msg => ("Error creating database " ^ user ^ "_" ^ dbname ^ ": " ^ msg,
-								   SOME ("Error creating database: " ^ msg))
-					  else
-					      ("Invalid database name " ^ user ^ "_" ^ dbname,
-					       SOME ("Invalid database name " ^ dbname)))
-				      (fn () => ())
-
-			       | MsgDropDb {dbtype, dbname} =>
-				 doIt (fn () =>
-					  if Dbms.validDbname dbname then
-					      case Dbms.lookup dbtype of
-						  NONE => ("Database drop request with unknown datatype type " ^ dbtype,
-							   SOME ("Unknown database type " ^ dbtype))
-						| SOME handler =>
-						  case #dropdb handler {user = user, dbname = dbname} of
-						      NONE => ("Drop database " ^ user ^ "_" ^ dbname ^ ".",
-							       NONE)
-						    | SOME msg => ("Error dropping database " ^ user ^ "_" ^ dbname ^ ": " ^ msg,
-								   SOME ("Error dropping database: " ^ msg))
-					  else
-					      ("Invalid database name " ^ user ^ "_" ^ dbname,
-					       SOME ("Invalid database name " ^ dbname)))
-				      (fn () => ())
-
-			       | MsgGrantDb {dbtype, dbname} =>
-				 doIt (fn () =>
-					  if Dbms.validDbname dbname then
-					      case Dbms.lookup dbtype of
-						  NONE => ("Database drop request with unknown datatype type " ^ dbtype,
-							   SOME ("Unknown database type " ^ dbtype))
-						| SOME handler =>
-						  case #grant handler {user = user, dbname = dbname} of
-						      NONE => ("Grant permissions to database " ^ user ^ "_" ^ dbname ^ ".",
-							       NONE)
-						    | SOME msg => ("Error granting permissions to database " ^ user ^ "_" ^ dbname ^ ": " ^ msg,
-								   SOME ("Error granting permissions to database: " ^ msg))
-					  else
-					      ("Invalid database name " ^ user ^ "_" ^ dbname,
-					       SOME ("Invalid database name " ^ dbname)))
-				      (fn () => ())
-
 			       | MsgListMailboxes domain =>
 				 doIt (fn () =>
 					  if not (Domain.yourDomain domain) then
@@ -1522,14 +1507,15 @@ fun service () =
 				      (fn () => ())
 
 			       | MsgMysqlFixperms =>
-				 doIt (fn () => if OS.Process.isSuccess
-						       (OS.Process.system "/usr/bin/sudo -H /afs/hcoop.net/common/etc/scripts/mysql-grant-table-drop") then
-						    ("Requested mysql-fixperms",
-						     NONE)
+				 (print "Starting mysql-fixperms\n";
+				  doIt (fn () => if OS.Process.isSuccess
+							(OS.Process.system "/usr/bin/sudo -H /afs/hcoop.net/common/etc/scripts/mysql-grant-table-drop") then
+						     ("Requested mysql-fixperms",
+						      NONE)
 						 else
 						     ("Requested mysql-fixperms, but execution failed!",
 						      SOME "Script execution failed."))
-				      (fn () => ())
+				       (fn () => ()))
 
 			       | MsgDescribe dom =>
 				 doIt (fn () => if not (Domain.validDomain dom) then
@@ -1545,6 +1531,16 @@ fun service () =
 						      NONE)))
 				      (fn () => ())
 
+			       | MsgReUsers =>
+				 doIt (fn () => if Acl.query {user = user, class = "priv", value = "regen"}
+						   orelse Acl.query {user = user, class = "priv", value = "all"} then
+						    (usersChanged ();
+						     ("Users change callbacks run", NONE))
+						else
+						    ("Unauthorized user asked to reusers!",
+						     SOME "You aren't authorized to regenerate files."))
+				      (fn () => ())
+
 			       | _ =>
 				 doIt (fn () => ("Unexpected command",
 						 SOME "Unexpected command"))
@@ -1615,69 +1611,172 @@ fun slave () =
 	val _ = print ("Slave server starting at " ^ now () ^ "\n")
 
 	fun loop () =
-	    case OpenSSL.accept sock of
-		NONE => ()
-	      | SOME bio =>
-		let
-		    val peer = OpenSSL.peerCN bio
-		    val () = print ("\nConnection from " ^ peer ^ " at " ^ now () ^ "\n")
-		in
-		    if peer = Config.dispatcherName then let
-			    fun loop' files =
-				case Msg.recv bio of
-				    NONE => print "Dispatcher closed connection unexpectedly\n"
-				  | SOME m =>
-				    case m of
-					MsgFile file => loop' (file :: files)
-				      | MsgDoFiles => (Slave.handleChanges files;
-						       Msg.send (bio, MsgOk))
-				      | MsgRegenerate => (Domain.resetLocal ();
-							  Msg.send (bio, MsgOk))
-				      | _ => (print "Dispatcher sent unexpected command\n";
-					      Msg.send (bio, MsgError "Unexpected command"))
-			in
-			    loop' [];
-			    ignore (OpenSSL.readChar bio);
-			    OpenSSL.close bio;
-			    loop ()
-			end
-		    else if peer = "domtool" then
-			case Msg.recv bio of
-			    SOME MsgShutdown => (OpenSSL.close bio;
-						 print ("Shutting down at " ^ now () ^ "\n\n"))
-			  | _ => (OpenSSL.close bio;
-				  loop ())
-		    else
-			case Msg.recv bio of
-			    SOME (MsgQuery q) => (print (describeQuery q ^ "\n");
-						  Msg.send (bio, answerQuery q);
-						  ignore (OpenSSL.readChar bio);
-						  OpenSSL.close bio;
-						  loop ())
-			  | _ => (OpenSSL.close bio;
-				  loop ())
-		end handle OpenSSL.OpenSSL s =>
-			   (print ("OpenSSL error: " ^ s ^ "\n");
-			    OpenSSL.close bio
+	    (case OpenSSL.accept sock of
+		 NONE => ()
+	       | SOME bio =>
+		 let
+		     val peer = OpenSSL.peerCN bio
+		     val () = print ("\nConnection from " ^ peer ^ " at " ^ now () ^ "\n")
+		 in
+		     if peer = Config.dispatcherName then let
+			     fun loop' files =
+				 case Msg.recv bio of
+				     NONE => print "Dispatcher closed connection unexpectedly\n"
+				   | SOME m =>
+				     case m of
+					 MsgFile file => loop' (file :: files)
+				       | MsgDoFiles => (Slave.handleChanges files;
+							Msg.send (bio, MsgOk))
+				       | MsgRegenerate => (Domain.resetLocal ();
+							   Msg.send (bio, MsgOk))
+				       | MsgVmailChanged => (if Vmail.doChanged () then
+								 Msg.send (bio, MsgOk)
+							     else
+								 Msg.send (bio, MsgError "userdb update failed"))
+				       | _ => (print "Dispatcher sent unexpected command\n";
+					       Msg.send (bio, MsgError "Unexpected command"))
+			 in
+			     loop' [];
+			     ignore (OpenSSL.readChar bio);
+			     OpenSSL.close bio;
+			     loop ()
+			 end
+		     else if peer = "domtool" then
+			 case Msg.recv bio of
+			     SOME MsgShutdown => (OpenSSL.close bio;
+						  print ("Shutting down at " ^ now () ^ "\n\n"))
+			   | _ => (OpenSSL.close bio;
+				   loop ())
+		     else
+			 let
+			     val doIt = doIt' loop bio
+			     val user = peer
+			 in
+			     case Msg.recv bio of
+				 NONE => (OpenSSL.close bio
 					  handle OpenSSL.OpenSSL _ => ();
-			    loop ())
-			 | e as OS.SysErr (s, _) =>
-			   (app (fn s => print (s ^ "\n")) (SMLofNJ.exnHistory e);
-			    print ("System error: "^ s ^ "\n");
-			    OpenSSL.close bio
-			    handle OpenSSL.OpenSSL _ => ();
-			    loop ())
-			 | IO.Io {function, name, ...} =>
-			   (print ("IO error: " ^ function ^ ": " ^ name ^ "\n");
-			    OpenSSL.close bio
-			    handle OpenSSL.OpenSSL _ => ();
-			    loop ())
-			 | e =>
-			   (app (fn s => print (s ^ "\n")) (SMLofNJ.exnHistory e);
-			    print "Uncaught exception!\n";
-			    OpenSSL.close bio
-			    handle OpenSSL.OpenSSL _ => ();
-			    loop ())
+					  loop ())
+			       | SOME m =>
+				 case m of 
+				     (MsgQuery q) => (print (describeQuery q ^ "\n");
+						      Msg.send (bio, answerQuery q);
+						      ignore (OpenSSL.readChar bio);
+						      OpenSSL.close bio;
+						      loop ())
+				   | MsgCreateDbUser {dbtype, passwd} =>
+				     doIt (fn () =>
+					      case Dbms.lookup dbtype of
+						  NONE => ("Database user creation request with unknown datatype type " ^ dbtype,
+							   SOME ("Unknown database type " ^ dbtype))
+						| SOME handler =>
+						  case #adduser handler {user = user, passwd = passwd} of
+						      NONE => ("Added " ^ dbtype ^ " user " ^ user ^ ".",
+							       NONE)
+						    | SOME msg =>
+						      ("Error adding a " ^ dbtype ^ " user " ^ user ^ ": " ^ msg,
+						       SOME ("Error adding user: " ^ msg)))
+					  (fn () => ())
+
+				   | MsgDbPasswd {dbtype, passwd} =>
+				     doIt (fn () =>
+					      case Dbms.lookup dbtype of
+						  NONE => ("Database passwd request with unknown datatype type " ^ dbtype,
+							   SOME ("Unknown database type " ^ dbtype))
+						| SOME handler =>
+						  case #passwd handler {user = user, passwd = passwd} of
+						      NONE => ("Changed " ^ dbtype ^ " password of user " ^ user ^ ".",
+							       NONE)
+						    | SOME msg =>
+						      ("Error setting " ^ dbtype ^ " password of user " ^ user ^ ": " ^ msg,
+						       SOME ("Error adding user: " ^ msg)))
+					  (fn () => ())
+
+				   | MsgCreateDb {dbtype, dbname, encoding} =>
+				     doIt (fn () =>
+					      if Dbms.validDbname dbname then
+						  case Dbms.lookup dbtype of
+						      NONE => ("Database creation request with unknown datatype type " ^ dbtype,
+							       SOME ("Unknown database type " ^ dbtype))
+						    | SOME handler =>
+						      if not (Dbms.validEncoding encoding) then
+							  ("Invalid encoding " ^ valOf encoding ^ " requested for database creation.",
+							   SOME "Invalid encoding")
+						      else
+							  case #createdb handler {user = user, dbname = dbname, encoding = encoding} of
+							      NONE => ("Created database " ^ user ^ "_" ^ dbname ^ ".",
+								       NONE)
+							    | SOME msg => ("Error creating database " ^ user ^ "_" ^ dbname ^ ": " ^ msg,
+									   SOME ("Error creating database: " ^ msg))
+					      else
+						  ("Invalid database name " ^ user ^ "_" ^ dbname,
+						   SOME ("Invalid database name " ^ dbname)))
+					  (fn () => ())
+
+				   | MsgDropDb {dbtype, dbname} =>
+				     doIt (fn () =>
+					      if Dbms.validDbname dbname then
+						  case Dbms.lookup dbtype of
+						      NONE => ("Database drop request with unknown datatype type " ^ dbtype,
+							       SOME ("Unknown database type " ^ dbtype))
+						    | SOME handler =>
+						      case #dropdb handler {user = user, dbname = dbname} of
+							  NONE => ("Drop database " ^ user ^ "_" ^ dbname ^ ".",
+								   NONE)
+							| SOME msg => ("Error dropping database " ^ user ^ "_" ^ dbname ^ ": " ^ msg,
+								       SOME ("Error dropping database: " ^ msg))
+					      else
+						  ("Invalid database name " ^ user ^ "_" ^ dbname,
+						   SOME ("Invalid database name " ^ dbname)))
+					  (fn () => ())
+
+				   | MsgGrantDb {dbtype, dbname} =>
+				     doIt (fn () =>
+					      if Dbms.validDbname dbname then
+						  case Dbms.lookup dbtype of
+						      NONE => ("Database drop request with unknown datatype type " ^ dbtype,
+							       SOME ("Unknown database type " ^ dbtype))
+						    | SOME handler =>
+						      case #grant handler {user = user, dbname = dbname} of
+							  NONE => ("Grant permissions to database " ^ user ^ "_" ^ dbname ^ ".",
+								   NONE)
+							| SOME msg => ("Error granting permissions to database " ^ user ^ "_" ^ dbname ^ ": " ^ msg,
+								       SOME ("Error granting permissions to database: " ^ msg))
+					      else
+						  ("Invalid database name " ^ user ^ "_" ^ dbname,
+						   SOME ("Invalid database name " ^ dbname)))
+					  (fn () => ())
+				   | _ => (OpenSSL.close bio;
+					   loop ())
+			 end
+		 end handle OpenSSL.OpenSSL s =>
+			    (print ("OpenSSL error: " ^ s ^ "\n");
+			     OpenSSL.close bio
+			     handle OpenSSL.OpenSSL _ => ();
+			     loop ())
+			  | e as OS.SysErr (s, _) =>
+			    (app (fn s => print (s ^ "\n")) (SMLofNJ.exnHistory e);
+			     print ("System error: "^ s ^ "\n");
+			     OpenSSL.close bio
+			     handle OpenSSL.OpenSSL _ => ();
+			     loop ())
+			  | IO.Io {function, name, ...} =>
+			    (print ("IO error: " ^ function ^ ": " ^ name ^ "\n");
+			     OpenSSL.close bio
+			     handle OpenSSL.OpenSSL _ => ();
+			     loop ())
+			  | e =>
+			    (app (fn s => print (s ^ "\n")) (SMLofNJ.exnHistory e);
+			     print "Uncaught exception!\n";
+			     OpenSSL.close bio
+			     handle OpenSSL.OpenSSL _ => ();
+			     loop ()))
+	    handle OpenSSL.OpenSSL s =>
+		   (print ("OpenSSL error: " ^ s ^ "\n");
+		    loop ())
+		 | e =>
+		   (app (fn s => print (s ^ "\n")) (SMLofNJ.exnHistory e);
+		    print "Uncaught exception!\n";
+		    loop ())
     in
 	loop ();
 	OpenSSL.shutdown sock