[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
	    false
	else
	    (foldl (fn (fname, G) => check' G fname) b files;
	     !ErrorMsg.anyErrors)
    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

val dispatcher =
    Config.dispatcher ^ ":" ^ Int.toString Config.dispatcherPort

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 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 (user, bio) = requestBio (fn () => ignore (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
	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 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 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 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 ^ "\n")
		    val () = Domain.setUser user

		    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
			    (app doOne codes;
			     Msg.send (bio, MsgOk))
			    handle ErrorMsg.Error =>
				   (print "Compilation error\n";
				    Msg.send (bio,
					      MsgError "Error during configuration evaluation"))
				 | OpenSSL.OpenSSL s =>
				   (print "OpenSSL error\n";
				    Msg.send (bio,
					      MsgError
						  ("Error during configuration evaluation: "
						   ^ s)));
			   OS.FileSys.remove outname;
			   (ignore (OpenSSL.readChar bio);
			    OpenSSL.close bio)
			   handle OpenSSL.OpenSSL _ => ();
			   loop ()
			end

		    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

			      | MsgGrant acl =>
				if Acl.query {user = user, class = "priv", value = "all"} then
				    ((Acl.grant acl;
				      Acl.write Config.aclFile;
				      Msg.send (bio, MsgOk);
				      print ("Granted permission " ^ #value acl ^ " to " ^ #user acl ^ " in " ^ #class acl ^ ".\n"))
				     handle OpenSSL.OpenSSL s =>
					    (print "OpenSSL error\n";
					     Msg.send (bio,
						       MsgError
							   ("Error during granting: "
							    ^ s)));
				    (ignore (OpenSSL.readChar bio);
				     OpenSSL.close bio)
				    handle OpenSSL.OpenSSL _ => ();
				    loop ())
				else
				    ((Msg.send (bio, MsgError "Not authorized to grant privileges");
				      print "Unauthorized user asked to grant a permission!\n";
				      ignore (OpenSSL.readChar bio);
				      OpenSSL.close bio)
				     handle OpenSSL.OpenSSL _ => ();
				     loop ())

			      | MsgRevoke acl =>
				if Acl.query {user = user, class = "priv", value = "all"} then
				    ((Acl.revoke acl;
				      Acl.write Config.aclFile;
				      Msg.send (bio, MsgOk);
				      print ("Revoked permission " ^ #value acl ^ " from " ^ #user acl ^ " in " ^ #class acl ^ ".\n"))
				     handle OpenSSL.OpenSSL s =>
					    (print "OpenSSL error\n";
					     Msg.send (bio,
						       MsgError
							   ("Error during revocation: "
							    ^ s)));
				    (ignore (OpenSSL.readChar bio);
				     OpenSSL.close bio)
				    handle OpenSSL.OpenSSL _ => ();
				    loop ())
				else
				    ((Msg.send (bio, MsgError "Not authorized to revoke privileges");
				      print "Unauthorized user asked to revoke a permission!\n";
				      ignore (OpenSSL.readChar bio);
				      OpenSSL.close bio)
				     handle OpenSSL.OpenSSL _ => ();
				     loop ())

			      | MsgListPerms user =>
				((Msg.send (bio, MsgPerms (Acl.queryAll user));
				  print ("Sent permission list for user " ^ user ^ ".\n"))
				 handle OpenSSL.OpenSSL s =>
					(print "OpenSSL error\n";
					 Msg.send (bio,
						   MsgError
						       ("Error during permission listing: "
							^ s)));
				(ignore (OpenSSL.readChar bio);
				 OpenSSL.close bio)
				handle OpenSSL.OpenSSL _ => ();
				loop ())

			      | MsgWhoHas perm =>
				((Msg.send (bio, MsgWhoHasResponse (Acl.whoHas perm));
				  print ("Sent whohas response for " ^ #class perm ^ " / " ^ #value perm ^ ".\n"))
				 handle OpenSSL.OpenSSL s =>
					(print "OpenSSL error\n";
					 Msg.send (bio,
						   MsgError
						       ("Error during whohas: "
							^ s)));
				(ignore (OpenSSL.readChar bio);
				 OpenSSL.close bio)
				handle OpenSSL.OpenSSL _ => ();
				loop ())

			      | MsgRmdom dom =>
				if Acl.query {user = user, class = "priv", value = "all"}
				   orelse Acl.query {user = user, class = "domain", value = dom} then
				    ((Domain.rmdom dom;
				      Msg.send (bio, MsgOk);
				      print ("Removed domain " ^ dom ^ ".\n"))
				     handle OpenSSL.OpenSSL s =>
					    (print "OpenSSL error\n";
					     Msg.send (bio,
						       MsgError
							   ("Error during revocation: "
							    ^ s)));
				    (ignore (OpenSSL.readChar bio);
				     OpenSSL.close bio)
				    handle OpenSSL.OpenSSL _ => ();
				    loop ())
				else
				    ((Msg.send (bio, MsgError "Not authorized to remove that domain");
				      print "Unauthorized user asked to remove a domain!\n";
				      ignore (OpenSSL.readChar bio);
				      OpenSSL.close bio)
				     handle OpenSSL.OpenSSL _ => ();
				     loop ())				

			      | _ =>
				(Msg.send (bio, MsgError "Unexpected command")
				 handle OpenSSL.OpenSSL _ => ();
				 OpenSSL.close bio
				 handle OpenSSL.OpenSSL _ => ();
				 loop ())
		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 "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)

	fun loop () =
	    case OpenSSL.accept sock of
		NONE => ()
	      | SOME bio =>
		let
		    val peer = OpenSSL.peerCN bio
		    val () = print ("\nConnection from " ^ peer ^ "\n")
		in
		    if peer <> Config.dispatcherName then
			(print "Not authorized!\n";
			 OpenSSL.close bio;
			 loop ())
		    else 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))
				      | _ => (print "Dispatcher sent unexpected command\n";
					      Msg.send (bio, MsgError "Unexpected command"))
			in
			    loop' [];
			    ignore (OpenSSL.readChar bio);
			    OpenSSL.close bio;
			    loop ()
			end
		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 autodocBasis outdir =
    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 []
    in
	Autodoc.autodoc {outdir = outdir, infiles = files}
    end

end
Commit	Line	Data
234b917a AC	1	(* HCoop Domtool (http://hcoop.sourceforge.net/)
	2	* Copyright (c) 2006, Adam Chlipala
	3	*
	4	* This program is free software; you can redistribute it and/or
	5	* modify it under the terms of the GNU General Public License
	6	* as published by the Free Software Foundation; either version 2
	7	* of the License, or (at your option) any later version.
	8	*
	9	* This program is distributed in the hope that it will be useful,
	10	* but WITHOUT ANY WARRANTY; without even the implied warranty of
	11	* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	12	* GNU General Public License for more details.
	13	*
	14	* You should have received a copy of the GNU General Public License
	15	* along with this program; if not, write to the Free Software
	16	* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
dac62e84	17	*)
234b917a AC	18
	19	(* Main interface *)
	20
	21	structure Main :> MAIN = struct
	22
36e42cb8	23	open Ast MsgTypes Print
234b917a	24
6ae327f8 AC	25	structure SM = StringMap
6ae327f8 AC	26
aa56e112	27	fun init () = Acl.read Config.aclFile
234b917a	28
d189ec0e	29	fun check' G fname =
a3698041 AC	30	let
	31	val prog = Parse.parse fname
	32	in
	33	if !ErrorMsg.anyErrors then
d189ec0e	34	G
a3698041	35	else
aa56e112	36	Tycheck.checkFile G (Defaults.tInit ()) prog
a3698041 AC	37	end
a3698041 AC	38
d189ec0e	39	fun basis () =
234b917a	40	let
d189ec0e AC	41	val dir = Posix.FileSys.opendir Config.libRoot
	42
	43	fun loop files =
	44	case Posix.FileSys.readdir dir of
d612d62c AC	45	NONE => (Posix.FileSys.closedir dir;
d612d62c AC	46	files)
d189ec0e AC	47	\| SOME fname =>
d189ec0e AC	48	if String.isSuffix ".dtl" fname then
d612d62c AC	49	loop (OS.Path.joinDirFile {dir = Config.libRoot,
d612d62c AC	50	file = fname}
d189ec0e AC	51	:: files)
	52	else
	53	loop files
	54
	55	val files = loop []
c53e82e4	56	val (_, files) = Order.order NONE files
d189ec0e	57	in
6ae327f8 AC	58	if !ErrorMsg.anyErrors then
	59	Env.empty
	60	else
b3159a70 AC	61	(Tycheck.allowExterns ();
	62	foldl (fn (fname, G) => check' G fname) Env.empty files
	63	before Tycheck.disallowExterns ())
d189ec0e AC	64	end
	65
	66	fun check fname =
	67	let
	68	val _ = ErrorMsg.reset ()
12adf55a	69	val _ = Env.preTycheck ()
d189ec0e AC	70
d189ec0e AC	71	val b = basis ()
234b917a AC	72	in
234b917a AC	73	if !ErrorMsg.anyErrors then
36e42cb8	74	raise ErrorMsg.Error
234b917a AC	75	else
234b917a AC	76	let
b3159a70	77	val _ = Tycheck.disallowExterns ()
7f012ffd	78	val _ = ErrorMsg.reset ()
d189ec0e	79	val prog = Parse.parse fname
234b917a	80	in
492c1cff	81	if !ErrorMsg.anyErrors then
36e42cb8	82	raise ErrorMsg.Error
492c1cff	83	else
d189ec0e	84	let
aa56e112	85	val G' = Tycheck.checkFile b (Defaults.tInit ()) prog
d189ec0e	86	in
36e42cb8 AC	87	if !ErrorMsg.anyErrors then
	88	raise ErrorMsg.Error
	89	else
	90	(G', #3 prog)
d189ec0e	91	end
234b917a AC	92	end
	93	end
	94
c53e82e4 AC	95	val notTmp = CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"." orelse ch = #"_" orelse ch = #"-")
	96
	97	fun checkDir dname =
	98	let
	99	val b = basis ()
	100
	101	val dir = Posix.FileSys.opendir dname
	102
	103	fun loop files =
	104	case Posix.FileSys.readdir dir of
	105	NONE => (Posix.FileSys.closedir dir;
	106	files)
	107	\| SOME fname =>
	108	if notTmp fname then
	109	loop (OS.Path.joinDirFile {dir = dname,
	110	file = fname}
	111	:: files)
	112	else
	113	loop files
	114
	115	val files = loop []
	116	val (_, files) = Order.order (SOME b) files
	117	in
	118	if !ErrorMsg.anyErrors then
	119	false
	120	else
	121	(foldl (fn (fname, G) => check' G fname) b files;
	122	!ErrorMsg.anyErrors)
	123	end
	124
d189ec0e	125	fun reduce fname =
a3698041	126	let
d189ec0e	127	val (G, body) = check fname
a3698041 AC	128	in
a3698041 AC	129	if !ErrorMsg.anyErrors then
d189ec0e	130	NONE
a3698041	131	else
d189ec0e AC	132	case body of
	133	SOME body =>
	134	let
	135	val body' = Reduce.reduceExp G body
	136	in
	137	(*printd (PD.hovBox (PD.PPS.Rel 0,
	138	[PD.string "Result:",
	139	PD.space 1,
	140	p_exp body']))*)
	141	SOME body'
	142	end
	143	\| _ => NONE
a3698041 AC	144	end
a3698041 AC	145
d189ec0e AC	146	fun eval fname =
	147	case reduce fname of
	148	(SOME body') =>
	149	if !ErrorMsg.anyErrors then
36e42cb8	150	raise ErrorMsg.Error
d189ec0e	151	else
aa56e112	152	Eval.exec (Defaults.eInit ()) body'
36e42cb8	153	\| NONE => raise ErrorMsg.Error
d189ec0e	154
3b267643 AC	155	val dispatcher =
3b267643 AC	156	Config.dispatcher ^ ":" ^ Int.toString Config.dispatcherPort
559e89e9	157
5ee41dd0	158	fun requestContext f =
07cc384c	159	let
a56cc2c3 AC	160	val uid = Posix.ProcEnv.getuid ()
a56cc2c3 AC	161	val user = Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid uid)
5ee41dd0	162
a56cc2c3 AC	163	val () = Acl.read Config.aclFile
a56cc2c3 AC	164	val () = Domain.setUser user
5ee41dd0 AC	165
5ee41dd0 AC	166	val () = f ()
aa56e112	167
aa56e112	168	val context = OpenSSL.context (Config.certDir ^ "/" ^ user ^ ".pem",
a088cea6	169	Config.keyDir ^ "/" ^ user ^ "/key.pem",
3b267643	170	Config.trustStore)
5ee41dd0 AC	171	in
	172	(user, context)
	173	end
07cc384c	174
5ee41dd0 AC	175	fun requestBio f =
	176	let
	177	val (user, context) = requestContext f
	178	in
	179	(user, OpenSSL.connect (context, dispatcher))
	180	end
	181
	182	fun request fname =
	183	let
	184	val (user, bio) = requestBio (fn () => ignore (check fname))
559e89e9	185
3b267643 AC	186	val inf = TextIO.openIn fname
3b267643 AC	187
36e42cb8	188	fun loop lines =
3b267643	189	case TextIO.inputLine inf of
36e42cb8 AC	190	NONE => String.concat (List.rev lines)
	191	\| SOME line => loop (line :: lines)
	192
	193	val code = loop []
559e89e9	194	in
3b267643	195	TextIO.closeIn inf;
36e42cb8 AC	196	Msg.send (bio, MsgConfig code);
	197	case Msg.recv bio of
	198	NONE => print "Server closed connection unexpectedly.\n"
	199	\| SOME m =>
	200	case m of
	201	MsgOk => print "Configuration succeeded.\n"
	202	\| MsgError s => print ("Configuration failed: " ^ s ^ "\n")
	203	\| _ => print "Unexpected server reply.\n";
3b267643	204	OpenSSL.close bio
559e89e9	205	end
aa56e112	206	handle ErrorMsg.Error => ()
559e89e9	207
c53e82e4 AC	208	fun requestDir dname =
	209	let
	210	val (user, bio) = requestBio (fn () => ignore (checkDir dname))
	211
	212	val b = basis ()
	213
	214	val dir = Posix.FileSys.opendir dname
	215
	216	fun loop files =
	217	case Posix.FileSys.readdir dir of
	218	NONE => (Posix.FileSys.closedir dir;
	219	files)
	220	\| SOME fname =>
	221	if notTmp fname then
	222	loop (OS.Path.joinDirFile {dir = dname,
	223	file = fname}
	224	:: files)
	225	else
	226	loop files
	227
	228	val files = loop []
	229	val (_, files) = Order.order (SOME b) files
	230
	231	val _ = if !ErrorMsg.anyErrors then
	232	raise ErrorMsg.Error
	233	else
	234	()
	235
	236	val codes = map (fn fname =>
	237	let
	238	val inf = TextIO.openIn fname
	239
	240	fun loop lines =
	241	case TextIO.inputLine inf of
	242	NONE => String.concat (rev lines)
	243	\| SOME line => loop (line :: lines)
	244	in
	245	loop []
	246	before TextIO.closeIn inf
	247	end) files
	248	in
	249	Msg.send (bio, MsgMultiConfig codes);
	250	case Msg.recv bio of
	251	NONE => print "Server closed connection unexpectedly.\n"
	252	\| SOME m =>
	253	case m of
	254	MsgOk => print "Configuration succeeded.\n"
	255	\| MsgError s => print ("Configuration failed: " ^ s ^ "\n")
	256	\| _ => print "Unexpected server reply.\n";
	257	OpenSSL.close bio
	258	end
	259	handle ErrorMsg.Error => ()
	260
5ee41dd0 AC	261	fun requestGrant acl =
	262	let
	263	val (user, bio) = requestBio (fn () => ())
	264	in
	265	Msg.send (bio, MsgGrant acl);
	266	case Msg.recv bio of
	267	NONE => print "Server closed connection unexpectedly.\n"
	268	\| SOME m =>
	269	case m of
	270	MsgOk => print "Grant succeeded.\n"
	271	\| MsgError s => print ("Grant failed: " ^ s ^ "\n")
	272	\| _ => print "Unexpected server reply.\n";
	273	OpenSSL.close bio
	274	end
	275
411a85f2 AC	276	fun requestRevoke acl =
	277	let
	278	val (user, bio) = requestBio (fn () => ())
	279	in
	280	Msg.send (bio, MsgRevoke acl);
	281	case Msg.recv bio of
	282	NONE => print "Server closed connection unexpectedly.\n"
	283	\| SOME m =>
	284	case m of
	285	MsgOk => print "Revoke succeeded.\n"
	286	\| MsgError s => print ("Revoke failed: " ^ s ^ "\n")
	287	\| _ => print "Unexpected server reply.\n";
	288	OpenSSL.close bio
	289	end
	290
08a04eb4 AC	291	fun requestListPerms user =
	292	let
	293	val (_, bio) = requestBio (fn () => ())
	294	in
	295	Msg.send (bio, MsgListPerms user);
	296	(case Msg.recv bio of
	297	NONE => (print "Server closed connection unexpectedly.\n";
	298	NONE)
	299	\| SOME m =>
	300	case m of
	301	MsgPerms perms => SOME perms
	302	\| MsgError s => (print ("Listing failed: " ^ s ^ "\n");
	303	NONE)
	304	\| _ => (print "Unexpected server reply.\n";
	305	NONE))
	306	before OpenSSL.close bio
	307	end
	308
094877b1 AC	309	fun requestWhoHas perm =
	310	let
	311	val (_, bio) = requestBio (fn () => ())
	312	in
	313	Msg.send (bio, MsgWhoHas perm);
	314	(case Msg.recv bio of
	315	NONE => (print "Server closed connection unexpectedly.\n";
	316	NONE)
	317	\| SOME m =>
	318	case m of
	319	MsgWhoHasResponse users => SOME users
	320	\| MsgError s => (print ("whohas failed: " ^ s ^ "\n");
	321	NONE)
	322	\| _ => (print "Unexpected server reply.\n";
	323	NONE))
	324	before OpenSSL.close bio
	325	end
	326
c189cbe9 AC	327	fun requestRmdom dom =
	328	let
	329	val (_, bio) = requestBio (fn () => ())
	330	in
	331	Msg.send (bio, MsgRmdom dom);
	332	case Msg.recv bio of
	333	NONE => print "Server closed connection unexpectedly.\n"
	334	\| SOME m =>
	335	case m of
	336	MsgOk => print "Removal succeeded.\n"
	337	\| MsgError s => print ("Removal failed: " ^ s ^ "\n")
	338	\| _ => print "Unexpected server reply.\n";
	339	OpenSSL.close bio
	340	end
	341
3b267643	342	fun service () =
07cc384c	343	let
aa56e112 AC	344	val () = Acl.read Config.aclFile
aa56e112 AC	345
3b267643 AC	346	val context = OpenSSL.context (Config.serverCert,
	347	Config.serverKey,
	348	Config.trustStore)
36e42cb8	349	val _ = Domain.set_context context
3b267643	350
60534712	351	val sock = OpenSSL.listen (context, Config.dispatcherPort)
3b267643 AC	352
3b267643 AC	353	fun loop () =
60534712	354	case OpenSSL.accept sock of
3b267643 AC	355	NONE => ()
	356	\| SOME bio =>
	357	let
aa56e112 AC	358	val user = OpenSSL.peerCN bio
	359	val () = print ("\nConnection from " ^ user ^ "\n")
	360	val () = Domain.setUser user
	361
c53e82e4 AC	362	fun doConfig codes =
	363	let
	364	val _ = print "Configuration:\n"
	365	val _ = app (fn s => (print s; print "\n")) codes
	366	val _ = print "\n"
	367
	368	val outname = OS.FileSys.tmpName ()
	369
	370	fun doOne code =
	371	let
	372	val outf = TextIO.openOut outname
	373	in
	374	TextIO.output (outf, code);
	375	TextIO.closeOut outf;
	376	eval outname
	377	end
	378	in
	379	(app doOne codes;
	380	Msg.send (bio, MsgOk))
	381	handle ErrorMsg.Error =>
	382	(print "Compilation error\n";
	383	Msg.send (bio,
	384	MsgError "Error during configuration evaluation"))
	385	\| OpenSSL.OpenSSL s =>
	386	(print "OpenSSL error\n";
	387	Msg.send (bio,
	388	MsgError
	389	("Error during configuration evaluation: "
	390	^ s)));
	391	OS.FileSys.remove outname;
	392	(ignore (OpenSSL.readChar bio);
	393	OpenSSL.close bio)
	394	handle OpenSSL.OpenSSL _ => ();
	395	loop ()
	396	end
	397
36e42cb8 AC	398	fun cmdLoop () =
	399	case Msg.recv bio of
	400	NONE => (OpenSSL.close bio
	401	handle OpenSSL.OpenSSL _ => ();
	402	loop ())
	403	\| SOME m =>
	404	case m of
c53e82e4 AC	405	MsgConfig code => doConfig [code]
c53e82e4 AC	406	\| MsgMultiConfig codes => doConfig codes
5ee41dd0 AC	407
5ee41dd0 AC	408	\| MsgGrant acl =>
be1bea4c	409	if Acl.query {user = user, class = "priv", value = "all"} then
5ee41dd0 AC	410	((Acl.grant acl;
5ee41dd0 AC	411	Acl.write Config.aclFile;
411a85f2 AC	412	Msg.send (bio, MsgOk);
411a85f2 AC	413	print ("Granted permission " ^ #value acl ^ " to " ^ #user acl ^ " in " ^ #class acl ^ ".\n"))
5ee41dd0 AC	414	handle OpenSSL.OpenSSL s =>
	415	(print "OpenSSL error\n";
	416	Msg.send (bio,
	417	MsgError
	418	("Error during granting: "
	419	^ s)));
	420	(ignore (OpenSSL.readChar bio);
	421	OpenSSL.close bio)
	422	handle OpenSSL.OpenSSL _ => ();
	423	loop ())
	424	else
	425	((Msg.send (bio, MsgError "Not authorized to grant privileges");
411a85f2 AC	426	print "Unauthorized user asked to grant a permission!\n";
	427	ignore (OpenSSL.readChar bio);
	428	OpenSSL.close bio)
	429	handle OpenSSL.OpenSSL _ => ();
	430	loop ())
	431
	432	\| MsgRevoke acl =>
be1bea4c	433	if Acl.query {user = user, class = "priv", value = "all"} then
411a85f2 AC	434	((Acl.revoke acl;
	435	Acl.write Config.aclFile;
	436	Msg.send (bio, MsgOk);
	437	print ("Revoked permission " ^ #value acl ^ " from " ^ #user acl ^ " in " ^ #class acl ^ ".\n"))
	438	handle OpenSSL.OpenSSL s =>
	439	(print "OpenSSL error\n";
	440	Msg.send (bio,
	441	MsgError
	442	("Error during revocation: "
	443	^ s)));
	444	(ignore (OpenSSL.readChar bio);
	445	OpenSSL.close bio)
	446	handle OpenSSL.OpenSSL _ => ();
	447	loop ())
	448	else
	449	((Msg.send (bio, MsgError "Not authorized to revoke privileges");
	450	print "Unauthorized user asked to revoke a permission!\n";
5ee41dd0 AC	451	ignore (OpenSSL.readChar bio);
	452	OpenSSL.close bio)
	453	handle OpenSSL.OpenSSL _ => ();
	454	loop ())
	455
08a04eb4 AC	456	\| MsgListPerms user =>
	457	((Msg.send (bio, MsgPerms (Acl.queryAll user));
	458	print ("Sent permission list for user " ^ user ^ ".\n"))
	459	handle OpenSSL.OpenSSL s =>
	460	(print "OpenSSL error\n";
	461	Msg.send (bio,
	462	MsgError
	463	("Error during permission listing: "
	464	^ s)));
	465	(ignore (OpenSSL.readChar bio);
	466	OpenSSL.close bio)
	467	handle OpenSSL.OpenSSL _ => ();
	468	loop ())
	469
094877b1 AC	470	\| MsgWhoHas perm =>
	471	((Msg.send (bio, MsgWhoHasResponse (Acl.whoHas perm));
	472	print ("Sent whohas response for " ^ #class perm ^ " / " ^ #value perm ^ ".\n"))
	473	handle OpenSSL.OpenSSL s =>
	474	(print "OpenSSL error\n";
	475	Msg.send (bio,
	476	MsgError
	477	("Error during whohas: "
	478	^ s)));
	479	(ignore (OpenSSL.readChar bio);
	480	OpenSSL.close bio)
	481	handle OpenSSL.OpenSSL _ => ();
	482	loop ())
	483
c189cbe9 AC	484	\| MsgRmdom dom =>
	485	if Acl.query {user = user, class = "priv", value = "all"}
	486	orelse Acl.query {user = user, class = "domain", value = dom} then
	487	((Domain.rmdom dom;
	488	Msg.send (bio, MsgOk);
	489	print ("Removed domain " ^ dom ^ ".\n"))
	490	handle OpenSSL.OpenSSL s =>
	491	(print "OpenSSL error\n";
	492	Msg.send (bio,
	493	MsgError
	494	("Error during revocation: "
	495	^ s)));
	496	(ignore (OpenSSL.readChar bio);
	497	OpenSSL.close bio)
	498	handle OpenSSL.OpenSSL _ => ();
	499	loop ())
	500	else
	501	((Msg.send (bio, MsgError "Not authorized to remove that domain");
	502	print "Unauthorized user asked to remove a domain!\n";
	503	ignore (OpenSSL.readChar bio);
	504	OpenSSL.close bio)
	505	handle OpenSSL.OpenSSL _ => ();
	506	loop ())
	507
36e42cb8 AC	508	\| _ =>
	509	(Msg.send (bio, MsgError "Unexpected command")
	510	handle OpenSSL.OpenSSL _ => ();
	511	OpenSSL.close bio
	512	handle OpenSSL.OpenSSL _ => ();
	513	loop ())
	514	in
	515	cmdLoop ()
	516	end
97665758 AC	517	handle OpenSSL.OpenSSL s =>
	518	(print ("OpenSSL error: " ^ s ^ "\n");
	519	OpenSSL.close bio
	520	handle OpenSSL.OpenSSL _ => ();
	521	loop ())
	522	\| OS.SysErr (s, _) =>
	523	(print ("System error: " ^ s ^ "\n");
	524	OpenSSL.close bio
	525	handle OpenSSL.OpenSSL _ => ();
	526	loop ())
36e42cb8	527	in
361a1e7f	528	print "Listening for connections....\n";
36e42cb8 AC	529	loop ();
	530	OpenSSL.shutdown sock
	531	end
	532
	533	fun slave () =
	534	let
6e62228d	535	val host = Slave.hostname ()
36e42cb8 AC	536
36e42cb8 AC	537	val context = OpenSSL.context (Config.certDir ^ "/" ^ host ^ ".pem",
a088cea6	538	Config.keyDir ^ "/" ^ host ^ "/key.pem",
36e42cb8 AC	539	Config.trustStore)
	540
	541	val sock = OpenSSL.listen (context, Config.slavePort)
	542
	543	fun loop () =
	544	case OpenSSL.accept sock of
	545	NONE => ()
	546	\| SOME bio =>
	547	let
	548	val peer = OpenSSL.peerCN bio
	549	val () = print ("\nConnection from " ^ peer ^ "\n")
3b267643	550	in
36e42cb8 AC	551	if peer <> Config.dispatcherName then
	552	(print "Not authorized!\n";
	553	OpenSSL.close bio;
	554	loop ())
	555	else let
	556	fun loop' files =
	557	case Msg.recv bio of
	558	NONE => print "Dispatcher closed connection unexpectedly\n"
	559	\| SOME m =>
	560	case m of
	561	MsgFile file => loop' (file :: files)
	562	\| MsgDoFiles => (Slave.handleChanges files;
	563	Msg.send (bio, MsgOk))
	564	\| _ => (print "Dispatcher sent unexpected command\n";
	565	Msg.send (bio, MsgError "Unexpected command"))
	566	in
	567	loop' [];
	568	ignore (OpenSSL.readChar bio);
	569	OpenSSL.close bio;
	570	loop ()
	571	end
3196000d AC	572	end handle OpenSSL.OpenSSL s =>
	573	(print ("OpenSSL error: "^ s ^ "\n");
	574	OpenSSL.close bio
	575	handle OpenSSL.OpenSSL _ => ();
	576	loop ())
7af7d4cb AC	577	\| OS.SysErr (s, _) =>
	578	(print ("System error: "^ s ^ "\n");
	579	OpenSSL.close bio
	580	handle OpenSSL.OpenSSL _ => ();
	581	loop ())
07cc384c	582	in
3b267643 AC	583	loop ();
3b267643 AC	584	OpenSSL.shutdown sock
07cc384c AC	585	end
07cc384c AC	586
3196000d AC	587	fun autodocBasis outdir =
	588	let
	589	val dir = Posix.FileSys.opendir Config.libRoot
	590
	591	fun loop files =
	592	case Posix.FileSys.readdir dir of
	593	NONE => (Posix.FileSys.closedir dir;
	594	files)
	595	\| SOME fname =>
	596	if String.isSuffix ".dtl" fname then
	597	loop (OS.Path.joinDirFile {dir = Config.libRoot,
	598	file = fname}
	599	:: files)
	600	else
	601	loop files
	602
	603	val files = loop []
	604	in
	605	Autodoc.autodoc {outdir = outdir, infiles = files}
	606	end
	607
234b917a	608	end