Socket permission querying

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

(* HCoop Domtool (http://hcoop.sourceforge.net/)
 * Copyright (c) 2006, 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

val notTmp = CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"." orelse ch = #"_" orelse ch = #"-")

fun checkDir dname =
    let
	val b = basis ()

	val dir = Posix.FileSys.opendir dname

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

	val files = loop []
	val (_, files) = Order.order (SOME b) files
    in
	if !ErrorMsg.anyErrors then
	    raise ErrorMsg.Error
	else
	    (foldl (fn (fname, G) => check' G fname) b files;
	     if !ErrorMsg.anyErrors then
		 raise ErrorMsg.Error
	     else
		 ())
    end

fun reduce fname =
    let
	val (G, body) = check fname
    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 requestContext f =
    let
	val uid = Posix.ProcEnv.getuid ()
	val user = Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid uid)
		   
	val () = Acl.read Config.aclFile
	val () = Domain.setUser user
		 
	val () = f ()

	val context = OpenSSL.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 _ = 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 requestRmdom dom =
    let
	val (_, bio) = requestBio (fn () => ())
    in
	Msg.send (bio, MsgRmdom dom);
	case Msg.recv bio of
	    NONE => print "Server closed connection unexpectedly.\n"
	  | SOME m =>
	    case m of
		MsgOk => print "Removal succeeded.\n"
	      | MsgError s => print ("Removal failed: " ^ s ^ "\n")
	      | _ => print "Unexpected server reply.\n";
	OpenSSL.close bio
    end

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

fun requestDbUser dbtype =
    let
	val (_, bio) = requestBio (fn () => ())
    in
	Msg.send (bio, MsgCreateDbUser dbtype);
	case Msg.recv bio of
	    NONE => print "Server closed connection unexpectedly.\n"
	  | SOME m =>
	    case m of
		MsgOk => print "Your user has been created.\n"
	      | MsgError s => print ("Creation failed: " ^ s ^ "\n")
	      | _ => print "Unexpected server reply.\n";
	OpenSSL.close bio
    end

fun requestDbPasswd rc =
    let
	val (_, bio) = requestBio (fn () => ())
    in
	Msg.send (bio, MsgDbPasswd rc);
	case Msg.recv bio of
	    NONE => print "Server closed connection unexpectedly.\n"
	  | SOME m =>
	    case m of
		MsgOk => print "Your password has been changed.\n"
	      | MsgError s => print ("Password set failed: " ^ s ^ "\n")
	      | _ => print "Unexpected server reply.\n";
	OpenSSL.close bio
    end

fun requestDbTable p =
    let
	val (user, bio) = requestBio (fn () => ())
    in
	Msg.send (bio, MsgCreateDbTable p);
	case Msg.recv bio of
	    NONE => print "Server closed connection unexpectedly.\n"
	  | SOME m =>
	    case m of
		MsgOk => print ("Your database " ^ user ^ "_" ^ #dbname p ^ " has been created.\n")
	      | MsgError s => print ("Creation failed: " ^ s ^ "\n")
	      | _ => print "Unexpected server reply.\n";
	OpenSSL.close bio
    end

fun requestListMailboxes domain =
    let
	val (_, bio) = requestBio (fn () => ())
    in
	Msg.send (bio, MsgListMailboxes domain);
	(case Msg.recv bio of
	     NONE => Vmail.Error "Server closed connection unexpectedly."
	   | SOME m =>
	     case m of
		 MsgMailboxes users => (Msg.send (bio, MsgOk);
					Vmail.Listing users)
	       | MsgError s => Vmail.Error ("Creation failed: " ^ s)
	       | _ => Vmail.Error "Unexpected server reply.")
	before OpenSSL.close bio
    end

fun requestNewMailbox p =
    let
	val (_, bio) = requestBio (fn () => ())
    in
	Msg.send (bio, MsgNewMailbox p);
	case Msg.recv bio of
	    NONE => print "Server closed connection unexpectedly.\n"
	  | SOME m =>
	    case m of
		MsgOk => print ("A mapping for " ^ #user p ^ "@" ^ #domain p ^ " has been created.\n")
	      | MsgError s => print ("Creation failed: " ^ s ^ "\n")
	      | _ => print "Unexpected server reply.\n";
	OpenSSL.close bio
    end

fun requestPasswdMailbox p =
    let
	val (_, bio) = requestBio (fn () => ())
    in
	Msg.send (bio, MsgPasswdMailbox p);
	case Msg.recv bio of
	    NONE => print "Server closed connection unexpectedly.\n"
	  | SOME m =>
	    case m of
		MsgOk => print ("The password for " ^ #user p ^ "@" ^ #domain p ^ " has been changed.\n")
	      | MsgError s => print ("Set failed: " ^ s ^ "\n")
	      | _ => print "Unexpected server reply.\n";
	OpenSSL.close bio
    end

fun requestRmMailbox p =
    let
	val (_, bio) = requestBio (fn () => ())
    in
	Msg.send (bio, MsgRmMailbox p);
	case Msg.recv bio of
	    NONE => print "Server closed connection unexpectedly.\n"
	  | SOME m =>
	    case m of
		MsgOk => print ("The mapping for mailbox " ^ #user p ^ "@" ^ #domain p ^ " has been deleted.\n")
	      | MsgError s => print ("Remove failed: " ^ s ^ "\n")
	      | _ => print "Unexpected server reply.\n";
	OpenSSL.close bio
    end

fun requestSaQuery addr =
    let
	val (_, bio) = requestBio (fn () => ())
    in
	Msg.send (bio, MsgSaQuery addr);
	(case Msg.recv bio of
	     NONE => print "Server closed connection unexpectedly.\n"
	   | SOME m =>
	     case m of
		 MsgSaStatus b => (print ("SpamAssassin filtering for " ^ addr ^ " is "
					  ^ (if b then "ON" else "OFF") ^ ".\n");
				   Msg.send (bio, MsgOk))
	       | MsgError s => print ("Query failed: " ^ s ^ "\n")
	       | _ => print "Unexpected server reply.\n")
	before OpenSSL.close bio
    end

fun requestSaSet p =
    let
	val (_, bio) = requestBio (fn () => ())
    in
	Msg.send (bio, MsgSaSet p);
	case Msg.recv bio of
	    NONE => print "Server closed connection unexpectedly.\n"
	  | SOME m =>
	    case m of
		MsgOk => print ("SpamAssassin filtering for " ^ #1 p ^ " is now "
				^ (if #2 p then "ON" else "OFF") ^ ".\n")
	      | MsgError s => print ("Set failed: " ^ s ^ "\n")
	      | _ => print "Unexpected server reply.\n";
	OpenSSL.close bio
    end

fun requestSmtpLog domain =
    let
	val (_, bio) = requestBio (fn () => ())

	val _ = Msg.send (bio, MsgSmtpLogReq domain)

	fun loop () =
	    case Msg.recv bio of
		NONE => print "Server closed connection unexpectedly.\n"
	      | SOME m =>
		case m of
		    MsgOk => ()
		  | MsgSmtpLogRes line => (print line;
					   loop ())
		  | MsgError s => print ("Log search failed: " ^ s ^ "\n")
		  | _ => print "Unexpected server reply.\n"
    in
	loop ();
	OpenSSL.close bio
    end

fun requestApt {node, pkg} =
    let
	val (user, context) = requestContext (fn () => ())
	val bio = OpenSSL.connect (context, if node = Config.masterNode then
						dispatcher
					    else
						Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)

	val _ = Msg.send (bio, MsgQuery (QApt pkg))

	fun loop () =
	    case Msg.recv bio of
		NONE => (print "Server closed connection unexpectedly.\n";
			 OS.Process.failure)
	      | SOME m =>
		case m of
		    MsgYes => (print "Package is installed.\n";
			       OS.Process.success)
		  | MsgNo => (print "Package is not installed.\n";
			      OS.Process.failure)
		  | MsgError s => (print ("APT query failed: " ^ s ^ "\n");
				   OS.Process.failure)
		  | _ => (print "Unexpected server reply.\n";
			  OS.Process.failure)
    in
	loop ()
	before OpenSSL.close bio
    end

fun requestCron {node, uname} =
    let
	val (user, context) = requestContext (fn () => ())
	val bio = OpenSSL.connect (context, if node = Config.masterNode then
						dispatcher
					    else
						Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)

	val _ = Msg.send (bio, MsgQuery (QCron uname))

	fun loop () =
	    case Msg.recv bio of
		NONE => (print "Server closed connection unexpectedly.\n";
			 OS.Process.failure)
	      | SOME m =>
		case m of
		    MsgYes => (print "User has cron permissions.\n";
			       OS.Process.success)
		  | MsgNo => (print "User does not have cron permissions.\n";
			      OS.Process.failure)
		  | MsgError s => (print ("Cron query failed: " ^ s ^ "\n");
				   OS.Process.failure)
		  | _ => (print "Unexpected server reply.\n";
			  OS.Process.failure)
    in
	loop ()
	before OpenSSL.close bio
    end

fun requestFtp {node, uname} =
    let
	val (user, context) = requestContext (fn () => ())
	val bio = OpenSSL.connect (context, if node = Config.masterNode then
						dispatcher
					    else
						Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)

	val _ = Msg.send (bio, MsgQuery (QFtp uname))

	fun loop () =
	    case Msg.recv bio of
		NONE => (print "Server closed connection unexpectedly.\n";
			 OS.Process.failure)
	      | SOME m =>
		case m of
		    MsgYes => (print "User has FTP permissions.\n";
			       OS.Process.success)
		  | MsgNo => (print "User does not have FTP permissions.\n";
			      OS.Process.failure)
		  | MsgError s => (print ("FTP query failed: " ^ s ^ "\n");
				   OS.Process.failure)
		  | _ => (print "Unexpected server reply.\n";
			  OS.Process.failure)
    in
	loop ()
	before OpenSSL.close bio
    end

fun 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 regenerate context =
    let
	val b = basis ()
	val () = Tycheck.disallowExterns ()

	val () = Domain.resetGlobal ()

	fun contactNode (node, ip) =
	    if node = Config.defaultNode then
		Domain.resetLocal ()
	    else let
		    val bio = OpenSSL.connect (context,
					       ip
					       ^ ":"
					       ^ Int.toString Config.slavePort)
		in
		    Msg.send (bio, MsgRegenerate);
		    case Msg.recv bio of
			NONE => print "Slave closed connection unexpectedly\n"
		      | SOME m =>
			case m of
			    MsgOk => print ("Slave " ^ node ^ " pre-regeneration finished\n")
			  | MsgError s => print ("Slave " ^ node
						 ^ " returned error: " ^
						 s ^ "\n")
			  | _ => print ("Slave " ^ node
					^ " returned unexpected command\n");
		    OpenSSL.close bio
		end		

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

		val dname = Config.domtoolDir user

		val dir = Posix.FileSys.opendir dname

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

		val files = loop []
		val (_, files) = Order.order (SOME b) files
	    in
		if !ErrorMsg.anyErrors then
		    print ("User " ^ user ^ "'s configuration has errors!\n")
		else
		    app eval' files
	    end
		handle IO.Io _ => ()
		     | OS.SysErr (s, _) => print ("System error processing user " ^ user ^ ": " ^ s ^ "\n")
		     | ErrorMsg.Error => print ("User " ^ user ^ " had a compilation error.\n")
    in
	app contactNode Config.nodeIps;
	Env.pre ();
	app doUser (Acl.users ());
	Env.post ()
    end

fun rmuser user =
    let
	val doms = Acl.class {user = user, class = "domain"}
	val doms = List.filter (fn dom =>
				   case Acl.whoHas {class = "domain", value = dom} of
				       [_] => true
				     | _ => false) (StringSet.listItems doms)
    in
	Acl.rmuser user;
	Domain.rmdom doms
    end

fun now () = Date.toString (Date.fromTimeUniv (Time.now ()))

fun answerQuery q =
    case q of
	QApt pkg => if Apt.installed pkg then MsgYes else MsgNo
      | QCron user => if Cron.allowed user then MsgYes else MsgNo
      | QFtp user => if Ftp.allowed user then MsgYes else MsgNo
      | QTrustedPath user => if TrustedPath.query user then MsgYes else MsgNo
      | QSocket user => MsgSocket (SocketPerm.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

fun service () =
    let
	val () = Acl.read Config.aclFile
	
	val context = OpenSSL.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 OpenSSL.OpenSSL _ =>
				print "OpenSSL error\n"
			      | OS.SysErr (s, _) =>
				(print "System error: ";
				 print s;
				 print "\n";
				 Msg.send (bio, MsgError ("System error: " ^ s))
				 handle OpenSSL.OpenSSL _ => ())
			      | Fail s =>
				(print "Failure: ";
				 print s;
				 print "\n";
				 Msg.send (bio, MsgError ("Failure: " ^ s))
				 handle OpenSSL.OpenSSL _ => ())
			      | ErrorMsg.Error =>
				(print "Compilation error\n";
				 Msg.send (bio, MsgError "Error during configuration evaluation")
				 handle OpenSSL.OpenSSL _ => ());
                         (cleanup ();
			  ignore (OpenSSL.readChar bio);
			  OpenSSL.close bio)
			 handle OpenSSL.OpenSSL _ => ();
			 loop ())

		    fun doConfig codes =
			let
			    val _ = print "Configuration:\n"
			    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
					     (regenerate context;
					      ("Regenerated all configuration.",
					       NONE))
					 else
					     ("Unauthorized user asked to regenerate!",
					      SOME "Not authorized to regenerate"))
				     (fn () => ())

			      | MsgRmuser user' =>
				doIt (fn () =>
					 if Acl.query {user = user, class = "priv", value = "all"} then
					     (rmuser user';
					      Acl.write Config.aclFile;
					      ("Removed user " ^ user' ^ ".",
					       NONE))
					 else
					     ("Unauthorized user asked to remove a user!",
					      SOME "Not authorized to remove users"))
				     (fn () => ())

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

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

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

			      | MsgListMailboxes domain =>
				doIt (fn () =>
					 if not (Domain.yourDomain domain) then
					     ("User wasn't authorized to list mailboxes for " ^ domain,
					      SOME "You're not authorized to configure that domain.")
					 else
					     case Vmail.list domain of
						 Vmail.Listing users => (Msg.send (bio, MsgMailboxes users);
									 ("Sent mailbox list for " ^ domain,
									  NONE))
					       | Vmail.Error msg => ("Error listing mailboxes for " ^ domain ^ ": " ^ msg,
								     SOME msg))
				     (fn () => ())

			      | MsgNewMailbox {domain, user = emailUser, passwd, mailbox} =>
				doIt (fn () =>
					 if not (Domain.yourDomain domain) then
					     ("User wasn't authorized to add a mailbox to " ^ domain,
					      SOME "You're not authorized to configure that domain.")
					 else if not (Domain.validEmailUser emailUser) then
					     ("Invalid e-mail username " ^ emailUser,
					      SOME "Invalid e-mail username")
					 else if not (CharVector.all Char.isGraph passwd) then
					     ("Invalid password",
					      SOME "Invalid password; may only contain printable, non-space characters")
					 else if not (Domain.yourPath mailbox) then
					     ("User wasn't authorized to add a mailbox at " ^ mailbox,
					      SOME "You're not authorized to use that mailbox location.")
					 else
					     case Vmail.add {requester = user,
							     domain = domain, user = emailUser,
							     passwd = passwd, mailbox = mailbox} of
						 NONE => ("Added mailbox " ^ emailUser ^ "@" ^ domain ^ " at " ^ mailbox,
							  NONE)
					       | SOME msg => ("Error adding mailbox " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
							      SOME msg))
				     (fn () => ())
				
			      | MsgPasswdMailbox {domain, user = emailUser, passwd} =>
				doIt (fn () =>
					 if not (Domain.yourDomain domain) then
					     ("User wasn't authorized to change password of a mailbox for " ^ domain,
					      SOME "You're not authorized to configure that domain.")
					 else if not (Domain.validEmailUser emailUser) then
					     ("Invalid e-mail username " ^ emailUser,
					      SOME "Invalid e-mail username")
					 else if not (CharVector.all Char.isGraph passwd) then
					     ("Invalid password",
					      SOME "Invalid password; may only contain printable, non-space characters")
					 else
					     case Vmail.passwd {domain = domain, user = emailUser,
								passwd = passwd} of
						 NONE => ("Changed password of mailbox " ^ emailUser ^ "@" ^ domain,
							  NONE)
					       | SOME msg => ("Error changing mailbox password for " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
							      SOME msg))
				     (fn () => ())

			      | MsgRmMailbox {domain, user = emailUser} =>
				doIt (fn () =>
					 if not (Domain.yourDomain domain) then
					     ("User wasn't authorized to change password of a mailbox for " ^ domain,
					      SOME "You're not authorized to configure that domain.")
					 else if not (Domain.validEmailUser emailUser) then
					     ("Invalid e-mail username " ^ emailUser,
					      SOME "Invalid e-mail username")
					 else
					     case Vmail.rm {domain = domain, user = emailUser} of
						 NONE => ("Deleted mailbox " ^ emailUser ^ "@" ^ domain,
							  NONE)
					       | SOME msg => ("Error deleting mailbox " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
							      SOME msg))
				     (fn () => ())

			      | MsgSaQuery addr =>
				doIt (fn () =>
					 case checkAddr addr of
					     NONE => ("User tried to query SA filtering for " ^ addr,
						      SOME "You aren't allowed to configure SA filtering for that recipient.")
					   | SOME addr' => (Msg.send (bio, MsgSaStatus (SetSA.query addr'));
							    ("Queried SA filtering status for " ^ addr,
							     NONE)))
				     (fn () => ())

			      | MsgSaSet (addr, b) =>
				doIt (fn () =>
					 case checkAddr addr of
					     NONE => ("User tried to set SA filtering for " ^ addr,
						      SOME "You aren't allowed to configure SA filtering for that recipient.")
					   | SOME addr' => (SetSA.set (addr', b);
							    Msg.send (bio, MsgOk);
							    ("Set SA filtering status for " ^ addr ^ " to "
							     ^ (if b then "ON" else "OFF"),
							     NONE)))
				     (fn () => ())

			      | MsgSmtpLogReq domain =>
				doIt (fn () =>
					 if not (Domain.yourDomain domain) then
					     ("Unauthorized user tried to request SMTP logs for " ^ domain,
					      SOME "You aren't authorized to configure that domain.")
					 else
					     (SmtpLog.search (fn line => Msg.send (bio, MsgSmtpLogRes line))
					      domain;
					      ("Requested SMTP logs for " ^ domain,
					       NONE)))
				(fn () => ())

			      | MsgQuery q =>
				doIt (fn () => (Msg.send (bio, answerQuery q);
						(describeQuery q,
						 NONE)))
				(fn () => ())

			      | _ =>
				doIt (fn () => ("Unexpected command",
						SOME "Unexpected command"))
				     (fn () => ())
		in
		    cmdLoop ()
		end
		    handle OpenSSL.OpenSSL s =>
			   (print ("OpenSSL error: " ^ s ^ "\n");
			    OpenSSL.close bio
			    handle OpenSSL.OpenSSL _ => ();
			    loop ())
			 | OS.SysErr (s, _) =>
			   (print ("System error: " ^ s ^ "\n");
			    OpenSSL.close bio
			    handle OpenSSL.OpenSSL _ => ();
			    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 = OpenSSL.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 ())
			 | OS.SysErr (s, _) =>
			   (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