[hcoop/domtool2.git] / src / main.sml

(* HCoop Domtool (http://hcoop.sourceforge.net/)
 * 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
 * as published by the Free Software Foundation; either version 2
 * of the License, or (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
 *)

(* Main interface *)

structure Main :> MAIN = struct

open Ast MsgTypes Print

structure SM = StringMap

fun init () = Acl.read Config.aclFile

fun isLib fname = OS.Path.file fname = "lib.dtl"

fun wrapFile (fname, file) =
    case (isLib fname, file) of
	(true, (comment, ds, SOME e)) =>
	let
	    val (_, loc) = e
	in
	    (comment, ds, SOME (ELocal (e, (ESkip, loc)), loc))
	end
      | _ => file

fun check' G fname =
    let
	val prog = Parse.parse fname
	val prog = wrapFile (fname, prog)
    in
	if !ErrorMsg.anyErrors then
	    G
	else
	    (if isLib fname then
		 ()
	     else
		 Option.app (Unused.check G) (#3 prog);
	     Tycheck.checkFile G prog)
    end

fun basis () =
    let
	val _ = ErrorMsg.reset ()
	val dir = Posix.FileSys.opendir Config.libRoot

	fun loop files =
	    case Posix.FileSys.readdir dir of
		NONE => (Posix.FileSys.closedir dir;
			 files)
	      | SOME fname =>
		if String.isSuffix ".dtl" fname then
		    loop (OS.Path.joinDirFile {dir = Config.libRoot,
					       file = fname}
			  :: files)
		else
		    loop files

	val files = loop []
	val (_, files) = Order.order NONE files
    in
	if !ErrorMsg.anyErrors then
	    Env.empty
	else
	    (Tycheck.allowExterns ();
	     foldl (fn (fname, G) => check' G fname) Env.empty files
	     before Tycheck.disallowExterns ())
    end

(* val b = basis () *)

fun check G fname =
    let
	val _ = ErrorMsg.reset ()
	val _ = Env.preTycheck ()
    in
	if !ErrorMsg.anyErrors then
	    raise ErrorMsg.Error
	else
	    let
		val _ = Tycheck.disallowExterns ()
		val _ = ErrorMsg.reset ()
		val prog = Parse.parse fname
		val prog = wrapFile (fname, prog)
	    in
		if !ErrorMsg.anyErrors then
		    raise ErrorMsg.Error
		else
		    let
			val G' = Tycheck.checkFile G prog
		    in
			if !ErrorMsg.anyErrors then
			    raise ErrorMsg.Error
			else
			    (if isLib fname then
				 ()
			     else
				 Option.app (Unused.check G) (#3 prog);
			     (G', #3 prog))
		    end
	    end
    end

fun notTmp s =
    String.sub (s, 0) <> #"."
    andalso s <> "_darcs"
    andalso CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"." orelse ch = #"_" orelse ch = #"-") s

fun setupUser () =
    let
	val user =
	    case Posix.ProcEnv.getenv "DOMTOOL_USER" of
		NONE =>
		let
		    val uid = Posix.ProcEnv.getuid ()
		in
		    Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid uid)
		end
	      | SOME user => user
    in
	Acl.read Config.aclFile;
	Domain.setUser user;
	user
    end

fun checkDir' dname =
    let
	val b = basis ()

	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 checkDir dname =
    (setupUser ();
     checkDir' dname)

fun reduce G fname =
    let
	val (G, body) = check G fname
    in
	if !ErrorMsg.anyErrors then
	    (G, NONE)
	else
	    case body of
		SOME body =>
		let
		    val body' = Reduce.reduceExp G body
		in
		    (*printd (PD.hovBox (PD.PPS.Rel 0,
					 [PD.string "Result:",
					  PD.space 1,
					  p_exp body']))*)
		    (G, SOME body')
		end
	      | _ => (G, NONE)
    end

(*(Defaults.eInit ())*)

val toplevel = Env.initialDynEnvVals Reduce.reduceExp

fun eval G evs fname =
    case reduce G fname of
	(G, SOME body') =>
	if !ErrorMsg.anyErrors then
	    raise ErrorMsg.Error
	else
	    let
		val evs' = Eval.exec' (toplevel G, evs) body'
	    in
		(G, evs')
	    end
      | (G, NONE) => (G, evs)

val dispatcher =
    Domain.nodeIp Config.dispatcherName ^ ":" ^ Int.toString Config.dispatcherPort

val self =
    "localhost:" ^ Int.toString Config.slavePort

fun context x =
    (OpenSSL.context false x)
    handle e as OpenSSL.OpenSSL s =>
	   (print "Couldn't find your certificate.\nYou probably haven't been given any Domtool privileges.\n";
	    print ("I looked in: " ^ #1 x ^ "\n");
	    print ("Additional information: " ^ s ^ "\n");
	    raise e)

fun requestContext f =
    let
	val user = setupUser ()
		 
	val () = f ()

	val context = context (Config.certDir ^ "/" ^ user ^ ".pem",
			       Config.keyDir ^ "/" ^ user ^ "/key.pem",
			       Config.trustStore)
    in
	(user, context)
    end

fun requestBio' printErr f =
    let
	val (user, context) = requestContext f
    in
	(user, OpenSSL.connect printErr (context, dispatcher))
    end

val requestBio = requestBio' true

fun requestSlaveBio' printErr =
    let
	val (user, context) = requestContext (fn () => ())
    in
	(user, OpenSSL.connect printErr (context, self))
    end

fun requestSlaveBio () = requestSlaveBio' true

fun request (fname, libOpt) =
    let
	val (user, bio) = requestBio (fn () =>
					 let
					     val env = basis ()
					     val env = case libOpt of
							   NONE => env
							 | SOME lib => #1 (check env lib)
					 in
					     ignore (check env fname)
					 end)

	fun readFile fname =
	    let
		val inf = TextIO.openIn fname

		fun loop lines =
		    case TextIO.inputLine inf of
			NONE => String.concat (rev lines)
		      | SOME line => loop (line :: lines)
	    in
		loop []
		before TextIO.closeIn inf
	    end

	val code = readFile fname
	val msg = case libOpt of
		      NONE => MsgConfig code
		    | SOME fname' => MsgMultiConfig [readFile fname', code]
    in
	Msg.send (bio, msg);
	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 requestDir dname =
    let
	val _ = if Posix.FileSys.access (dname, []) then
		    ()
		else
		    (print ("Can't access " ^ dname ^ ".\n");
		     print "Did you mean to run domtool on a specific file, instead of asking for all\n";
		     print "files in your ~/.domtool directory?\n";
		     OS.Process.exit OS.Process.failure)

	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' false (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 => ()
	  | 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' false
    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 => ()
	  | 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 () => ())
    in
	Msg.send (bio, MsgGrant acl);
	case Msg.recv bio of
	    NONE => print "Server closed connection unexpectedly.\n"
	  | SOME m =>
	    case m of
		MsgOk => print "Grant succeeded.\n"
	      | MsgError s => print ("Grant failed: " ^ s ^ "\n")
	      | _ => print "Unexpected server reply.\n";
	OpenSSL.close bio
    end

fun requestRevoke acl =
    let
	val (user, bio) = requestBio (fn () => ())
    in
	Msg.send (bio, MsgRevoke acl);
	case Msg.recv bio of
	    NONE => print "Server closed connection unexpectedly.\n"
	  | SOME m =>
	    case m of
		MsgOk => print "Revoke succeeded.\n"
	      | MsgError s => print ("Revoke failed: " ^ s ^ "\n")
	      | _ => print "Unexpected server reply.\n";
	OpenSSL.close bio
    end

fun requestListPerms user =
    let
	val (_, bio) = requestBio (fn () => ())
    in
	Msg.send (bio, MsgListPerms user);
	(case Msg.recv bio of
	     NONE => (print "Server closed connection unexpectedly.\n";
		      NONE)
	   | SOME m =>
	     case m of
		 MsgPerms perms => SOME perms
	       | MsgError s => (print ("Listing failed: " ^ s ^ "\n");
				NONE)
	       | _ => (print "Unexpected server reply.\n";
		       NONE))
	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 requestRegenTc () =
    let
	val (_, bio) = requestBio (fn () => ())
    in
	Msg.send (bio, MsgRegenerateTc);
	case Msg.recv bio of
	    NONE => print "Server closed connection unexpectedly.\n"
	  | SOME m =>
	    case m of
		MsgOk => print "All configuration validated.\n"
	      | MsgError s => print ("Configuration validation 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 (_, 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
	    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 (_, 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
	    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, 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
	    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 requestDbDrop p =
    let
	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
	    NONE => print "Server closed connection unexpectedly.\n"
	  | SOME m =>
	    case m of
		MsgOk => print ("Your database " ^ user ^ "_" ^ #dbname p ^ " has been dropped.\n")
	      | MsgError s => print ("Drop failed: " ^ s ^ "\n")
	      | _ => print "Unexpected server reply.\n";
	OpenSSL.close bio
    end

fun requestDbGrant p =
    let
	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
	    NONE => print "Server closed connection unexpectedly.\n"
	  | SOME m =>
	    case m of
		MsgOk => print ("You've been granted all allowed privileges to database " ^ user ^ "_" ^ #dbname p ^ ".\n")
	      | MsgError s => print ("Grant 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 ("Listing 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 requestPortalPasswdMailbox p =
    let
	val (_, bio) = requestBio (fn () => ())
    in
	(Msg.send (bio, MsgPortalPasswdMailbox p);
	 case Msg.recv bio of
	     NONE => (print "Server closed connection unexpectedly.\n"; OS.Process.failure)
	   | SOME m =>
	     case m of
		 MsgOk => (print ("The password for " ^ #user p ^ "@" ^ #domain p ^ " has been changed.\n");
			   OS.Process.success)
	       | MsgError s => (print ("Set failed: " ^ s ^ "\n"); OS.Process.failure)
	       | _ => (print "Unexpected server reply.\n"; OS.Process.failure))
	before 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 requestMysqlFixperms () =
    let
	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
	    NONE => print "Server closed connection unexpectedly.\n"
	  | SOME m =>
	    case m of
		MsgOk => print "Permissions granted.\n"
	      | MsgError s => print ("Failed: " ^ s ^ "\n")
	      | _ => print "Unexpected server reply.\n";
	OpenSSL.close bio
    end

fun requestApt {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 (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 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.dispatcherName 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 true (context, if node = Config.dispatcherName 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 requestTrustedPath {node, uname} =
    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 (QTrustedPath 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 trusted path restriction.\n";
			       OS.Process.success)
		  | MsgNo => (print "User does not have trusted path restriction.\n";
			      OS.Process.failure)
		  | MsgError s => (print ("Trusted path query failed: " ^ s ^ "\n");
				   OS.Process.failure)
		  | _ => (print "Unexpected server reply.\n";
			  OS.Process.failure)
    in
	loop ()
	before OpenSSL.close bio
    end

fun requestSocketPerm {node, uname} =
    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 (QSocket uname))

	fun loop () =
	    case Msg.recv bio of
		NONE => (print "Server closed connection unexpectedly.\n";
			 OS.Process.failure)
	      | SOME m =>
		case m of
		    MsgSocket p => (case p of
					Any => print "Any\n"
				      | Client => print "Client\n"
				      | Server => print "Server\n"
				      | Nada => print "Nada\n";
				    OS.Process.success)
		  | MsgError s => (print ("Socket permission query failed: " ^ s ^ "\n");
				   OS.Process.failure)
		  | _ => (print "Unexpected server reply.\n";
			  OS.Process.failure)
    in
	loop ()
	before OpenSSL.close bio
    end

fun requestFirewall {node, uname} =
    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 (QFirewall {node = node, user = uname}))

	fun loop () =
	    case Msg.recv bio of
		NONE => (print "Server closed connection unexpectedly.\n";
			 OS.Process.failure)
	      | SOME m =>
		case m of
		    MsgFirewall ls => (app (fn s => (print s; print "\n")) ls;
				       OS.Process.success)
		  | MsgError s => (print ("Firewall query failed: " ^ s ^ "\n");
				   OS.Process.failure)
		  | _ => (print "Unexpected server reply.\n";
			  OS.Process.failure)
    in
	loop ()
	before OpenSSL.close bio
    end

fun requestDescribe dom =
    let
	val (_, bio) = requestBio (fn () => ())
    in
	Msg.send (bio, MsgDescribe dom);
	case Msg.recv bio of
	    NONE => print "Server closed connection unexpectedly.\n"
	  | SOME m =>
	    case m of
		MsgDescription s => print s
	      | MsgError s => print ("Description failed: " ^ s ^ "\n")
	      | _ => print "Unexpected server reply.\n";
	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 =
    let
	val dir = Posix.FileSys.opendir dname

	fun visitNode dset =
	    case Posix.FileSys.readdir dir of
		NONE => dset
	      | SOME node =>
		let
		    val path = OS.Path.joinDirFile {dir = dname,
						    file = node}

		    fun visitDomains (path, bfor, dset) =
			let
			    val dir = Posix.FileSys.opendir path

			    fun loop dset =
				case Posix.FileSys.readdir dir of
				    NONE => dset
				  | SOME dname =>
				    let
					val path = OS.Path.joinDirFile {dir = path,
									file = dname}
				    in
					if Posix.FileSys.ST.isDir (Posix.FileSys.stat path) then
					    let
						val bfor = dname :: bfor
					    in
						loop (visitDomains (path, bfor,
								    SS.add (dset,
									    String.concatWith "." bfor)))
					    end
					else
					    loop dset
				    end
			in
			    loop dset
			    before Posix.FileSys.closedir dir
			end
		in
		    visitNode (visitDomains (path, [], dset))
		end
    in
	visitNode SS.empty
	before Posix.FileSys.closedir dir
    end

fun regenerateEither tc checker context =
    let
	val () = print "Starting regeneration....\n"

	val domainsBefore =
	    if tc then
		SS.empty
	    else
		domainList Config.resultRoot

	fun ifReal f =
	    if tc then
		()
	    else
		f ()

	val _ = ErrorMsg.reset ()

	val b = basis ()
	val () = Tycheck.disallowExterns ()

	val () = ifReal (fn () =>
			    (ignore (OS.Process.system ("rm -rf " ^ Config.oldResultRoot ^ "/*"));
			     ignore (OS.Process.system ("cp -r " ^ Config.resultRoot
							^ "/* " ^ Config.oldResultRoot ^ "/"));
			     Domain.resetGlobal ()))

	val ok = ref true
 
	fun contactNode (node, ip) =
	    if node = Config.dispatcherName then
		Domain.resetLocal ()
	    else let
		    val bio = OpenSSL.connect true (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
		 handle OpenSSL.OpenSSL s => print ("OpenSSL error: " ^ s ^ "\n")

	fun doUser user =
	    let
		val _ = Domain.setUser user
		val _ = ErrorMsg.reset ()

		val dname = Config.domtoolDir user
	    in
		if Posix.FileSys.access (dname, []) then
		    let
			val dir = Posix.FileSys.opendir dname

			fun loop files =
			    case Posix.FileSys.readdir dir of
				NONE => (Posix.FileSys.closedir dir;
					 files)
			      | SOME fname =>
				if notTmp fname then
				    loop (OS.Path.joinDirFile {dir = dname,
							       file = fname}
					  :: files)
				else
				    loop files

			val files = loop []
			val (_, files) = Order.order (SOME b) files

			fun checker' (file, (G, evs)) =
			    checker G evs file
		    in
			if !ErrorMsg.anyErrors then
			    (ErrorMsg.reset ();
			     print ("User " ^ user ^ "'s configuration has errors!\n");
			     ok := false)
			else
			    ();
			let val basis' = basis () in
			    ignore (foldl checker' (basis', SM.empty) files)
			end
		    end
		else if (String.isSuffix "_admin" user) orelse (String.isSuffix ".daemon" user) then
		    ()    
		else
		    (print ("Couldn't access " ^ user ^ "'s ~/.domtool directory.\n");
		     ok := false)
	    end
	    handle IO.Io {name, function, ...} =>
		   (print ("IO error processing user " ^ user ^ ": " ^ function ^ ": " ^ name ^ "\n");
		    ok := false)
		 | exn as OS.SysErr (s, _) => (print ("System error processing user " ^ user ^ ": " ^ s ^ "\n");
					       ok := false)
		 | ErrorMsg.Error => (ErrorMsg.reset ();
				      print ("User " ^ user ^ " had a compilation error.\n");
				      ok := false)
		 | _ => (print "Unknown exception during regeneration!\n";
			 ok := false)
    in
	ifReal (fn () => (app contactNode Config.nodeIps;
			  Env.pre ()));
	app doUser (Acl.users ());
	ifReal (fn () =>
		   let
		       val domainsAfter = domainList Config.resultRoot
		       val domainsGone = SS.difference (domainsBefore, domainsAfter)
		   in
		       if SS.isEmpty domainsGone then
			   ()
		       else
			   (print "Domains to kill:";
			    SS.app (fn s => (print " "; print s)) domainsGone;
			    print "\n";

			    Domain.rmdom' Config.oldResultRoot (SS.listItems domainsGone));
		       
		       Env.post ()
		   end);
	!ok
    end

val regenerate = regenerateEither false eval
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"}
	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;
	usersChanged ()
    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
      | 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 {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 {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
	val host = Slave.hostname ()

	val () = Acl.read Config.aclFile

	val context = context (Config.certDir ^ "/" ^ host ^ ".pem",
			       Config.keyDir ^ "/" ^ host ^ "/key.pem",
			       Config.trustStore)
	val _ = Domain.set_context context

	val sock = OpenSSL.listen (context, Config.dispatcherPort)

	fun loop () =
	    (case OpenSSL.accept sock of
		 NONE => ()
	       | SOME bio =>
		 let
		     val user = OpenSSL.peerCN bio
		     val () = print ("\nConnection from " ^ user ^ " at " ^ now () ^ "\n")
		     val () = Domain.setUser user
		     val doIt = doIt' loop bio

		     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, (G, evs)) =
				 let
				     val outf = TextIO.openOut outname
				 in
				     TextIO.output (outf, code);
				     TextIO.closeOut outf;
				     eval G evs outname
				 end
			 in
			     doIt (fn () => (Env.pre ();
					     let val basis' = basis () in
						 ignore (foldl doOne (basis', SM.empty) codes)
					     end;
					     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
				      handle OpenSSL.OpenSSL _ => ();
				      loop ())
			   | SOME m =>
			     case m of
				 MsgConfig code => doConfig [code]
			       | MsgMultiConfig codes => doConfig codes

			       | 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
				     (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;
					       if #class acl = "user" then
						   usersChanged ()
					       else
						   ();
					       ("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 =>
				 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 => Domain.validDomain dom
									andalso Acl.queryDomain {user = user, domain = 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
					      (if regenerate context then
						   ("Regenerated all configuration.",
						    NONE)
					       else
						   ("Error regenerating configuration!",
						    SOME "Error regenerating configuration!  Consult /var/log/domtool.log."))
					  else
					      ("Unauthorized user asked to regenerate!",
					       SOME "Not authorized to regenerate"))
				      (fn () => ())

			       | MsgRegenerateTc =>
				 doIt (fn () =>
					  if Acl.query {user = user, class = "priv", value = "regen"}
					     orelse Acl.query {user = user, class = "priv", value = "all"} then
					      (if regenerateTc context then
						   ("Checked all configuration.",
						    NONE)
					       else
						   ("Found a compilation error!",
						    SOME "Found a compilation error!  Consult /var/log/domtool.log."))
					  else
					      ("Unauthorized user asked to regenerate -tc!",
					       SOME "Not authorized to regenerate -tc"))
				      (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 () => ())

			       | 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. ("
						     ^ mailbox ^ ")"))
					  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 () => ())

			       | MsgPortalPasswdMailbox {domain, user = emailUser, oldpasswd, newpasswd} =>
				 doIt (fn () =>
					  if not (Acl.query {user = user, class = "priv", value = "vmail"}) then
						 ("User is not authorized to run portal vmail password",
					       SOME "You're not authorized to use the portal password command")
					  else if not (Domain.validEmailUser emailUser) then
					      ("Invalid e-mail username " ^ emailUser,
					       SOME "Invalid e-mail username")
					  else if not (CharVector.all Char.isGraph oldpasswd
						      andalso CharVector.all Char.isGraph newpasswd) then
					      ("Invalid password",
					       SOME "Invalid password; may only contain printable, non-space characters")
					  else
					      case Vmail.portalpasswd {domain = domain, user = emailUser,
								       oldpasswd = oldpasswd, newpasswd = newpasswd} 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);
							     SetSA.rebuild ();
							     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 () => ())
			       | MsgDescribe dom =>
				 doIt (fn () => if not (Domain.validDomain dom) then
						    ("Requested description of invalid domain " ^ dom,
						     SOME "Invalid domain name")
						else if not (Domain.yourDomain dom
							     orelse Acl.query {user = user, class = "priv", value = "all"}) then
						    ("Requested description of " ^ dom ^ ", but not allowed access",
						     SOME "Access denied")
						else
						    (Msg.send (bio, MsgDescription (Domain.describe dom));
						     ("Sent description of domain " ^ dom,
						      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"))
				      (fn () => ())
		 in
		     cmdLoop ()
		 end
		 handle e as (OpenSSL.OpenSSL s) =>
			(print ("OpenSSL error: " ^ s ^ "\n");
			 app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);
			 OpenSSL.close bio
			 handle OpenSSL.OpenSSL _ => ();
			 loop ())
		      | OS.SysErr (s, _) =>
			(print ("System error: " ^ s ^ "\n");
			 OpenSSL.close bio
			 handle OpenSSL.OpenSSL _ => ();
			 loop ())
		      | IO.Io {name, function, cause} =>
			(print ("IO error: " ^ function ^ " for " ^ name ^ "\n");
			 app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory cause);
			 OpenSSL.close bio
			 handle OpenSSL.OpenSSL _ => ();
			 loop ())
		      | OS.Path.InvalidArc =>
			(print "Invalid arc\n";
			 OpenSSL.close bio
			 handle OpenSSL.OpenSSL _ => ();
			 loop ())
		      | e =>
			(print "Unknown exception in main loop!\n";
			 app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);
			 OpenSSL.close bio
			 handle OpenSSL.OpenSSL _ => ();
			 loop ()))
	    handle e as (OpenSSL.OpenSSL s) =>
		   (print ("OpenSSL error: " ^ s ^ "\n");
		    app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);
		    loop ())
		 | OS.SysErr (s, _) =>
		   (print ("System error: " ^ s ^ "\n");
		    loop ())
		 | IO.Io {name, function, cause} =>
		   (print ("IO error: " ^ function ^ " for " ^ name ^ "\n");
		    app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory cause);
		    loop ())
		 | e =>
		   (print "Unknown exception in main loop!\n";
		    app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);
		    loop ())
    in
	print ("Domtool dispatcher starting up at " ^ now () ^ "\n");
	print "Listening for connections....\n";
	loop ();
	OpenSSL.shutdown sock
    end

fun slave () =
    let
	val host = Slave.hostname ()

	val context = context (Config.certDir ^ "/" ^ host ^ ".pem",
			       Config.keyDir ^ "/" ^ host ^ "/key.pem",
			       Config.trustStore)

	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 ^ " 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 ())
			       | 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
    end

fun listBasis () =
    let
	val dir = Posix.FileSys.opendir Config.libRoot

	fun loop files =
	    case Posix.FileSys.readdir dir of
		NONE => (Posix.FileSys.closedir dir;
			 files)
	      | SOME fname =>
		if String.isSuffix ".dtl" fname then
		    loop (OS.Path.joinDirFile {dir = Config.libRoot,
					       file = fname}
			  :: files)
		else
		    loop files
    in
	loop []
    end

fun autodocBasis outdir =
    Autodoc.autodoc {outdir = outdir, infiles = listBasis ()}

end