X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/blobdiff_plain/21d921a56a850857f6ea883c6dff6a411a659bbf..d351d679283a797c98f5f65d18aa757c18e56305:/src/main.sml

diff --git a/src/main.sml b/src/main.sml
index ec98e4e..05bce83 100644
--- a/src/main.sml
+++ b/src/main.sml
@@ -167,6 +167,9 @@ fun eval' fname =
 val dispatcher =
     Config.dispatcher ^ ":" ^ Int.toString Config.dispatcherPort
 
+val self =
+    "localhost:" ^ Int.toString Config.slavePort
+
 fun requestContext f =
     let
 	val uid = Posix.ProcEnv.getuid ()
@@ -191,6 +194,13 @@ fun requestBio f =
 	(user, OpenSSL.connect (context, dispatcher))
     end
 
+fun requestSlaveBio () =
+    let
+	val (user, context) = requestContext (fn () => ())
+    in
+	(user, OpenSSL.connect (context, self))
+    end
+
 fun request fname =
     let
 	val (user, bio) = requestBio (fn () => ignore (check fname))
@@ -275,6 +285,54 @@ fun requestDir dname =
     end
     handle ErrorMsg.Error => ()
 
+fun requestPing () =
+    let
+	val (_, bio) = requestBio (fn () => ())
+    in
+	OpenSSL.close bio;
+	OS.Process.success
+    end
+    handle _ => OS.Process.failure
+
+fun requestShutdown () =
+    let
+	val (_, bio) = requestBio (fn () => ())
+    in
+	Msg.send (bio, MsgShutdown);
+	case Msg.recv bio of
+	    NONE => print "Server closed connection unexpectedly.\n"
+	  | SOME m =>
+	    case m of
+		MsgOk => print "Shutdown begun.\n"
+	      | MsgError s => print ("Shutdown failed: " ^ s ^ "\n")
+	      | _ => print "Unexpected server reply.\n";
+	OpenSSL.close bio
+    end
+
+fun requestSlavePing () =
+    let
+	val (_, bio) = requestSlaveBio ()
+    in
+	OpenSSL.close bio;
+	OS.Process.success
+    end
+    handle _ => OS.Process.failure
+
+fun requestSlaveShutdown () =
+    let
+	val (_, bio) = requestSlaveBio ()
+    in
+	Msg.send (bio, MsgShutdown);
+	case Msg.recv bio of
+	    NONE => print "Server closed connection unexpectedly.\n"
+	  | SOME m =>
+	    case m of
+		MsgOk => print "Shutdown begun.\n"
+	      | MsgError s => print ("Shutdown failed: " ^ s ^ "\n")
+	      | _ => print "Unexpected server reply.\n";
+	OpenSSL.close bio
+    end
+
 fun requestGrant acl =
     let
 	val (user, bio) = requestBio (fn () => ())
@@ -401,6 +459,21 @@ fun requestDbUser dbtype =
 	OpenSSL.close bio
     end
 
+fun requestDbPasswd rc =
+    let
+	val (_, bio) = requestBio (fn () => ())
+    in
+	Msg.send (bio, MsgDbPasswd rc);
+	case Msg.recv bio of
+	    NONE => print "Server closed connection unexpectedly.\n"
+	  | SOME m =>
+	    case m of
+		MsgOk => print "Your password has been changed.\n"
+	      | MsgError s => print ("Password set failed: " ^ s ^ "\n")
+	      | _ => print "Unexpected server reply.\n";
+	OpenSSL.close bio
+    end
+
 fun requestDbTable p =
     let
 	val (user, bio) = requestBio (fn () => ())
@@ -416,6 +489,208 @@ fun requestDbTable p =
 	OpenSSL.close bio
     end
 
+fun requestListMailboxes domain =
+    let
+	val (_, bio) = requestBio (fn () => ())
+    in
+	Msg.send (bio, MsgListMailboxes domain);
+	(case Msg.recv bio of
+	     NONE => Vmail.Error "Server closed connection unexpectedly."
+	   | SOME m =>
+	     case m of
+		 MsgMailboxes users => (Msg.send (bio, MsgOk);
+					Vmail.Listing users)
+	       | MsgError s => Vmail.Error ("Creation failed: " ^ s)
+	       | _ => Vmail.Error "Unexpected server reply.")
+	before OpenSSL.close bio
+    end
+
+fun requestNewMailbox p =
+    let
+	val (_, bio) = requestBio (fn () => ())
+    in
+	Msg.send (bio, MsgNewMailbox p);
+	case Msg.recv bio of
+	    NONE => print "Server closed connection unexpectedly.\n"
+	  | SOME m =>
+	    case m of
+		MsgOk => print ("A mapping for " ^ #user p ^ "@" ^ #domain p ^ " has been created.\n")
+	      | MsgError s => print ("Creation failed: " ^ s ^ "\n")
+	      | _ => print "Unexpected server reply.\n";
+	OpenSSL.close bio
+    end
+
+fun requestPasswdMailbox p =
+    let
+	val (_, bio) = requestBio (fn () => ())
+    in
+	Msg.send (bio, MsgPasswdMailbox p);
+	case Msg.recv bio of
+	    NONE => print "Server closed connection unexpectedly.\n"
+	  | SOME m =>
+	    case m of
+		MsgOk => print ("The password for " ^ #user p ^ "@" ^ #domain p ^ " has been changed.\n")
+	      | MsgError s => print ("Set failed: " ^ s ^ "\n")
+	      | _ => print "Unexpected server reply.\n";
+	OpenSSL.close bio
+    end
+
+fun requestRmMailbox p =
+    let
+	val (_, bio) = requestBio (fn () => ())
+    in
+	Msg.send (bio, MsgRmMailbox p);
+	case Msg.recv bio of
+	    NONE => print "Server closed connection unexpectedly.\n"
+	  | SOME m =>
+	    case m of
+		MsgOk => print ("The mapping for mailbox " ^ #user p ^ "@" ^ #domain p ^ " has been deleted.\n")
+	      | MsgError s => print ("Remove failed: " ^ s ^ "\n")
+	      | _ => print "Unexpected server reply.\n";
+	OpenSSL.close bio
+    end
+
+fun requestSaQuery addr =
+    let
+	val (_, bio) = requestBio (fn () => ())
+    in
+	Msg.send (bio, MsgSaQuery addr);
+	(case Msg.recv bio of
+	     NONE => print "Server closed connection unexpectedly.\n"
+	   | SOME m =>
+	     case m of
+		 MsgSaStatus b => (print ("SpamAssassin filtering for " ^ addr ^ " is "
+					  ^ (if b then "ON" else "OFF") ^ ".\n");
+				   Msg.send (bio, MsgOk))
+	       | MsgError s => print ("Query failed: " ^ s ^ "\n")
+	       | _ => print "Unexpected server reply.\n")
+	before OpenSSL.close bio
+    end
+
+fun requestSaSet p =
+    let
+	val (_, bio) = requestBio (fn () => ())
+    in
+	Msg.send (bio, MsgSaSet p);
+	case Msg.recv bio of
+	    NONE => print "Server closed connection unexpectedly.\n"
+	  | SOME m =>
+	    case m of
+		MsgOk => print ("SpamAssassin filtering for " ^ #1 p ^ " is now "
+				^ (if #2 p then "ON" else "OFF") ^ ".\n")
+	      | MsgError s => print ("Set failed: " ^ s ^ "\n")
+	      | _ => print "Unexpected server reply.\n";
+	OpenSSL.close bio
+    end
+
+fun requestSmtpLog domain =
+    let
+	val (_, bio) = requestBio (fn () => ())
+
+	val _ = Msg.send (bio, MsgSmtpLogReq domain)
+
+	fun loop () =
+	    case Msg.recv bio of
+		NONE => print "Server closed connection unexpectedly.\n"
+	      | SOME m =>
+		case m of
+		    MsgOk => ()
+		  | MsgSmtpLogRes line => (print line;
+					   loop ())
+		  | MsgError s => print ("Log search failed: " ^ s ^ "\n")
+		  | _ => print "Unexpected server reply.\n"
+    in
+	loop ();
+	OpenSSL.close bio
+    end
+
+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 _ = Msg.send (bio, MsgQuery (QApt pkg))
+
+	fun loop () =
+	    case Msg.recv bio of
+		NONE => (print "Server closed connection unexpectedly.\n";
+			 OS.Process.failure)
+	      | SOME m =>
+		case m of
+		    MsgYes => (print "Package is installed.\n";
+			       OS.Process.success)
+		  | MsgNo => (print "Package is not installed.\n";
+			      OS.Process.failure)
+		  | MsgError s => (print ("APT 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 (context, if node = Config.masterNode then
+						dispatcher
+					    else
+						Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
+
+	val _ = Msg.send (bio, MsgQuery (QCron uname))
+
+	fun loop () =
+	    case Msg.recv bio of
+		NONE => (print "Server closed connection unexpectedly.\n";
+			 OS.Process.failure)
+	      | SOME m =>
+		case m of
+		    MsgYes => (print "User has cron permissions.\n";
+			       OS.Process.success)
+		  | MsgNo => (print "User does not have cron permissions.\n";
+			      OS.Process.failure)
+		  | MsgError s => (print ("Cron query failed: " ^ s ^ "\n");
+				   OS.Process.failure)
+		  | _ => (print "Unexpected server reply.\n";
+			  OS.Process.failure)
+    in
+	loop ()
+	before OpenSSL.close bio
+    end
+
+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 _ = Msg.send (bio, MsgQuery (QFtp uname))
+
+	fun loop () =
+	    case Msg.recv bio of
+		NONE => (print "Server closed connection unexpectedly.\n";
+			 OS.Process.failure)
+	      | SOME m =>
+		case m of
+		    MsgYes => (print "User has FTP permissions.\n";
+			       OS.Process.success)
+		  | MsgNo => (print "User does not have FTP permissions.\n";
+			      OS.Process.failure)
+		  | MsgError s => (print ("FTP query failed: " ^ s ^ "\n");
+				   OS.Process.failure)
+		  | _ => (print "Unexpected server reply.\n";
+			  OS.Process.failure)
+    in
+	loop ()
+	before OpenSSL.close bio
+    end
+
 fun regenerate context =
     let
 	val b = basis ()
@@ -477,6 +752,7 @@ fun regenerate context =
 	    end
 		handle IO.Io _ => ()
 		     | OS.SysErr (s, _) => print ("System error processing user " ^ user ^ ": " ^ s ^ "\n")
+		     | ErrorMsg.Error => print ("User " ^ user ^ " had a compilation error.\n")
     in
 	app contactNode Config.nodeIps;
 	Env.pre ();
@@ -496,6 +772,20 @@ fun rmuser user =
 	Domain.rmdom doms
     end
 
+fun now () = Date.toString (Date.fromTimeUniv (Time.now ()))
+
+fun answerQuery q =
+    case q of
+	QApt pkg => if Apt.installed pkg then MsgYes else MsgNo
+      | QCron user => if Cron.allowed user then MsgYes else MsgNo
+      | QFtp user => if Ftp.allowed user then MsgYes else MsgNo
+
+fun describeQuery q =
+    case q of
+	QApt pkg => "Requested installation status of package " ^ pkg
+      | QCron user => "Asked about cron permissions for user " ^ user
+      | QFtp user => "Asked about FTP permissions for user " ^ user
+
 fun service () =
     let
 	val () = Acl.read Config.aclFile
@@ -513,9 +803,43 @@ fun service () =
 	      | SOME bio =>
 		let
 		    val user = OpenSSL.peerCN bio
-		    val () = print ("\nConnection from " ^ user ^ "\n")
+		    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 OpenSSL.OpenSSL _ =>
+				print "OpenSSL error\n"
+			      | 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 doConfig codes =
 			let
 			    val _ = print "Configuration:\n"
@@ -533,27 +857,28 @@ fun service () =
 				    eval' outname
 				end
 			in
-			    (Env.pre ();
-			     app doOne codes;
-			     Env.post ();
-			     Msg.send (bio, MsgOk))
-			    handle ErrorMsg.Error =>
-				   (print "Compilation error\n";
-				    Msg.send (bio,
-					      MsgError "Error during configuration evaluation"))
-				 | OpenSSL.OpenSSL s =>
-				   (print "OpenSSL error\n";
-				    Msg.send (bio,
-					      MsgError
-						  ("Error during configuration evaluation: "
-						   ^ s)));
-			   OS.FileSys.remove outname;
-			   (ignore (OpenSSL.readChar bio);
-			    OpenSSL.close bio)
-			   handle OpenSSL.OpenSSL _ => ();
-			   loop ()
+			    doIt (fn () => (Env.pre ();
+					    app doOne codes;
+					    Env.post ();
+					    Msg.send (bio, MsgOk);
+					    ("Configuration complete.", NONE)))
+				 (fn () => OS.FileSys.remove outname)
 			end
 
+		    fun checkAddr s =
+			case String.fields (fn ch => ch = #"@") s of
+			    [user'] =>
+			    if user = user' then
+				SOME (SetSA.User s)
+			    else
+				NONE
+			  | [user', domain] =>
+			    if Domain.validEmailUser user' andalso Domain.yourDomain domain then
+				SOME (SetSA.Email s)
+			    else
+				NONE
+			  | _ => NONE
+
 		    fun cmdLoop () =
 			case Msg.recv bio of
 			    NONE => (OpenSSL.close bio
@@ -564,231 +889,256 @@ fun service () =
 				MsgConfig code => doConfig [code]
 			      | MsgMultiConfig codes => doConfig codes
 
-			      | MsgGrant acl =>
-				if Acl.query {user = user, class = "priv", value = "all"} then
-				    ((Acl.grant acl;
-				      Acl.write Config.aclFile;
-				      Msg.send (bio, MsgOk);
-				      print ("Granted permission " ^ #value acl ^ " to " ^ #user acl ^ " in " ^ #class acl ^ ".\n"))
-				     handle OpenSSL.OpenSSL s =>
-					    (print "OpenSSL error\n";
-					     Msg.send (bio,
-						       MsgError
-							   ("Error during granting: "
-							    ^ s)));
-				    (ignore (OpenSSL.readChar bio);
-				     OpenSSL.close bio)
-				    handle OpenSSL.OpenSSL _ => ();
-				    loop ())
+			      | MsgShutdown =>
+				if Acl.query {user = user, class = "priv", value = "all"}
+				   orelse Acl.query {user = user, class = "priv", value = "shutdown"} then
+				    print ("Domtool dispatcher shutting down at " ^ now () ^ "\n\n")
 				else
-				    ((Msg.send (bio, MsgError "Not authorized to grant privileges");
-				      print "Unauthorized user asked to grant a permission!\n";
-				      ignore (OpenSSL.readChar bio);
-				      OpenSSL.close bio)
+				    (print "Unauthorized shutdown command!\n";
+				     OpenSSL.close bio
 				     handle OpenSSL.OpenSSL _ => ();
 				     loop ())
 
+			      | MsgGrant acl =>
+				doIt (fn () =>
+					 if Acl.query {user = user, class = "priv", value = "all"} then
+					     (Acl.grant acl;
+					      Acl.write Config.aclFile;
+					      ("Granted permission " ^ #value acl ^ " to " ^ #user acl ^ " in " ^ #class acl ^ ".",
+					       NONE))
+					 else
+					     ("Unauthorized user asked to grant a permission!",
+					      SOME "Not authorized to grant privileges"))
+				     (fn () => ())
+							 
 			      | MsgRevoke acl =>
-				if Acl.query {user = user, class = "priv", value = "all"} then
-				    ((Acl.revoke acl;
-				      Acl.write Config.aclFile;
-				      Msg.send (bio, MsgOk);
-				      print ("Revoked permission " ^ #value acl ^ " from " ^ #user acl ^ " in " ^ #class acl ^ ".\n"))
-				     handle OpenSSL.OpenSSL s =>
-					    (print "OpenSSL error\n";
-					     Msg.send (bio,
-						       MsgError
-							   ("Error during revocation: "
-							    ^ s)));
-				    (ignore (OpenSSL.readChar bio);
-				     OpenSSL.close bio)
-				    handle OpenSSL.OpenSSL _ => ();
-				    loop ())
-				else
-				    ((Msg.send (bio, MsgError "Not authorized to revoke privileges");
-				      print "Unauthorized user asked to revoke a permission!\n";
-				      ignore (OpenSSL.readChar bio);
-				      OpenSSL.close bio)
-				     handle OpenSSL.OpenSSL _ => ();
-				     loop ())
+				doIt (fn () =>
+					 if Acl.query {user = user, class = "priv", value = "all"} then
+					     (Acl.revoke acl;
+					      Acl.write Config.aclFile;
+					      ("Revoked permission " ^ #value acl ^ " from " ^ #user acl ^ " in " ^ #class acl ^ ".",
+					       NONE))
+					 else
+					     ("Unauthorized user asked to revoke a permission!",
+					      SOME "Not authorized to revoke privileges"))
+				     (fn () => ())
 
 			      | MsgListPerms user =>
-				((Msg.send (bio, MsgPerms (Acl.queryAll user));
-				  print ("Sent permission list for user " ^ user ^ ".\n"))
-				 handle OpenSSL.OpenSSL s =>
-					(print "OpenSSL error\n";
-					 Msg.send (bio,
-						   MsgError
-						       ("Error during permission listing: "
-							^ s)));
-				(ignore (OpenSSL.readChar bio);
-				 OpenSSL.close bio)
-				handle OpenSSL.OpenSSL _ => ();
-				loop ())
+				doIt (fn () =>
+					 (Msg.send (bio, MsgPerms (Acl.queryAll user));
+					  ("Sent permission list for user " ^ user ^ ".",
+					   NONE)))
+				     (fn () => ())
 
 			      | MsgWhoHas perm =>
-				((Msg.send (bio, MsgWhoHasResponse (Acl.whoHas perm));
-				  print ("Sent whohas response for " ^ #class perm ^ " / " ^ #value perm ^ ".\n"))
-				 handle OpenSSL.OpenSSL s =>
-					(print "OpenSSL error\n";
-					 Msg.send (bio,
-						   MsgError
-						       ("Error during whohas: "
-							^ s)));
-				(ignore (OpenSSL.readChar bio);
-				 OpenSSL.close bio)
-				handle OpenSSL.OpenSSL _ => ();
-				loop ())
+				doIt (fn () =>
+					 (Msg.send (bio, MsgWhoHasResponse (Acl.whoHas perm));
+					  ("Sent whohas response for " ^ #class perm ^ " / " ^ #value perm ^ ".",
+					   NONE)))
+				     (fn () => ())
 
 			      | MsgRmdom doms =>
-				if Acl.query {user = user, class = "priv", value = "all"}
-				   orelse List.all (fn dom => Acl.query {user = user, class = "domain", value = dom}) doms then
-				    ((Domain.rmdom doms;
-				      app (fn dom =>
-					      Acl.revokeFromAll {class = "domain", value = dom}) doms;
-				      Acl.write Config.aclFile;
-				      Msg.send (bio, MsgOk);
-				      print ("Removed domains" ^ foldl (fn (d, s) => s ^ " " ^ d) "" doms ^ ".\n"))
-				     handle OpenSSL.OpenSSL s =>
-					    (print "OpenSSL error\n";
-					     Msg.send (bio,
-						       MsgError
-							   ("Error during revocation: "
-							    ^ s)));
-				    (ignore (OpenSSL.readChar bio);
-				     OpenSSL.close bio)
-				    handle OpenSSL.OpenSSL _ => ();
-				    loop ())
-				else
-				    ((Msg.send (bio, MsgError "Not authorized to remove that domain");
-				      print "Unauthorized user asked to remove a domain!\n";
-				      ignore (OpenSSL.readChar bio);
-				      OpenSSL.close bio)
-				     handle OpenSSL.OpenSSL _ => ();
-				     loop ())
+				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
+					     (Domain.rmdom doms;
+					      app (fn dom =>
+						      Acl.revokeFromAll {class = "domain", value = dom}) doms;
+					      Acl.write Config.aclFile;
+					      ("Removed domains" ^ foldl (fn (d, s) => s ^ " " ^ d) "" doms ^ ".",
+					       NONE))
+					 else
+					     ("Unauthorized user asked to remove a domain!",
+					      SOME "Not authorized to remove that domain"))
+				     (fn () => ())
 
 			      | MsgRegenerate =>
-				if Acl.query {user = user, class = "priv", value = "regen"}
-				   orelse Acl.query {user = user, class = "priv", value = "all"} then
-				    ((regenerate context;
-				      Msg.send (bio, MsgOk);
-				      print "Regenerated all configuration.\n")
-				     handle OpenSSL.OpenSSL s =>
-					    (print "OpenSSL error\n";
-					     Msg.send (bio,
-						       MsgError
-							   ("Error during regeneration: "
-							    ^ s)));
-				    (ignore (OpenSSL.readChar bio);
-				     OpenSSL.close bio)
-				    handle OpenSSL.OpenSSL _ => ();
-				    loop ())
-				else
-				    ((Msg.send (bio, MsgError "Not authorized to regeneration");
-				      print "Unauthorized user asked to regenerate!\n";
-				      ignore (OpenSSL.readChar bio);
-				      OpenSSL.close bio)
-				     handle OpenSSL.OpenSSL _ => ();
-				     loop ())
+				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))
+					 else
+					     ("Unauthorized user asked to regenerate!",
+					      SOME "Not authorized to regenerate"))
+				     (fn () => ())
 
 			      | MsgRmuser user' =>
-				if Acl.query {user = user, class = "priv", value = "all"} then
-				    ((rmuser user';
-				      Acl.write Config.aclFile;
-				      Msg.send (bio, MsgOk);
-				      print ("Removed user " ^ user' ^ ".\n"))
-				     handle OpenSSL.OpenSSL s =>
-					    (print "OpenSSL error\n";
-					     Msg.send (bio,
-						       MsgError
-							   ("Error during revocation: "
-							    ^ s)));
-				    (ignore (OpenSSL.readChar bio);
-				     OpenSSL.close bio)
-				    handle OpenSSL.OpenSSL _ => ();
-				    loop ())
-				else
-				    ((Msg.send (bio, MsgError "Not authorized to remove users");
-				      print "Unauthorized user asked to remove a user!\n";
-				      ignore (OpenSSL.readChar bio);
-				      OpenSSL.close bio)
-				     handle OpenSSL.OpenSSL _ => ();
-				     loop ())
+				doIt (fn () =>
+					 if Acl.query {user = user, class = "priv", value = "all"} then
+					     (rmuser user';
+					      Acl.write Config.aclFile;
+					      ("Removed user " ^ user' ^ ".",
+					       NONE))
+					 else
+					     ("Unauthorized user asked to remove a user!",
+					      SOME "Not authorized to remove users"))
+				     (fn () => ())
 
 			      | MsgCreateDbUser {dbtype, passwd} =>
-				(case Dbms.lookup dbtype of
-				     NONE => ((Msg.send (bio, MsgError ("Unknown database type " ^ dbtype));
-					       print ("Database user creation request with unknown datatype type " ^ dbtype);
-					       ignore (OpenSSL.readChar bio))
-					      handle OpenSSL.OpenSSL _ => ();
-					      OpenSSL.close bio
-					      handle OpenSSL.OpenSSL _ => ();
-					      loop ())
-				   | SOME handler =>
-				     case #adduser handler {user = user, passwd = passwd} of
-					 NONE => ((Msg.send (bio, MsgOk);
-						   print ("Added " ^ dbtype ^ " user " ^ user ^ ".\n"))
-						  handle OpenSSL.OpenSSL s =>
-							 (print "OpenSSL error\n";
-							  Msg.send (bio,
-								    MsgError
-									("Error during creation: "
-									 ^ s)));
-				                  (ignore (OpenSSL.readChar bio);
-						   OpenSSL.close bio)
-						  handle OpenSSL.OpenSSL _ => ();
-						  loop ())
-				       | SOME msg => ((Msg.send (bio, MsgError ("Error adding user: " ^ msg));
-						       print ("Error adding a " ^ dbtype ^ " user " ^ user ^ ": " ^ msg ^ "\n");
-						       ignore (OpenSSL.readChar bio);
-						       OpenSSL.close bio)
-						      handle OpenSSL.OpenSSL _ => ();
-						      loop ()))
+				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 () => ())
 
 			      | MsgCreateDbTable {dbtype, dbname} =>
-				if Dbms.validDbname dbname then
-				    (case Dbms.lookup dbtype of
-					 NONE => ((Msg.send (bio, MsgError ("Unknown database type " ^ dbtype));
-						   print ("Database creation request with unknown datatype type " ^ dbtype);
-						   ignore (OpenSSL.readChar bio))
-						  handle OpenSSL.OpenSSL _ => ();
-						  OpenSSL.close bio
-						  handle OpenSSL.OpenSSL _ => ();
-						  loop ())
-				       | SOME handler =>
-					 case #createdb handler {user = user, dbname = dbname} of
-					     NONE => ((Msg.send (bio, MsgOk);
-						       print ("Created database " ^ user ^ "_" ^ dbname ^ ".\n"))
-						      handle OpenSSL.OpenSSL s =>
-							     (print "OpenSSL error\n";
-							      Msg.send (bio,
-									MsgError
-									    ("Error during creation: "
-									     ^ s)));
-						      (ignore (OpenSSL.readChar bio);
-						       OpenSSL.close bio)
-						      handle OpenSSL.OpenSSL _ => ();
-						      loop ())
-					   | SOME msg => ((Msg.send (bio, MsgError ("Error creating database: " ^ msg));
-							   print ("Error creating database " ^ user ^ "_" ^ dbname ^ ": " ^ msg ^ "\n");
-							   ignore (OpenSSL.readChar bio);
-							   OpenSSL.close bio)
-							  handle OpenSSL.OpenSSL _ => ();
-							  loop ()))
-				else
-				    ((Msg.send (bio, MsgError ("Invalid database name " ^ dbname));
-				      print ("Invalid database name " ^ user ^ "_" ^ dbname ^ "\n");
-				      ignore (OpenSSL.readChar bio);
-				      OpenSSL.close bio)
-				     handle OpenSSL.OpenSSL _ => ();
-				     loop ())
+				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 () => ())
+
+			      | MsgListMailboxes domain =>
+				doIt (fn () =>
+					 if not (Domain.yourDomain domain) then
+					     ("User wasn't authorized to list mailboxes for " ^ domain,
+					      SOME "You're not authorized to configure that domain.")
+					 else
+					     case Vmail.list domain of
+						 Vmail.Listing users => (Msg.send (bio, MsgMailboxes users);
+									 ("Sent mailbox list for " ^ domain,
+									  NONE))
+					       | Vmail.Error msg => ("Error listing mailboxes for " ^ domain ^ ": " ^ msg,
+								     SOME msg))
+				     (fn () => ())
+
+			      | MsgNewMailbox {domain, user = emailUser, passwd, mailbox} =>
+				doIt (fn () =>
+					 if not (Domain.yourDomain domain) then
+					     ("User wasn't authorized to add a mailbox to " ^ domain,
+					      SOME "You're not authorized to configure that domain.")
+					 else if not (Domain.validEmailUser emailUser) then
+					     ("Invalid e-mail username " ^ emailUser,
+					      SOME "Invalid e-mail username")
+					 else if not (CharVector.all Char.isGraph passwd) then
+					     ("Invalid password",
+					      SOME "Invalid password; may only contain printable, non-space characters")
+					 else if not (Domain.yourPath mailbox) then
+					     ("User wasn't authorized to add a mailbox at " ^ mailbox,
+					      SOME "You're not authorized to use that mailbox location.")
+					 else
+					     case Vmail.add {requester = user,
+							     domain = domain, user = emailUser,
+							     passwd = passwd, mailbox = mailbox} of
+						 NONE => ("Added mailbox " ^ emailUser ^ "@" ^ domain ^ " at " ^ mailbox,
+							  NONE)
+					       | SOME msg => ("Error adding mailbox " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
+							      SOME msg))
+				     (fn () => ())
+				
+			      | MsgPasswdMailbox {domain, user = emailUser, passwd} =>
+				doIt (fn () =>
+					 if not (Domain.yourDomain domain) then
+					     ("User wasn't authorized to change password of a mailbox for " ^ domain,
+					      SOME "You're not authorized to configure that domain.")
+					 else if not (Domain.validEmailUser emailUser) then
+					     ("Invalid e-mail username " ^ emailUser,
+					      SOME "Invalid e-mail username")
+					 else if not (CharVector.all Char.isGraph passwd) then
+					     ("Invalid password",
+					      SOME "Invalid password; may only contain printable, non-space characters")
+					 else
+					     case Vmail.passwd {domain = domain, user = emailUser,
+								passwd = passwd} of
+						 NONE => ("Changed password of mailbox " ^ emailUser ^ "@" ^ domain,
+							  NONE)
+					       | SOME msg => ("Error changing mailbox password for " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
+							      SOME msg))
+				     (fn () => ())
+
+			      | MsgRmMailbox {domain, user = emailUser} =>
+				doIt (fn () =>
+					 if not (Domain.yourDomain domain) then
+					     ("User wasn't authorized to change password of a mailbox for " ^ domain,
+					      SOME "You're not authorized to configure that domain.")
+					 else if not (Domain.validEmailUser emailUser) then
+					     ("Invalid e-mail username " ^ emailUser,
+					      SOME "Invalid e-mail username")
+					 else
+					     case Vmail.rm {domain = domain, user = emailUser} of
+						 NONE => ("Deleted mailbox " ^ emailUser ^ "@" ^ domain,
+							  NONE)
+					       | SOME msg => ("Error deleting mailbox " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
+							      SOME msg))
+				     (fn () => ())
+
+			      | MsgSaQuery addr =>
+				doIt (fn () =>
+					 case checkAddr addr of
+					     NONE => ("User tried to query SA filtering for " ^ addr,
+						      SOME "You aren't allowed to configure SA filtering for that recipient.")
+					   | SOME addr' => (Msg.send (bio, MsgSaStatus (SetSA.query addr'));
+							    ("Queried SA filtering status for " ^ addr,
+							     NONE)))
+				     (fn () => ())
+
+			      | MsgSaSet (addr, b) =>
+				doIt (fn () =>
+					 case checkAddr addr of
+					     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);
+							    Msg.send (bio, MsgOk);
+							    ("Set SA filtering status for " ^ addr ^ " to "
+							     ^ (if b then "ON" else "OFF"),
+							     NONE)))
+				     (fn () => ())
+
+			      | MsgSmtpLogReq domain =>
+				doIt (fn () =>
+					 if not (Domain.yourDomain domain) then
+					     ("Unauthorized user tried to request SMTP logs for " ^ domain,
+					      SOME "You aren't authorized to configure that domain.")
+					 else
+					     (SmtpLog.search (fn line => Msg.send (bio, MsgSmtpLogRes line))
+					      domain;
+					      ("Requested SMTP logs for " ^ domain,
+					       NONE)))
+				(fn () => ())
+
+			      | MsgQuery q =>
+				doIt (fn () => (Msg.send (bio, answerQuery q);
+						(describeQuery q,
+						 NONE)))
+				(fn () => ())
 
 			      | _ =>
-				(Msg.send (bio, MsgError "Unexpected command")
-				 handle OpenSSL.OpenSSL _ => ();
-				 OpenSSL.close bio
-				 handle OpenSSL.OpenSSL _ => ();
-				 loop ())
+				doIt (fn () => ("Unexpected command",
+						SOME "Unexpected command"))
+				     (fn () => ())
 		in
 		    cmdLoop ()
 		end
@@ -803,6 +1153,7 @@ fun service () =
 			    handle OpenSSL.OpenSSL _ => ();
 			    loop ())
     in
+	print ("Domtool dispatcher starting up at " ^ now () ^ "\n");
 	print "Listening for connections....\n";
 	loop ();
 	OpenSSL.shutdown sock
@@ -818,19 +1169,17 @@ fun slave () =
 
 	val sock = OpenSSL.listen (context, Config.slavePort)
 
+	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 ^ "\n")
+		    val () = print ("\nConnection from " ^ peer ^ " at " ^ now () ^ "\n")
 		in
-		    if peer <> Config.dispatcherName then
-			(print "Not authorized!\n";
-			 OpenSSL.close bio;
-			 loop ())
-		    else let
+		    if peer = Config.dispatcherName then let
 			    fun loop' files =
 				case Msg.recv bio of
 				    NONE => print "Dispatcher closed connection unexpectedly\n"
@@ -849,6 +1198,21 @@ fun slave () =
 			    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