[hcoop/zz_old/domtool2-proto.git] / src / msg.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.
 *)

(* Network messages *)

structure Msg :> MSG = struct

open OpenSSL MsgTypes Slave

val a2i = fn Add => 0
	   | Delete => 1
	   | Modify => 2

val i2a = fn 0 => Add
	   | 1 => Delete
	   | 2 => Modify
	   | _ => raise OpenSSL.OpenSSL "Bad action number to deserialize"

fun sendAcl (bio, {user, class, value}) =
    (OpenSSL.writeString (bio, user);
     OpenSSL.writeString (bio, class);
     OpenSSL.writeString (bio, value))

fun recvAcl bio =
    case (OpenSSL.readString bio, OpenSSL.readString bio, OpenSSL.readString bio) of
	(SOME user, SOME class, SOME value) => SOME {user = user, class = class, value = value}
      | _ => NONE

fun sendList f (bio, ls) =
    (app (fn x =>
	     (OpenSSL.writeInt (bio, 1);
	      f (bio, x))) ls;
     OpenSSL.writeInt (bio, 0))

fun recvList f bio =
    let
	fun loop ls =
	    case OpenSSL.readInt bio of
		SOME 0 => SOME (rev ls)
	      | SOME 1 =>
		(case f bio of
		     SOME x => loop (x :: ls)
		   | NONE => NONE)
	      | _ => NONE
    in
	loop []
    end

fun sendOption f (bio, opt) =
    case opt of
	NONE => OpenSSL.writeInt (bio, 0)
      | SOME x => (OpenSSL.writeInt (bio, 1);
		   f (bio, x))

fun recvOption f bio =
    case OpenSSL.readInt bio of
	SOME 0 => SOME NONE
      | SOME 1 =>
	(case f bio of
	     SOME x => SOME (SOME x)
	   | NONE => NONE)
      | _ => NONE

fun send (bio, m) =
    case m of
	MsgOk => OpenSSL.writeInt (bio, 1)
      | MsgError s => (OpenSSL.writeInt (bio, 2);
		       OpenSSL.writeString (bio, s))
      | MsgConfig s => (OpenSSL.writeInt (bio, 3);
		       OpenSSL.writeString (bio, s))
      | MsgFile {action, domain, dir, file} =>
	(OpenSSL.writeInt (bio, 4);
	 OpenSSL.writeInt (bio, a2i action);
	 OpenSSL.writeString (bio, domain);
	 OpenSSL.writeString (bio, dir);
	 OpenSSL.writeString (bio, file))
      | MsgDoFiles => OpenSSL.writeInt (bio, 5)
      | MsgGrant acl => (OpenSSL.writeInt (bio, 6);
			 sendAcl (bio, acl))
      | MsgRevoke acl => (OpenSSL.writeInt (bio, 7);
			  sendAcl (bio, acl))
      | MsgListPerms user => (OpenSSL.writeInt (bio, 8);
			      OpenSSL.writeString (bio, user))
      | MsgPerms classes => (OpenSSL.writeInt (bio, 9);
			     sendList (fn (bio, (class, values)) =>
					  (OpenSSL.writeString (bio, class);
					   sendList OpenSSL.writeString (bio, values)))
				      (bio, classes))
      | MsgWhoHas {class, value} => (OpenSSL.writeInt (bio, 10);
				     OpenSSL.writeString (bio, class);
				     OpenSSL.writeString (bio, value))
      | MsgWhoHasResponse users => (OpenSSL.writeInt (bio, 11);
				    sendList OpenSSL.writeString (bio, users))
      | MsgMultiConfig codes => (OpenSSL.writeInt (bio, 12);
				 sendList OpenSSL.writeString (bio, codes))
      | MsgRmdom doms => (OpenSSL.writeInt (bio, 13);
			  sendList OpenSSL.writeString (bio, doms))
      | MsgRegenerate => OpenSSL.writeInt (bio, 14)
      | MsgRmuser dom => (OpenSSL.writeInt (bio, 15);
			  OpenSSL.writeString (bio, dom))
      | MsgCreateDbUser {dbtype, passwd} => (OpenSSL.writeInt (bio, 16);
					     OpenSSL.writeString (bio, dbtype);
					     sendOption OpenSSL.writeString (bio, passwd))
      | MsgCreateDbTable {dbtype, dbname} => (OpenSSL.writeInt (bio, 17);
					      OpenSSL.writeString (bio, dbtype);
					      OpenSSL.writeString (bio, dbname))
      | MsgNewMailbox {domain, user, passwd, mailbox} =>
	(OpenSSL.writeInt (bio, 18);
	 OpenSSL.writeString (bio, domain);
	 OpenSSL.writeString (bio, user);
	 OpenSSL.writeString (bio, passwd);
	 OpenSSL.writeString (bio, mailbox))
      | MsgPasswdMailbox {domain, user, passwd} =>
	(OpenSSL.writeInt (bio, 19);
	 OpenSSL.writeString (bio, domain);
	 OpenSSL.writeString (bio, user);
	 OpenSSL.writeString (bio, passwd))
      | MsgRmMailbox {domain, user} =>
	(OpenSSL.writeInt (bio, 20);
	 OpenSSL.writeString (bio, domain);
	 OpenSSL.writeString (bio, user))

fun checkIt v =
    case v of
	NONE => raise OpenSSL.OpenSSL "Bad Msg format"
      | _ => v

fun recv bio =
    case OpenSSL.readInt bio of
	NONE => NONE
      | SOME n =>
	checkIt (case n of
		     1 => SOME MsgOk
		   | 2 => Option.map MsgError (OpenSSL.readString bio)
		   | 3 => Option.map MsgConfig (OpenSSL.readString bio)
		   | 4 => (case (OpenSSL.readInt bio,
				 OpenSSL.readString bio,
				 OpenSSL.readString bio,
				 OpenSSL.readString bio) of
			       (SOME action, SOME domain, SOME dir, SOME file) =>
			       SOME (MsgFile {action = i2a action,
					      domain = domain,
					      dir = dir,
					      file = file})
			     | _ => NONE)
		   | 5 => SOME MsgDoFiles
		   | 6 => (case recvAcl bio of
			       SOME acl => SOME (MsgGrant acl)
			     | _ => NONE)
		   | 7 => (case recvAcl bio of
			       SOME acl => SOME (MsgRevoke acl)
			     | _ => NONE)
		   | 8 => (case OpenSSL.readString bio of
			       SOME user => SOME (MsgListPerms user)
			     | _ => NONE)
		   | 9 => Option.map MsgPerms
				     (recvList (fn bio =>
						   case (OpenSSL.readString bio,
							 recvList OpenSSL.readString bio) of
						       (SOME class, SOME values) => SOME (class, values)
						     | _ => NONE) bio)
		   | 10 => (case (OpenSSL.readString bio, OpenSSL.readString bio) of
				(SOME class, SOME value) => SOME (MsgWhoHas {class = class, value = value})
			      | _ => NONE)
		   | 11 => Option.map MsgWhoHasResponse
			   (recvList OpenSSL.readString bio)
		   | 12 => Option.map MsgMultiConfig
			   (recvList OpenSSL.readString bio)
		   | 13 => Option.map MsgRmdom (recvList OpenSSL.readString bio)
		   | 14 => SOME MsgRegenerate
		   | 15 => Option.map MsgRmuser (OpenSSL.readString bio)
		   | 16 => (case (OpenSSL.readString bio, recvOption OpenSSL.readString bio) of
				(SOME dbtype, SOME passwd) =>
				SOME (MsgCreateDbUser {dbtype = dbtype, passwd = passwd})
			      | _ => NONE)
		   | 17 => (case (OpenSSL.readString bio, OpenSSL.readString bio) of
				(SOME dbtype, SOME dbname) =>
				SOME (MsgCreateDbTable {dbtype = dbtype, dbname = dbname})
			      | _ => NONE)
		   | 18 => (case (OpenSSL.readString bio, OpenSSL.readString bio,
				  OpenSSL.readString bio, OpenSSL.readString bio) of
				(SOME domain, SOME user, SOME passwd, SOME mailbox) =>
				SOME (MsgNewMailbox {domain = domain, user = user,
						     passwd = passwd, mailbox = mailbox})
			      | _ => NONE)
		   | 19 => (case (OpenSSL.readString bio, OpenSSL.readString bio,
				  OpenSSL.readString bio) of
				(SOME domain, SOME user, SOME passwd) =>
				SOME (MsgPasswdMailbox {domain = domain, user = user,
							passwd = passwd})
			      | _ => NONE)
		   | 20 => (case (OpenSSL.readString bio, OpenSSL.readString bio) of
				(SOME domain, SOME user) =>
				SOME (MsgRmMailbox {domain = domain, user = user})
			      | _ => NONE)
		   | _ => NONE)
	 
end
Commit	Line	Data
d330d9b8	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.
	17	*)
	18
	19	(* Network messages *)
	20
	21	structure Msg :> MSG = struct
	22
	23	open OpenSSL MsgTypes Slave
	24
	25	val a2i = fn Add => 0
	26	\| Delete => 1
	27	\| Modify => 2
	28
	29	val i2a = fn 0 => Add
	30	\| 1 => Delete
	31	\| 2 => Modify
	32	\| _ => raise OpenSSL.OpenSSL "Bad action number to deserialize"
	33
e2130d9c	34	fun sendAcl (bio, {user, class, value}) =
	35	(OpenSSL.writeString (bio, user);
	36	OpenSSL.writeString (bio, class);
	37	OpenSSL.writeString (bio, value))
	38
	39	fun recvAcl bio =
	40	case (OpenSSL.readString bio, OpenSSL.readString bio, OpenSSL.readString bio) of
	41	(SOME user, SOME class, SOME value) => SOME {user = user, class = class, value = value}
	42	\| _ => NONE
	43
c8a739af	44	fun sendList f (bio, ls) =
	45	(app (fn x =>
	46	(OpenSSL.writeInt (bio, 1);
	47	f (bio, x))) ls;
	48	OpenSSL.writeInt (bio, 0))
	49
	50	fun recvList f bio =
	51	let
	52	fun loop ls =
	53	case OpenSSL.readInt bio of
	54	SOME 0 => SOME (rev ls)
	55	\| SOME 1 =>
	56	(case f bio of
	57	SOME x => loop (x :: ls)
	58	\| NONE => NONE)
	59	\| _ => NONE
	60	in
	61	loop []
	62	end
	63
2bc895e7	64	fun sendOption f (bio, opt) =
	65	case opt of
	66	NONE => OpenSSL.writeInt (bio, 0)
	67	\| SOME x => (OpenSSL.writeInt (bio, 1);
	68	f (bio, x))
	69
	70	fun recvOption f bio =
	71	case OpenSSL.readInt bio of
	72	SOME 0 => SOME NONE
	73	\| SOME 1 =>
	74	(case f bio of
	75	SOME x => SOME (SOME x)
	76	\| NONE => NONE)
	77	\| _ => NONE
	78
d330d9b8	79	fun send (bio, m) =
	80	case m of
	81	MsgOk => OpenSSL.writeInt (bio, 1)
	82	\| MsgError s => (OpenSSL.writeInt (bio, 2);
	83	OpenSSL.writeString (bio, s))
	84	\| MsgConfig s => (OpenSSL.writeInt (bio, 3);
	85	OpenSSL.writeString (bio, s))
	86	\| MsgFile {action, domain, dir, file} =>
	87	(OpenSSL.writeInt (bio, 4);
	88	OpenSSL.writeInt (bio, a2i action);
	89	OpenSSL.writeString (bio, domain);
	90	OpenSSL.writeString (bio, dir);
	91	OpenSSL.writeString (bio, file))
	92	\| MsgDoFiles => OpenSSL.writeInt (bio, 5)
e2130d9c	93	\| MsgGrant acl => (OpenSSL.writeInt (bio, 6);
e2130d9c	94	sendAcl (bio, acl))
d1aa6a21	95	\| MsgRevoke acl => (OpenSSL.writeInt (bio, 7);
d1aa6a21	96	sendAcl (bio, acl))
646381db	97	\| MsgListPerms user => (OpenSSL.writeInt (bio, 8);
	98	OpenSSL.writeString (bio, user))
	99	\| MsgPerms classes => (OpenSSL.writeInt (bio, 9);
c8a739af	100	sendList (fn (bio, (class, values)) =>
	101	(OpenSSL.writeString (bio, class);
	102	sendList OpenSSL.writeString (bio, values)))
	103	(bio, classes))
d0e75410	104	\| MsgWhoHas {class, value} => (OpenSSL.writeInt (bio, 10);
	105	OpenSSL.writeString (bio, class);
	106	OpenSSL.writeString (bio, value))
	107	\| MsgWhoHasResponse users => (OpenSSL.writeInt (bio, 11);
c8a739af	108	sendList OpenSSL.writeString (bio, users))
	109	\| MsgMultiConfig codes => (OpenSSL.writeInt (bio, 12);
	110	sendList OpenSSL.writeString (bio, codes))
aba1f07e	111	\| MsgRmdom doms => (OpenSSL.writeInt (bio, 13);
aba1f07e	112	sendList OpenSSL.writeString (bio, doms))
f92c6883	113	\| MsgRegenerate => OpenSSL.writeInt (bio, 14)
aba1f07e	114	\| MsgRmuser dom => (OpenSSL.writeInt (bio, 15);
aba1f07e	115	OpenSSL.writeString (bio, dom))
2bc895e7	116	\| MsgCreateDbUser {dbtype, passwd} => (OpenSSL.writeInt (bio, 16);
	117	OpenSSL.writeString (bio, dbtype);
	118	sendOption OpenSSL.writeString (bio, passwd))
d34cbcb8	119	\| MsgCreateDbTable {dbtype, dbname} => (OpenSSL.writeInt (bio, 17);
	120	OpenSSL.writeString (bio, dbtype);
	121	OpenSSL.writeString (bio, dbname))
c45f1662	122	\| MsgNewMailbox {domain, user, passwd, mailbox} =>
	123	(OpenSSL.writeInt (bio, 18);
	124	OpenSSL.writeString (bio, domain);
	125	OpenSSL.writeString (bio, user);
	126	OpenSSL.writeString (bio, passwd);
	127	OpenSSL.writeString (bio, mailbox))
	128	\| MsgPasswdMailbox {domain, user, passwd} =>
	129	(OpenSSL.writeInt (bio, 19);
	130	OpenSSL.writeString (bio, domain);
	131	OpenSSL.writeString (bio, user);
	132	OpenSSL.writeString (bio, passwd))
	133	\| MsgRmMailbox {domain, user} =>
	134	(OpenSSL.writeInt (bio, 20);
	135	OpenSSL.writeString (bio, domain);
	136	OpenSSL.writeString (bio, user))
d330d9b8	137
	138	fun checkIt v =
	139	case v of
	140	NONE => raise OpenSSL.OpenSSL "Bad Msg format"
	141	\| _ => v
	142
	143	fun recv bio =
	144	case OpenSSL.readInt bio of
	145	NONE => NONE
	146	\| SOME n =>
	147	checkIt (case n of
	148	1 => SOME MsgOk
	149	\| 2 => Option.map MsgError (OpenSSL.readString bio)
	150	\| 3 => Option.map MsgConfig (OpenSSL.readString bio)
	151	\| 4 => (case (OpenSSL.readInt bio,
	152	OpenSSL.readString bio,
	153	OpenSSL.readString bio,
	154	OpenSSL.readString bio) of
	155	(SOME action, SOME domain, SOME dir, SOME file) =>
	156	SOME (MsgFile {action = i2a action,
	157	domain = domain,
	158	dir = dir,
	159	file = file})
	160	\| _ => NONE)
	161	\| 5 => SOME MsgDoFiles
e2130d9c	162	\| 6 => (case recvAcl bio of
	163	SOME acl => SOME (MsgGrant acl)
	164	\| _ => NONE)
d1aa6a21	165	\| 7 => (case recvAcl bio of
	166	SOME acl => SOME (MsgRevoke acl)
	167	\| _ => NONE)
646381db	168	\| 8 => (case OpenSSL.readString bio of
	169	SOME user => SOME (MsgListPerms user)
	170	\| _ => NONE)
c8a739af	171	\| 9 => Option.map MsgPerms
	172	(recvList (fn bio =>
	173	case (OpenSSL.readString bio,
	174	recvList OpenSSL.readString bio) of
	175	(SOME class, SOME values) => SOME (class, values)
	176	\| _ => NONE) bio)
d0e75410	177	\| 10 => (case (OpenSSL.readString bio, OpenSSL.readString bio) of
	178	(SOME class, SOME value) => SOME (MsgWhoHas {class = class, value = value})
	179	\| _ => NONE)
c8a739af	180	\| 11 => Option.map MsgWhoHasResponse
	181	(recvList OpenSSL.readString bio)
	182	\| 12 => Option.map MsgMultiConfig
	183	(recvList OpenSSL.readString bio)
aba1f07e	184	\| 13 => Option.map MsgRmdom (recvList OpenSSL.readString bio)
f92c6883	185	\| 14 => SOME MsgRegenerate
aba1f07e	186	\| 15 => Option.map MsgRmuser (OpenSSL.readString bio)
2bc895e7	187	\| 16 => (case (OpenSSL.readString bio, recvOption OpenSSL.readString bio) of
	188	(SOME dbtype, SOME passwd) =>
	189	SOME (MsgCreateDbUser {dbtype = dbtype, passwd = passwd})
	190	\| _ => NONE)
d34cbcb8	191	\| 17 => (case (OpenSSL.readString bio, OpenSSL.readString bio) of
	192	(SOME dbtype, SOME dbname) =>
	193	SOME (MsgCreateDbTable {dbtype = dbtype, dbname = dbname})
	194	\| _ => NONE)
c45f1662	195	\| 18 => (case (OpenSSL.readString bio, OpenSSL.readString bio,
	196	OpenSSL.readString bio, OpenSSL.readString bio) of
	197	(SOME domain, SOME user, SOME passwd, SOME mailbox) =>
	198	SOME (MsgNewMailbox {domain = domain, user = user,
	199	passwd = passwd, mailbox = mailbox})
	200	\| _ => NONE)
	201	\| 19 => (case (OpenSSL.readString bio, OpenSSL.readString bio,
	202	OpenSSL.readString bio) of
	203	(SOME domain, SOME user, SOME passwd) =>
	204	SOME (MsgPasswdMailbox {domain = domain, user = user,
	205	passwd = passwd})
	206	\| _ => NONE)
	207	\| 20 => (case (OpenSSL.readString bio, OpenSSL.readString bio) of
	208	(SOME domain, SOME user) =>
	209	SOME (MsgRmMailbox {domain = domain, user = user})
	210	\| _ => NONE)
d330d9b8	211	\| _ => NONE)
	212
	213	end