X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/blobdiff_plain/0c3785870c3ad0ec9e42d6704939b98e707df64a..ebb51f80568cc35cf3cd2f99a31a28f72526798d:/src/main.sml

diff --git a/src/main.sml b/src/main.sml
index 9b9d296..50f5e97 100644
--- a/src/main.sml
+++ b/src/main.sml
@@ -1,5 +1,6 @@
 (* HCoop Domtool (http://hcoop.sourceforge.net/)
- * Copyright (c) 2006-2007, Adam Chlipala
+ * Copyright (c) 2006-2009, Adam Chlipala
+ * Copyright (c) 2012,2013,2014 Clinton Ebadi <clinton@unknownlamer.org>
  *
  * This program is free software; you can redistribute it and/or
  * modify it under the terms of the GNU General Public License
@@ -50,7 +51,7 @@ fun check' G fname =
 		 ()
 	     else
 		 Option.app (Unused.check G) (#3 prog);
-	     Tycheck.checkFile G (Defaults.tInit prog) prog)
+	     Tycheck.checkFile G prog)
     end
 
 fun basis () =
@@ -100,7 +101,7 @@ fun check G fname =
 		    raise ErrorMsg.Error
 		else
 		    let
-			val G' = Tycheck.checkFile G (Defaults.tInit prog) prog
+			val G' = Tycheck.checkFile G prog
 		    in
 			if !ErrorMsg.anyErrors then
 			    raise ErrorMsg.Error
@@ -193,6 +194,8 @@ fun reduce G fname =
 
 (*(Defaults.eInit ())*)
 
+val toplevel = Env.initialDynEnvVals Reduce.reduceExp
+
 fun eval G evs fname =
     case reduce G fname of
 	(G, SOME body') =>
@@ -200,14 +203,14 @@ fun eval G evs fname =
 	    raise ErrorMsg.Error
 	else
 	    let
-		val evs' = Eval.exec' evs body'
+		val evs' = Eval.exec' (toplevel G, evs) body'
 	    in
 		(G, evs')
 	    end
       | (G, NONE) => (G, evs)
 
 val dispatcher =
-    Config.dispatcher ^ ":" ^ Int.toString Config.dispatcherPort
+    Domain.nodeIp Config.dispatcherName ^ ":" ^ Int.toString Config.dispatcherPort
 
 val self =
     "localhost:" ^ Int.toString Config.slavePort
@@ -327,7 +330,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
 		    ()
 
@@ -535,7 +538,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
@@ -550,7 +555,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
@@ -565,7 +572,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
@@ -580,7 +589,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
@@ -595,7 +606,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
@@ -725,7 +738,9 @@ fun requestSmtpLog domain =
 
 fun requestMysqlFixperms () =
     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, MsgMysqlFixperms);
 	case Msg.recv bio of
@@ -741,7 +756,7 @@ fun requestMysqlFixperms () =
 fun requestApt {node, pkg} =
     let
 	val (user, context) = requestContext (fn () => ())
-	val bio = OpenSSL.connect true (context, if node = Config.masterNode then
+	val bio = OpenSSL.connect true (context, if node = Config.dispatcherName then
 						     dispatcher
 						 else
 						     Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
@@ -767,10 +782,42 @@ fun requestApt {node, pkg} =
 	before OpenSSL.close bio
     end
 
+fun requestAptExists {node, pkg} =
+    let
+	val (user, context) = requestContext (fn () => ())
+	val bio = OpenSSL.connect true (context, if node = Config.dispatcherName then
+						     dispatcher
+						 else
+						     Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
+
+	val _ = Msg.send (bio, MsgQuery (QAptExists pkg))
+
+	fun loop () =
+	    case Msg.recv bio of
+		NONE => (print "Server closed connection unexpectedly.\n";
+			 OS.Process.failure)
+	      | SOME m =>
+		case m of
+		    MsgAptQuery {section,description}  =>  (print "Package exists.\n";
+							    print ("Section: " ^ section ^ "\n");
+							    print ("Description: " ^ description ^ "\n");
+							    OS.Process.success)
+		  | MsgNo => (print "Package does not exist.\n";
+			      OS.Process.failure
+			     (* It might be the Wrong Thing (tm) to use MsgNo like this *))
+		  | MsgError s => (print ("APT existence query failed: " ^ s ^ "\n");
+				   OS.Process.failure)
+		  | _ => (print "Unexpected server reply.\n";
+			  OS.Process.failure)
+    in
+	loop ()
+	before OpenSSL.close bio
+    end
+
 fun requestCron {node, uname} =
     let
 	val (user, context) = requestContext (fn () => ())
-	val bio = OpenSSL.connect true (context, if node = Config.masterNode then
+	val bio = OpenSSL.connect true (context, if node = Config.dispatcherName then
 						     dispatcher
 						 else
 						     Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
@@ -799,7 +846,7 @@ fun requestCron {node, uname} =
 fun requestFtp {node, uname} =
     let
 	val (user, context) = requestContext (fn () => ())
-	val bio = OpenSSL.connect true (context, if node = Config.masterNode then
+	val bio = OpenSSL.connect true (context, if node = Config.dispatcherName then
 						     dispatcher
 						 else
 						     Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
@@ -828,7 +875,7 @@ fun requestFtp {node, uname} =
 fun requestTrustedPath {node, uname} =
     let
 	val (user, context) = requestContext (fn () => ())
-	val bio = OpenSSL.connect true (context, if node = Config.masterNode then
+	val bio = OpenSSL.connect true (context, if node = Config.dispatcherName then
 						     dispatcher
 						 else
 						     Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
@@ -857,7 +904,7 @@ fun requestTrustedPath {node, uname} =
 fun requestSocketPerm {node, uname} =
     let
 	val (user, context) = requestContext (fn () => ())
-	val bio = OpenSSL.connect true (context, if node = Config.masterNode then
+	val bio = OpenSSL.connect true (context, if node = Config.dispatcherName then
 						     dispatcher
 						 else
 						     Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
@@ -888,12 +935,12 @@ fun requestSocketPerm {node, uname} =
 fun requestFirewall {node, uname} =
     let
 	val (user, context) = requestContext (fn () => ())
-	val bio = OpenSSL.connect true (context, if node = Config.masterNode then
+	val bio = OpenSSL.connect true (context, if node = Config.dispatcherName then
 						     dispatcher
 						 else
 						     Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
 		  
-	val _ = Msg.send (bio, MsgQuery (QFirewall uname))
+	val _ = Msg.send (bio, MsgQuery (QFirewall {node = node, user = uname}))
 
 	fun loop () =
 	    case Msg.recv bio of
@@ -927,6 +974,46 @@ 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
+
+fun requestFirewallRegen node = 
+    let
+	val (user, context) = requestContext (fn () => ())
+	val bio = OpenSSL.connect true (context, Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
+	(* Only supporting on slave nodes *)
+		  
+	val _ = Msg.send (bio, MsgFirewallRegen)
+
+	fun handleResult () =
+	    case Msg.recv bio of
+		NONE => (print "Server closed connection unexpectedly.\n";
+			 OS.Process.failure)
+	      | SOME m =>
+		case m of
+		    MsgOk => (print "Firewall regenerated.\n";
+			      OS.Process.success)
+		  | MsgError s => (print ("Firewall regeneration failed: " ^ s ^ "\n");
+				   OS.Process.failure)
+		  | _ => (print "Unexpected server reply.\n";
+			  OS.Process.failure)
+    in
+	handleResult()
+	before OpenSSL.close bio
+    end
+
 structure SS = StringSet
 
 fun domainList dname =
@@ -1006,7 +1093,7 @@ fun regenerateEither tc checker context =
 	val ok = ref true
  
 	fun contactNode (node, ip) =
-	    if node = Config.defaultNode then
+	    if node = Config.dispatcherName then
 		Domain.resetLocal ()
 	    else let
 		    val bio = OpenSSL.connect true (context,
@@ -1064,7 +1151,9 @@ fun regenerateEither tc checker context =
 			     ok := false)
 			else
 			    ();
-			ignore (foldl checker' (basis (), Defaults.eInit ()) files)
+			let val basis' = basis () in
+			    ignore (foldl checker' (basis', SM.empty) files)
+			end
 		    end
 		else if String.isSuffix "_admin" user then
 		    ()    
@@ -1110,6 +1199,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"}
@@ -1119,7 +1212,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 ()))
@@ -1127,20 +1221,61 @@ fun now () = Date.toString (Date.fromTimeUniv (Time.now ()))
 fun answerQuery q =
     case q of
 	QApt pkg => if Apt.installed pkg then MsgYes else MsgNo
+      | QAptExists pkg => (case Apt.info pkg of
+			      SOME {section, description} => MsgAptQuery {section = section, description = description}
+			    | NONE => MsgNo)
       | QCron user => if Cron.allowed user then MsgYes else MsgNo
       | QFtp user => if Ftp.allowed user then MsgYes else MsgNo
       | QTrustedPath user => if TrustedPath.query user then MsgYes else MsgNo
       | QSocket user => MsgSocket (SocketPerm.query user)
-      | QFirewall user => MsgFirewall (Firewall.query user)
+      | QFirewall {node, user} => MsgFirewall (Firewall.query (node, user))
 
 fun describeQuery q =
     case q of
 	QApt pkg => "Requested installation status of package " ^ pkg
+      | QAptExists pkg => "Requested if package " ^ pkg ^ " exists"
       | QCron user => "Asked about cron permissions for user " ^ user
       | QFtp user => "Asked about FTP permissions for user " ^ user
       | QTrustedPath user => "Asked about trusted path settings for user " ^ user
       | QSocket user => "Asked about socket permissions for user " ^ user
-      | QFirewall user => "Asked about firewall rules for user " ^ user
+      | QFirewall {node, user} => "Asked about firewall rules on " ^ node ^ " 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
@@ -1163,43 +1298,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
@@ -1219,7 +1318,9 @@ fun service () =
 				 end
 			 in
 			     doIt (fn () => (Env.pre ();
-					     ignore (foldl doOne (basis (), Defaults.eInit ()) codes);
+					     let val basis' = basis () in
+						 ignore (foldl doOne (basis', SM.empty) codes)
+					     end;
 					     Env.post ();
 					     Msg.send (bio, MsgOk);
 					     ("Configuration complete.", NONE)))
@@ -1265,6 +1366,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
@@ -1356,89 +1461,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, 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 () => ())
-
 			       | MsgListMailboxes domain =>
 				 doIt (fn () =>
 					  if not (Domain.yourDomain domain) then
@@ -1530,6 +1552,7 @@ fun service () =
 					      NONE => ("User tried to set SA filtering for " ^ addr,
 						       SOME "You aren't allowed to configure SA filtering for that recipient.")
 					    | SOME addr' => (SetSA.set (addr', b);
+							     SetSA.rebuild ();
 							     Msg.send (bio, MsgOk);
 							     ("Set SA filtering status for " ^ addr ^ " to "
 							      ^ (if b then "ON" else "OFF"),
@@ -1553,18 +1576,6 @@ fun service () =
 						 (describeQuery q,
 						  NONE)))
 				      (fn () => ())
-
-			       | MsgMysqlFixperms =>
-				 (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 () => ()))
-
 			       | MsgDescribe dom =>
 				 doIt (fn () => if not (Domain.validDomain dom) then
 						    ("Requested description of invalid domain " ^ dom,
@@ -1579,6 +1590,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"))
@@ -1649,69 +1670,200 @@ 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"))
+				       | MsgSaChanged => (if Slave.shell [Config.SpamAssassin.postReload] then
+							      Msg.send (bio, MsgOk)
+							  else
+							      Msg.send (bio, MsgError "Error reloading SpamAssassin addresses"))
+				       | _ => (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 () => ())
+				   | MsgMysqlFixperms =>
+				     (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 () => ()))
+				   | MsgFirewallRegen =>
+				     doIt (fn () => (Acl.read Config.aclFile;
+						     if Acl.query {user = user, class = "priv", value = "all"} then
+							 if List.exists (fn x => x = host) Config.Firewall.firewallNodes then
+							     if (Firewall.generateFirewallConfig (Firewall.parseRules ()) andalso Firewall.publishConfig ())
+							     then
+								 ("Firewall rules regenerated.", NONE)
+							     else
+								("Rules regeneration failed!", SOME "Script execution failed.")
+							else ("Node not controlled by domtool firewall.", SOME (host))
+						     else
+							 ("Not authorized to regenerate firewall.", SOME ("Unauthorized user " ^ user ^ " attempted to regenerated firewall"))))
+					  (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