Adding domain description

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

(* HCoop Domtool (http://hcoop.sourceforge.net/)
 * Copyright (c) 2006-2007, Adam Chlipala
 *
 * 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 check' G fname =
    let
	val prog = Parse.parse fname
    in
	if !ErrorMsg.anyErrors then
	    G
	else
	    Tycheck.checkFile G (Defaults.tInit ()) prog
    end

fun basis () =
    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

	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

fun check fname =
    let
	val _ = ErrorMsg.reset ()
	val _ = Env.preTycheck ()

	val b = basis ()
    in
	if !ErrorMsg.anyErrors then
	    raise ErrorMsg.Error
	else
	    let
		val _ = Tycheck.disallowExterns ()
		val _ = ErrorMsg.reset ()
		val prog = Parse.parse fname
	    in
		if !ErrorMsg.anyErrors then
		    raise ErrorMsg.Error
		else
		    let
			val G' = Tycheck.checkFile b (Defaults.tInit ()) prog
		    in
			if !ErrorMsg.anyErrors then
			    raise ErrorMsg.Error
			else
			    (G', #3 prog)
		    end
	    end
    end

fun notTmp s =
    String.sub (s, 0) <> #"."
    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 fname =
    let
	val (G, body) = check fname
    in
	if !ErrorMsg.anyErrors then
	    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']))*)
		    SOME body'
		end
	      | _ => NONE
    end

fun eval fname =
    case reduce fname of
	(SOME body') =>
	if !ErrorMsg.anyErrors then
	    raise ErrorMsg.Error
	else
	    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 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 f =
    let
	val (user, context) = requestContext f
    in
	(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))

	val inf = TextIO.openIn fname

	fun loop lines =
	    case TextIO.inputLine inf of
		NONE => String.concat (List.rev lines)
	      | SOME line => loop (line :: lines)

	val code = loop []
    in
	TextIO.closeIn inf;
	Msg.send (bio, MsgConfig code);
	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 (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 () => ())
    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 (_, 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, 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, bio) = requestBio (fn () => ())
    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, bio) = requestBio (fn () => ())
    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 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 (_, bio) = requestBio (fn () => ())
    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 (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 requestTrustedPath {node, uname} =
    let
	val (user, context) = requestContext (fn () => ())
	val bio = OpenSSL.connect (context, if node = Config.masterNode then
						dispatcher
					    else
						Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)

	val _ = 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 (context, if node = Config.masterNode 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 (context, if node = Config.masterNode then
						dispatcher
					    else
						Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)

	val _ = Msg.send (bio, MsgQuery (QFirewall 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 ("Describe failed: " ^ s ^ "\n")
	      | _ => print "Unexpected server reply.\n";
	OpenSSL.close bio
    end

fun regenerateEither tc checker context =
    let
	fun ifReal f =
	    if tc then
		()
	    else
		f ()

	val _ = ErrorMsg.reset ()

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

	val () = ifReal Domain.resetGlobal

	val ok = ref true
 
	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
		 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
		    in
			if !ErrorMsg.anyErrors then
			    (ErrorMsg.reset ();
			     print ("User " ^ user ^ "'s configuration has errors!\n"))
			else
			    app checker files
		    end
		else
		    ()
	    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 Env.post;
	!ok
    end

val regenerate = regenerateEither false eval'
val regenerateTc = regenerateEither true (ignore o check)

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
      | QTrustedPath user => if TrustedPath.query user then MsgYes else MsgNo
      | QSocket user => MsgSocket (SocketPerm.query user)
      | QFirewall user => MsgFirewall (Firewall.query user)

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
      | QTrustedPath user => "Asked about trusted path settings for user " ^ user
      | QSocket user => "Asked about socket permissions for user " ^ user
      | QFirewall user => "Asked about firewall rules for user " ^ user

fun service () =
    let
	val () = Acl.read Config.aclFile
	
	val context = context (Config.serverCert,
			       Config.serverKey,
			       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

		     fun doIt f cleanup =
			 ((case f () of
			       (msgLocal, SOME msgRemote) => 
			       (print msgLocal;
				print "\n";
				Msg.send (bio, MsgError msgRemote))
			     | (msgLocal, NONE) =>
			       (print msgLocal;
				print "\n";
				Msg.send (bio, MsgOk)))
			  handle e as (OpenSSL.OpenSSL s) =>
				 (print ("OpenSSL error: " ^ s ^ "\n");
				  app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);
				  Msg.send (bio, MsgError ("OpenSSL error: " ^ s))
				  handle OpenSSL.OpenSSL _ => ())
			       | OS.SysErr (s, _) =>
				 (print "System error: ";
				  print s;
				  print "\n";
				  Msg.send (bio, MsgError ("System error: " ^ s))
				  handle OpenSSL.OpenSSL _ => ())
			       | Fail s =>
				 (print "Failure: ";
				  print s;
				  print "\n";
				  Msg.send (bio, MsgError ("Failure: " ^ s))
				  handle OpenSSL.OpenSSL _ => ())
			       | ErrorMsg.Error =>
				 (print "Compilation error\n";
				  Msg.send (bio, MsgError "Error during configuration evaluation")
				  handle OpenSSL.OpenSSL _ => ());
                          (cleanup ();
			   ignore (OpenSSL.readChar bio);
			   OpenSSL.close bio)
			  handle OpenSSL.OpenSSL _ => ();
			  loop ())

		     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
				 end
			 in
			     doIt (fn () => (Env.pre ();
					     app doOne codes;
					     Env.post ();
					     Msg.send (bio, MsgOk);
					     ("Configuration complete.", NONE)))
				  (fn () => OS.FileSys.remove outname)
			 end

		     fun checkAddr s =
			 case String.fields (fn ch => ch = #"@") s of
			     [user'] =>
			     if user = user' then
				 SOME (SetSA.User s)
			     else
				 NONE
			   | [user', domain] =>
			     if Domain.validEmailUser user' andalso Domain.yourDomain domain then
				 SOME (SetSA.Email s)
			     else
				 NONE
			   | _ => NONE

		     fun cmdLoop () =
			 case Msg.recv bio of
			     NONE => (OpenSSL.close bio
				      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;
					       ("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 => 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
					      (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 () => ())

			       | MsgCreateDbUser {dbtype, passwd} =>
				 doIt (fn () =>
					  case Dbms.lookup dbtype of
					      NONE => ("Database user creation request with unknown datatype type " ^ dbtype,
						       SOME ("Unknown database type " ^ dbtype))
					    | SOME handler =>
					      case #adduser handler {user = user, passwd = passwd} of
						  NONE => ("Added " ^ dbtype ^ " user " ^ user ^ ".",
							   NONE)
						| SOME msg =>
						  ("Error adding a " ^ dbtype ^ " user " ^ user ^ ": " ^ msg,
						   SOME ("Error adding user: " ^ msg)))
				      (fn () => ())

			       | MsgDbPasswd {dbtype, passwd} =>
				 doIt (fn () =>
					  case Dbms.lookup dbtype of
					      NONE => ("Database passwd request with unknown datatype type " ^ dbtype,
						       SOME ("Unknown database type " ^ dbtype))
					    | SOME handler =>
					      case #passwd handler {user = user, passwd = passwd} of
						  NONE => ("Changed " ^ dbtype ^ " password of user " ^ user ^ ".",
							   NONE)
						| SOME msg =>
						  ("Error setting " ^ dbtype ^ " password of user " ^ user ^ ": " ^ msg,
						   SOME ("Error adding user: " ^ msg)))
				      (fn () => ())

			       | MsgCreateDb {dbtype, dbname} =>
				 doIt (fn () =>
					  if Dbms.validDbname dbname then
					      case Dbms.lookup dbtype of
						  NONE => ("Database creation request with unknown datatype type " ^ dbtype,
							   SOME ("Unknown database type " ^ dbtype))
						| SOME handler =>
						  case #createdb handler {user = user, dbname = dbname} of
						      NONE => ("Created database " ^ user ^ "_" ^ dbname ^ ".",
							       NONE)
						    | SOME msg => ("Error creating database " ^ user ^ "_" ^ dbname ^ ": " ^ msg,
								   SOME ("Error creating database: " ^ msg))
					  else
					      ("Invalid database name " ^ user ^ "_" ^ dbname,
					       SOME ("Invalid database name " ^ dbname)))
				      (fn () => ())

			       | MsgDropDb {dbtype, dbname} =>
				 doIt (fn () =>
					  if Dbms.validDbname dbname then
					      case Dbms.lookup dbtype of
						  NONE => ("Database drop request with unknown datatype type " ^ dbtype,
							   SOME ("Unknown database type " ^ dbtype))
						| SOME handler =>
						  case #dropdb handler {user = user, dbname = dbname} of
						      NONE => ("Drop database " ^ user ^ "_" ^ dbname ^ ".",
							       NONE)
						    | SOME msg => ("Error dropping database " ^ user ^ "_" ^ dbname ^ ": " ^ msg,
								   SOME ("Error dropping database: " ^ msg))
					  else
					      ("Invalid database name " ^ user ^ "_" ^ dbname,
					       SOME ("Invalid database name " ^ dbname)))
				      (fn () => ())

			       | MsgGrantDb {dbtype, dbname} =>
				 doIt (fn () =>
					  if Dbms.validDbname dbname then
					      case Dbms.lookup dbtype of
						  NONE => ("Database drop request with unknown datatype type " ^ dbtype,
							   SOME ("Unknown database type " ^ dbtype))
						| SOME handler =>
						  case #grant handler {user = user, dbname = dbname} of
						      NONE => ("Grant permissions to database " ^ user ^ "_" ^ dbname ^ ".",
							       NONE)
						    | SOME msg => ("Error granting permissions to database " ^ user ^ "_" ^ dbname ^ ": " ^ msg,
								   SOME ("Error granting permissions to database: " ^ msg))
					  else
					      ("Invalid database name " ^ user ^ "_" ^ dbname,
					       SOME ("Invalid database name " ^ dbname)))
				      (fn () => ())

			       | MsgListMailboxes domain =>
				 doIt (fn () =>
					  if not (Domain.yourDomain domain) then
					      ("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 () => ())

			       | 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 () => ())

			       | MsgMysqlFixperms =>
				 doIt (fn () => if OS.Process.isSuccess
						       (OS.Process.system "/usr/bin/sudo -H /afs/hcoop.net/common/etc/scripts/mysql-grant-table-drop") then
						    ("Requested mysql-fixperms",
						     NONE)
						 else
						     ("Requested mysql-fixperms, but execution failed!",
						      SOME "Script execution failed."))
				      (fn () => ())

			       | MsgDescribe dom =>
				 doIt (fn () => (if Domain.validDomain dom then
						     (Msg.send (bio, MsgDescription (Domain.describe dom));
						      ("Requested description of domain " ^ dom,
						       NONE))
						 else
						     ("Requested description of invalid domain " ^ dom,
						      SOME "Invalid domain name")))
				      (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))
				      | _ => (print "Dispatcher sent unexpected command\n";
					      Msg.send (bio, MsgError "Unexpected command"))
			in
			    loop' [];
			    ignore (OpenSSL.readChar bio);
			    OpenSSL.close bio;
			    loop ()
			end
		    else if peer = "domtool" then
			case Msg.recv bio of
			    SOME MsgShutdown => (OpenSSL.close bio;
						 print ("Shutting down at " ^ now () ^ "\n\n"))
			  | _ => (OpenSSL.close bio;
				  loop ())
		    else
			case Msg.recv bio of
			    SOME (MsgQuery q) => (print (describeQuery q ^ "\n");
						  Msg.send (bio, answerQuery q);
						  ignore (OpenSSL.readChar bio);
						  OpenSSL.close bio;
						  loop ())
			  | _ => (OpenSSL.close bio;
				  loop ())
		end handle OpenSSL.OpenSSL s =>
			   (print ("OpenSSL error: "^ s ^ "\n");
			    OpenSSL.close bio
					  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 ())
    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