[hcoop/zz_old/domtool2-proto.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 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 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 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 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 cmdLoop () =
			case Msg.recv bio of
			    NONE => (OpenSSL.close bio
				     handle OpenSSL.OpenSSL _ => ();
				     loop ())
			  | SOME m =>
			    case m of
				MsgConfig code =>
				let
				    val _ = print "Configuration:\n"
				    val _ = print code
				    val _ = print "\n"

				    val outname = OS.FileSys.tmpName ()
				    val outf = TextIO.openOut outname
				in
				    TextIO.output (outf, code);
				    TextIO.closeOut outf;
				    (eval outname;
				     Msg.send (bio, MsgOk))
				    handle ErrorMsg.Error =>
					   (print "Compilation error\n";
					    Msg.send (bio,
						      MsgError "Error during configuration evaluation"))
					 | OpenSSL.OpenSSL s =>
					   (print "OpenSSL error\n";
					    Msg.send (bio,
						      MsgError
							  ("Error during configuration evaluation: "
							   ^ s)));
				    OS.FileSys.remove outname;
				    (ignore (OpenSSL.readChar bio);
				     OpenSSL.close bio)
				    handle OpenSSL.OpenSSL _ => ();
				    loop ()
				end

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

			      | _ =>
				(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
e680130a	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.
ae3a5b8c	17	*)
e680130a	18
	19	(* Main interface *)
	20
	21	structure Main :> MAIN = struct
	22
d330d9b8	23	open Ast MsgTypes Print
e680130a	24
85af7d3e	25	structure SM = StringMap
85af7d3e	26
53d222a3	27	fun init () = Acl.read Config.aclFile
e680130a	28
17ef447e	29	fun check' G fname =
a11c0ff3	30	let
	31	val prog = Parse.parse fname
	32	in
	33	if !ErrorMsg.anyErrors then
17ef447e	34	G
a11c0ff3	35	else
53d222a3	36	Tycheck.checkFile G (Defaults.tInit ()) prog
a11c0ff3	37	end
a11c0ff3	38
17ef447e	39	fun basis () =
e680130a	40	let
17ef447e	41	val dir = Posix.FileSys.opendir Config.libRoot
	42
	43	fun loop files =
	44	case Posix.FileSys.readdir dir of
c12828f2	45	NONE => (Posix.FileSys.closedir dir;
c12828f2	46	files)
17ef447e	47	\| SOME fname =>
17ef447e	48	if String.isSuffix ".dtl" fname then
c12828f2	49	loop (OS.Path.joinDirFile {dir = Config.libRoot,
c12828f2	50	file = fname}
17ef447e	51	:: files)
	52	else
	53	loop files
	54
	55	val files = loop []
91c5a390	56	val (_, files) = Order.order files
17ef447e	57	in
85af7d3e	58	if !ErrorMsg.anyErrors then
	59	Env.empty
	60	else
89c9edc9	61	(Tycheck.allowExterns ();
	62	foldl (fn (fname, G) => check' G fname) Env.empty files
	63	before Tycheck.disallowExterns ())
17ef447e	64	end
	65
	66	fun check fname =
	67	let
	68	val _ = ErrorMsg.reset ()
4e8a3f2b	69	val _ = Env.preTycheck ()
17ef447e	70
17ef447e	71	val b = basis ()
e680130a	72	in
e680130a	73	if !ErrorMsg.anyErrors then
d330d9b8	74	raise ErrorMsg.Error
e680130a	75	else
e680130a	76	let
89c9edc9	77	val _ = Tycheck.disallowExterns ()
4cc63b03	78	val _ = ErrorMsg.reset ()
17ef447e	79	val prog = Parse.parse fname
e680130a	80	in
add6f172	81	if !ErrorMsg.anyErrors then
d330d9b8	82	raise ErrorMsg.Error
add6f172	83	else
17ef447e	84	let
53d222a3	85	val G' = Tycheck.checkFile b (Defaults.tInit ()) prog
17ef447e	86	in
d330d9b8	87	if !ErrorMsg.anyErrors then
	88	raise ErrorMsg.Error
	89	else
	90	(G', #3 prog)
17ef447e	91	end
e680130a	92	end
	93	end
	94
17ef447e	95	fun reduce fname =
a11c0ff3	96	let
17ef447e	97	val (G, body) = check fname
a11c0ff3	98	in
a11c0ff3	99	if !ErrorMsg.anyErrors then
17ef447e	100	NONE
a11c0ff3	101	else
17ef447e	102	case body of
	103	SOME body =>
	104	let
	105	val body' = Reduce.reduceExp G body
	106	in
	107	(*printd (PD.hovBox (PD.PPS.Rel 0,
	108	[PD.string "Result:",
	109	PD.space 1,
	110	p_exp body']))*)
	111	SOME body'
	112	end
	113	\| _ => NONE
a11c0ff3	114	end
a11c0ff3	115
17ef447e	116	fun eval fname =
	117	case reduce fname of
	118	(SOME body') =>
	119	if !ErrorMsg.anyErrors then
d330d9b8	120	raise ErrorMsg.Error
17ef447e	121	else
53d222a3	122	Eval.exec (Defaults.eInit ()) body'
d330d9b8	123	\| NONE => raise ErrorMsg.Error
17ef447e	124
2569e66d	125	val dispatcher =
2569e66d	126	Config.dispatcher ^ ":" ^ Int.toString Config.dispatcherPort
1f8889bd	127
e2130d9c	128	fun requestContext f =
904eb905	129	let
3ff08fe1	130	val uid = Posix.ProcEnv.getuid ()
3ff08fe1	131	val user = Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid uid)
e2130d9c	132
3ff08fe1	133	val () = Acl.read Config.aclFile
3ff08fe1	134	val () = Domain.setUser user
e2130d9c	135
e2130d9c	136	val () = f ()
53d222a3	137
53d222a3	138	val context = OpenSSL.context (Config.certDir ^ "/" ^ user ^ ".pem",
514b7936	139	Config.keyDir ^ "/" ^ user ^ "/key.pem",
2569e66d	140	Config.trustStore)
e2130d9c	141	in
	142	(user, context)
	143	end
904eb905	144
e2130d9c	145	fun requestBio f =
	146	let
	147	val (user, context) = requestContext f
	148	in
	149	(user, OpenSSL.connect (context, dispatcher))
	150	end
	151
	152	fun request fname =
	153	let
	154	val (user, bio) = requestBio (fn () => ignore (check fname))
1f8889bd	155
2569e66d	156	val inf = TextIO.openIn fname
2569e66d	157
d330d9b8	158	fun loop lines =
2569e66d	159	case TextIO.inputLine inf of
d330d9b8	160	NONE => String.concat (List.rev lines)
	161	\| SOME line => loop (line :: lines)
	162
	163	val code = loop []
1f8889bd	164	in
2569e66d	165	TextIO.closeIn inf;
d330d9b8	166	Msg.send (bio, MsgConfig code);
	167	case Msg.recv bio of
	168	NONE => print "Server closed connection unexpectedly.\n"
	169	\| SOME m =>
	170	case m of
	171	MsgOk => print "Configuration succeeded.\n"
	172	\| MsgError s => print ("Configuration failed: " ^ s ^ "\n")
	173	\| _ => print "Unexpected server reply.\n";
2569e66d	174	OpenSSL.close bio
1f8889bd	175	end
53d222a3	176	handle ErrorMsg.Error => ()
1f8889bd	177
e2130d9c	178	fun requestGrant acl =
	179	let
	180	val (user, bio) = requestBio (fn () => ())
	181	in
	182	Msg.send (bio, MsgGrant acl);
	183	case Msg.recv bio of
	184	NONE => print "Server closed connection unexpectedly.\n"
	185	\| SOME m =>
	186	case m of
	187	MsgOk => print "Grant succeeded.\n"
	188	\| MsgError s => print ("Grant failed: " ^ s ^ "\n")
	189	\| _ => print "Unexpected server reply.\n";
	190	OpenSSL.close bio
	191	end
	192
d1aa6a21	193	fun requestRevoke acl =
	194	let
	195	val (user, bio) = requestBio (fn () => ())
	196	in
	197	Msg.send (bio, MsgRevoke acl);
	198	case Msg.recv bio of
	199	NONE => print "Server closed connection unexpectedly.\n"
	200	\| SOME m =>
	201	case m of
	202	MsgOk => print "Revoke succeeded.\n"
	203	\| MsgError s => print ("Revoke failed: " ^ s ^ "\n")
	204	\| _ => print "Unexpected server reply.\n";
	205	OpenSSL.close bio
	206	end
	207
646381db	208	fun requestListPerms user =
	209	let
	210	val (_, bio) = requestBio (fn () => ())
	211	in
	212	Msg.send (bio, MsgListPerms user);
	213	(case Msg.recv bio of
	214	NONE => (print "Server closed connection unexpectedly.\n";
	215	NONE)
	216	\| SOME m =>
	217	case m of
	218	MsgPerms perms => SOME perms
	219	\| MsgError s => (print ("Listing failed: " ^ s ^ "\n");
	220	NONE)
	221	\| _ => (print "Unexpected server reply.\n";
	222	NONE))
	223	before OpenSSL.close bio
	224	end
	225
d0e75410	226	fun requestWhoHas perm =
	227	let
	228	val (_, bio) = requestBio (fn () => ())
	229	in
	230	Msg.send (bio, MsgWhoHas perm);
	231	(case Msg.recv bio of
	232	NONE => (print "Server closed connection unexpectedly.\n";
	233	NONE)
	234	\| SOME m =>
	235	case m of
	236	MsgWhoHasResponse users => SOME users
	237	\| MsgError s => (print ("whohas failed: " ^ s ^ "\n");
	238	NONE)
	239	\| _ => (print "Unexpected server reply.\n";
	240	NONE))
	241	before OpenSSL.close bio
	242	end
	243
2569e66d	244	fun service () =
904eb905	245	let
53d222a3	246	val () = Acl.read Config.aclFile
53d222a3	247
2569e66d	248	val context = OpenSSL.context (Config.serverCert,
	249	Config.serverKey,
	250	Config.trustStore)
d330d9b8	251	val _ = Domain.set_context context
2569e66d	252
cbb8f260	253	val sock = OpenSSL.listen (context, Config.dispatcherPort)
2569e66d	254
2569e66d	255	fun loop () =
cbb8f260	256	case OpenSSL.accept sock of
2569e66d	257	NONE => ()
	258	\| SOME bio =>
	259	let
53d222a3	260	val user = OpenSSL.peerCN bio
	261	val () = print ("\nConnection from " ^ user ^ "\n")
	262	val () = Domain.setUser user
	263
d330d9b8	264	fun cmdLoop () =
	265	case Msg.recv bio of
	266	NONE => (OpenSSL.close bio
	267	handle OpenSSL.OpenSSL _ => ();
	268	loop ())
	269	\| SOME m =>
	270	case m of
	271	MsgConfig code =>
	272	let
	273	val _ = print "Configuration:\n"
	274	val _ = print code
	275	val _ = print "\n"
2569e66d	276
d330d9b8	277	val outname = OS.FileSys.tmpName ()
	278	val outf = TextIO.openOut outname
	279	in
	280	TextIO.output (outf, code);
	281	TextIO.closeOut outf;
	282	(eval outname;
	283	Msg.send (bio, MsgOk))
7e90e261	284	handle ErrorMsg.Error =>
	285	(print "Compilation error\n";
	286	Msg.send (bio,
	287	MsgError "Error during configuration evaluation"))
	288	\| OpenSSL.OpenSSL s =>
	289	(print "OpenSSL error\n";
	290	Msg.send (bio,
	291	MsgError
	292	("Error during configuration evaluation: "
	293	^ s)));
e2130d9c	294	OS.FileSys.remove outname;
	295	(ignore (OpenSSL.readChar bio);
	296	OpenSSL.close bio)
	297	handle OpenSSL.OpenSSL _ => ();
	298	loop ()
d330d9b8	299	end
e2130d9c	300
e2130d9c	301	\| MsgGrant acl =>
1bb29dea	302	if Acl.query {user = user, class = "priv", value = "all"} then
e2130d9c	303	((Acl.grant acl;
e2130d9c	304	Acl.write Config.aclFile;
d1aa6a21	305	Msg.send (bio, MsgOk);
d1aa6a21	306	print ("Granted permission " ^ #value acl ^ " to " ^ #user acl ^ " in " ^ #class acl ^ ".\n"))
e2130d9c	307	handle OpenSSL.OpenSSL s =>
	308	(print "OpenSSL error\n";
	309	Msg.send (bio,
	310	MsgError
	311	("Error during granting: "
	312	^ s)));
	313	(ignore (OpenSSL.readChar bio);
	314	OpenSSL.close bio)
	315	handle OpenSSL.OpenSSL _ => ();
	316	loop ())
	317	else
	318	((Msg.send (bio, MsgError "Not authorized to grant privileges");
d1aa6a21	319	print "Unauthorized user asked to grant a permission!\n";
	320	ignore (OpenSSL.readChar bio);
	321	OpenSSL.close bio)
	322	handle OpenSSL.OpenSSL _ => ();
	323	loop ())
	324
	325	\| MsgRevoke acl =>
1bb29dea	326	if Acl.query {user = user, class = "priv", value = "all"} then
d1aa6a21	327	((Acl.revoke acl;
	328	Acl.write Config.aclFile;
	329	Msg.send (bio, MsgOk);
	330	print ("Revoked permission " ^ #value acl ^ " from " ^ #user acl ^ " in " ^ #class acl ^ ".\n"))
	331	handle OpenSSL.OpenSSL s =>
	332	(print "OpenSSL error\n";
	333	Msg.send (bio,
	334	MsgError
	335	("Error during revocation: "
	336	^ s)));
	337	(ignore (OpenSSL.readChar bio);
	338	OpenSSL.close bio)
	339	handle OpenSSL.OpenSSL _ => ();
	340	loop ())
	341	else
	342	((Msg.send (bio, MsgError "Not authorized to revoke privileges");
	343	print "Unauthorized user asked to revoke a permission!\n";
e2130d9c	344	ignore (OpenSSL.readChar bio);
	345	OpenSSL.close bio)
	346	handle OpenSSL.OpenSSL _ => ();
	347	loop ())
	348
646381db	349	\| MsgListPerms user =>
	350	((Msg.send (bio, MsgPerms (Acl.queryAll user));
	351	print ("Sent permission list for user " ^ user ^ ".\n"))
	352	handle OpenSSL.OpenSSL s =>
	353	(print "OpenSSL error\n";
	354	Msg.send (bio,
	355	MsgError
	356	("Error during permission listing: "
	357	^ s)));
	358	(ignore (OpenSSL.readChar bio);
	359	OpenSSL.close bio)
	360	handle OpenSSL.OpenSSL _ => ();
	361	loop ())
	362
d0e75410	363	\| MsgWhoHas perm =>
	364	((Msg.send (bio, MsgWhoHasResponse (Acl.whoHas perm));
	365	print ("Sent whohas response for " ^ #class perm ^ " / " ^ #value perm ^ ".\n"))
	366	handle OpenSSL.OpenSSL s =>
	367	(print "OpenSSL error\n";
	368	Msg.send (bio,
	369	MsgError
	370	("Error during whohas: "
	371	^ s)));
	372	(ignore (OpenSSL.readChar bio);
	373	OpenSSL.close bio)
	374	handle OpenSSL.OpenSSL _ => ();
	375	loop ())
	376
d330d9b8	377	\| _ =>
	378	(Msg.send (bio, MsgError "Unexpected command")
	379	handle OpenSSL.OpenSSL _ => ();
	380	OpenSSL.close bio
	381	handle OpenSSL.OpenSSL _ => ();
	382	loop ())
	383	in
	384	cmdLoop ()
	385	end
7e90e261	386	handle OpenSSL.OpenSSL s =>
	387	(print ("OpenSSL error: " ^ s ^ "\n");
	388	OpenSSL.close bio
	389	handle OpenSSL.OpenSSL _ => ();
	390	loop ())
	391	\| OS.SysErr (s, _) =>
	392	(print ("System error: " ^ s ^ "\n");
	393	OpenSSL.close bio
	394	handle OpenSSL.OpenSSL _ => ();
	395	loop ())
d330d9b8	396	in
0cfb3669	397	print "Listening for connections....\n";
d330d9b8	398	loop ();
	399	OpenSSL.shutdown sock
	400	end
	401
	402	fun slave () =
	403	let
f58a3627	404	val host = Slave.hostname ()
d330d9b8	405
d330d9b8	406	val context = OpenSSL.context (Config.certDir ^ "/" ^ host ^ ".pem",
514b7936	407	Config.keyDir ^ "/" ^ host ^ "/key.pem",
d330d9b8	408	Config.trustStore)
	409
	410	val sock = OpenSSL.listen (context, Config.slavePort)
	411
	412	fun loop () =
	413	case OpenSSL.accept sock of
	414	NONE => ()
	415	\| SOME bio =>
	416	let
	417	val peer = OpenSSL.peerCN bio
	418	val () = print ("\nConnection from " ^ peer ^ "\n")
2569e66d	419	in
d330d9b8	420	if peer <> Config.dispatcherName then
	421	(print "Not authorized!\n";
	422	OpenSSL.close bio;
	423	loop ())
	424	else let
	425	fun loop' files =
	426	case Msg.recv bio of
	427	NONE => print "Dispatcher closed connection unexpectedly\n"
	428	\| SOME m =>
	429	case m of
	430	MsgFile file => loop' (file :: files)
	431	\| MsgDoFiles => (Slave.handleChanges files;
	432	Msg.send (bio, MsgOk))
	433	\| _ => (print "Dispatcher sent unexpected command\n";
	434	Msg.send (bio, MsgError "Unexpected command"))
	435	in
	436	loop' [];
	437	ignore (OpenSSL.readChar bio);
	438	OpenSSL.close bio;
	439	loop ()
	440	end
91c5a390	441	end handle OpenSSL.OpenSSL s =>
	442	(print ("OpenSSL error: "^ s ^ "\n");
	443	OpenSSL.close bio
	444	handle OpenSSL.OpenSSL _ => ();
	445	loop ())
1d2fd26b	446	\| OS.SysErr (s, _) =>
	447	(print ("System error: "^ s ^ "\n");
	448	OpenSSL.close bio
	449	handle OpenSSL.OpenSSL _ => ();
	450	loop ())
904eb905	451	in
2569e66d	452	loop ();
2569e66d	453	OpenSSL.shutdown sock
904eb905	454	end
904eb905	455
91c5a390	456	fun autodocBasis outdir =
	457	let
	458	val dir = Posix.FileSys.opendir Config.libRoot
	459
	460	fun loop files =
	461	case Posix.FileSys.readdir dir of
	462	NONE => (Posix.FileSys.closedir dir;
	463	files)
	464	\| SOME fname =>
	465	if String.isSuffix ".dtl" fname then
	466	loop (OS.Path.joinDirFile {dir = Config.libRoot,
	467	file = fname}
	468	:: files)
	469	else
	470	loop files
	471
	472	val files = loop []
	473	in
	474	Autodoc.autodoc {outdir = outdir, infiles = files}
	475	end
	476
e680130a	477	end