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

diff --git a/src/main.sml b/src/main.sml
index 03d5877..05bce83 100644
--- a/src/main.sml
+++ b/src/main.sml
@@ -53,7 +53,7 @@ fun basis () =
 		    loop files
 
 	val files = loop []
-	val (_, files) = Order.order files
+	val (_, files) = Order.order NONE files
     in
 	if !ErrorMsg.anyErrors then
 	    Env.empty
@@ -92,6 +92,39 @@ fun check fname =
 	    end
     end
 
+val notTmp = CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"." orelse ch = #"_" orelse ch = #"-")
+
+fun checkDir dname =
+    let
+	val b = basis ()
+
+	val dir = Posix.FileSys.opendir dname
+
+	fun loop files =
+	    case Posix.FileSys.readdir dir of
+		NONE => (Posix.FileSys.closedir dir;
+			 files)
+	      | SOME fname =>
+		if notTmp fname then
+		    loop (OS.Path.joinDirFile {dir = dname,
+					       file = fname}
+			  :: files)
+		else
+		    loop files
+
+	val files = loop []
+	val (_, files) = Order.order (SOME b) files
+    in
+	if !ErrorMsg.anyErrors then
+	    raise ErrorMsg.Error
+	else
+	    (foldl (fn (fname, G) => check' G fname) b files;
+	     if !ErrorMsg.anyErrors then
+		 raise ErrorMsg.Error
+	     else
+		 ())
+    end
+
 fun reduce fname =
     let
 	val (G, body) = check fname
@@ -122,9 +155,21 @@ fun eval fname =
 	    Eval.exec (Defaults.eInit ()) body'
       | NONE => raise ErrorMsg.Error
 
+fun eval' fname =
+    case reduce fname of
+	(SOME body') =>
+	if !ErrorMsg.anyErrors then
+	    raise ErrorMsg.Error
+	else
+	    ignore (Eval.exec' (Defaults.eInit ()) body')
+      | NONE => raise ErrorMsg.Error
+
 val dispatcher =
     Config.dispatcher ^ ":" ^ Int.toString Config.dispatcherPort
 
+val self =
+    "localhost:" ^ Int.toString Config.slavePort
+
 fun requestContext f =
     let
 	val uid = Posix.ProcEnv.getuid ()
@@ -149,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))
@@ -175,6 +227,112 @@ fun request fname =
     end
     handle ErrorMsg.Error => ()
 
+fun requestDir dname =
+    let
+	val _ = ErrorMsg.reset ()
+
+	val (user, bio) = requestBio (fn () => checkDir dname)
+
+	val b = basis ()
+
+	val dir = Posix.FileSys.opendir dname
+
+	fun loop files =
+	    case Posix.FileSys.readdir dir of
+		NONE => (Posix.FileSys.closedir dir;
+			 files)
+	      | SOME fname =>
+		if notTmp fname then
+		    loop (OS.Path.joinDirFile {dir = dname,
+					       file = fname}
+			  :: files)
+		else
+		    loop files
+
+	val files = loop []
+	val (_, files) = Order.order (SOME b) files
+
+	val _ = if !ErrorMsg.anyErrors then
+		    raise ErrorMsg.Error
+		else
+		    ()
+
+	val codes = map (fn fname =>
+			    let	    
+				val inf = TextIO.openIn fname
+
+				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) files
+    in
+	if !ErrorMsg.anyErrors then
+	    ()
+	else
+	    (Msg.send (bio, MsgMultiConfig codes);
+	     case Msg.recv bio of
+		 NONE => print "Server closed connection unexpectedly.\n"
+	       | SOME m =>
+		 case m of
+		     MsgOk => print "Configuration succeeded.\n"
+		   | MsgError s => print ("Configuration failed: " ^ s ^ "\n")
+		   | _ => print "Unexpected server reply.\n";
+	     OpenSSL.close bio)
+    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 () => ())
@@ -223,6 +381,411 @@ fun requestListPerms user =
 	before OpenSSL.close bio
     end
 
+fun requestWhoHas perm =
+    let
+	val (_, bio) = requestBio (fn () => ())
+    in
+	Msg.send (bio, MsgWhoHas perm);
+	(case Msg.recv bio of
+	     NONE => (print "Server closed connection unexpectedly.\n";
+		      NONE)
+	   | SOME m =>
+	     case m of
+		 MsgWhoHasResponse users => SOME users
+	       | MsgError s => (print ("whohas failed: " ^ s ^ "\n");
+				NONE)
+	       | _ => (print "Unexpected server reply.\n";
+		       NONE))
+	before OpenSSL.close bio
+    end
+
+fun requestRegen () =
+    let
+	val (_, bio) = requestBio (fn () => ())
+    in
+	Msg.send (bio, MsgRegenerate);
+	case Msg.recv bio of
+	    NONE => print "Server closed connection unexpectedly.\n"
+	  | SOME m =>
+	    case m of
+		MsgOk => print "Regeneration succeeded.\n"
+	      | MsgError s => print ("Regeneration failed: " ^ s ^ "\n")
+	      | _ => print "Unexpected server reply.\n";
+	OpenSSL.close bio
+    end
+
+fun requestRmdom dom =
+    let
+	val (_, bio) = requestBio (fn () => ())
+    in
+	Msg.send (bio, MsgRmdom dom);
+	case Msg.recv bio of
+	    NONE => print "Server closed connection unexpectedly.\n"
+	  | SOME m =>
+	    case m of
+		MsgOk => print "Removal succeeded.\n"
+	      | MsgError s => print ("Removal failed: " ^ s ^ "\n")
+	      | _ => print "Unexpected server reply.\n";
+	OpenSSL.close bio
+    end
+
+fun requestRmuser user =
+    let
+	val (_, bio) = requestBio (fn () => ())
+    in
+	Msg.send (bio, MsgRmuser user);
+	case Msg.recv bio of
+	    NONE => print "Server closed connection unexpectedly.\n"
+	  | SOME m =>
+	    case m of
+		MsgOk => print "Removal succeeded.\n"
+	      | MsgError s => print ("Removal failed: " ^ s ^ "\n")
+	      | _ => print "Unexpected server reply.\n";
+	OpenSSL.close bio
+    end
+
+fun requestDbUser dbtype =
+    let
+	val (_, bio) = requestBio (fn () => ())
+    in
+	Msg.send (bio, MsgCreateDbUser dbtype);
+	case Msg.recv bio of
+	    NONE => print "Server closed connection unexpectedly.\n"
+	  | SOME m =>
+	    case m of
+		MsgOk => print "Your user has been created.\n"
+	      | MsgError s => print ("Creation failed: " ^ s ^ "\n")
+	      | _ => print "Unexpected server reply.\n";
+	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 () => ())
+    in
+	Msg.send (bio, MsgCreateDbTable p);
+	case Msg.recv bio of
+	    NONE => print "Server closed connection unexpectedly.\n"
+	  | SOME m =>
+	    case m of
+		MsgOk => print ("Your database " ^ user ^ "_" ^ #dbname p ^ " has been created.\n")
+	      | MsgError s => print ("Creation failed: " ^ s ^ "\n")
+	      | _ => print "Unexpected server reply.\n";
+	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 ()
+	val () = Tycheck.disallowExterns ()
+
+	val () = Domain.resetGlobal ()
+
+	fun contactNode (node, ip) =
+	    if node = Config.defaultNode then
+		Domain.resetLocal ()
+	    else let
+		    val bio = OpenSSL.connect (context,
+					       ip
+					       ^ ":"
+					       ^ Int.toString Config.slavePort)
+		in
+		    Msg.send (bio, MsgRegenerate);
+		    case Msg.recv bio of
+			NONE => print "Slave closed connection unexpectedly\n"
+		      | SOME m =>
+			case m of
+			    MsgOk => print ("Slave " ^ node ^ " pre-regeneration finished\n")
+			  | MsgError s => print ("Slave " ^ node
+						 ^ " returned error: " ^
+						 s ^ "\n")
+			  | _ => print ("Slave " ^ node
+					^ " returned unexpected command\n");
+		    OpenSSL.close bio
+		end		
+
+	fun doUser user =
+	    let
+		val _ = Domain.setUser user
+		val _ = ErrorMsg.reset ()
+
+		val dname = Config.domtoolDir user
+
+		val dir = Posix.FileSys.opendir dname
+
+		fun loop files =
+		    case Posix.FileSys.readdir dir of
+			NONE => (Posix.FileSys.closedir dir;
+				 files)
+		      | SOME fname =>
+			if notTmp fname then
+			    loop (OS.Path.joinDirFile {dir = dname,
+						       file = fname}
+				  :: files)
+			else
+			    loop files
+
+		val files = loop []
+		val (_, files) = Order.order (SOME b) files
+	    in
+		if !ErrorMsg.anyErrors then
+		    print ("User " ^ user ^ "'s configuration has errors!\n")
+		else
+		    app eval' files
+	    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 ();
+	app doUser (Acl.users ());
+	Env.post ()
+    end
+
+fun rmuser user =
+    let
+	val doms = Acl.class {user = user, class = "domain"}
+	val doms = List.filter (fn dom =>
+				   case Acl.whoHas {class = "domain", value = dom} of
+				       [_] => true
+				     | _ => false) (StringSet.listItems doms)
+    in
+	Acl.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
@@ -240,114 +803,342 @@ 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 cmdLoop () =
-			case Msg.recv bio of
-			    NONE => (OpenSSL.close bio
-				     handle OpenSSL.OpenSSL _ => ();
-				     loop ())
-			  | SOME m =>
-			    case m of
-				MsgConfig code =>
-				let
-				    val _ = print "Configuration:\n"
-				    val _ = print code
-				    val _ = print "\n"
+		    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 ())
 
-				    val outname = OS.FileSys.tmpName ()
+		    fun doConfig codes =
+			let
+			    val _ = print "Configuration:\n"
+			    val _ = app (fn s => (print s; print "\n")) codes
+			    val _ = print "\n"
+
+			    val outname = OS.FileSys.tmpName ()
+
+			    fun doOne code =
+				let
 				    val outf = TextIO.openOut outname
 				in
 				    TextIO.output (outf, code);
 				    TextIO.closeOut outf;
-				    (eval outname;
-				     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 ()
+				    eval' outname
 				end
+			in
+			    doIt (fn () => (Env.pre ();
+					    app doOne codes;
+					    Env.post ();
+					    Msg.send (bio, MsgOk);
+					    ("Configuration complete.", NONE)))
+				 (fn () => OS.FileSys.remove outname)
+			end
 
-			      | MsgGrant acl =>
-				if Acl.query {user = user, class = "group", value = "root"} 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 ())
-				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)
+		    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
 				     handle OpenSSL.OpenSSL _ => ();
 				     loop ())
+			  | SOME m =>
+			    case m of
+				MsgConfig code => doConfig [code]
+			      | MsgMultiConfig codes => doConfig codes
 
-			      | MsgRevoke acl =>
-				if Acl.query {user = user, class = "group", value = "root"} 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 ())
+			      | 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 revoke privileges");
-				      print "Unauthorized user asked to revoke 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 =>
+				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 =>
+				doIt (fn () =>
+					 (Msg.send (bio, MsgWhoHasResponse (Acl.whoHas perm));
+					  ("Sent whohas response for " ^ #class perm ^ " / " ^ #value perm ^ ".",
+					   NONE)))
+				     (fn () => ())
+
+			      | 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
+					     (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 =>
+				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' =>
+				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} =>
+				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} =>
+				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
@@ -362,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
@@ -377,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"
@@ -398,6 +1188,8 @@ fun slave () =
 					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
@@ -406,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
@@ -421,7 +1228,7 @@ fun slave () =
 	OpenSSL.shutdown sock
     end
 
-fun autodocBasis outdir =
+fun listBasis () =
     let
 	val dir = Posix.FileSys.opendir Config.libRoot
 
@@ -436,10 +1243,11 @@ fun autodocBasis outdir =
 			  :: files)
 		else
 		    loop files
-
-	val files = loop []
     in
-	Autodoc.autodoc {outdir = outdir, infiles = files}
+	loop []
     end
 
+fun autodocBasis outdir =
+    Autodoc.autodoc {outdir = outdir, infiles = listBasis ()}
+
 end