Fix problem noted by omry on original domtool; namely, bad handling of rewrites insid...
[hcoop/domtool2.git] / src / msg.sml
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
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
44 fun send (bio, m) =
45 case m of
46 MsgOk => OpenSSL.writeInt (bio, 1)
47 | MsgError s => (OpenSSL.writeInt (bio, 2);
48 OpenSSL.writeString (bio, s))
49 | MsgConfig s => (OpenSSL.writeInt (bio, 3);
50 OpenSSL.writeString (bio, s))
51 | MsgFile {action, domain, dir, file} =>
52 (OpenSSL.writeInt (bio, 4);
53 OpenSSL.writeInt (bio, a2i action);
54 OpenSSL.writeString (bio, domain);
55 OpenSSL.writeString (bio, dir);
56 OpenSSL.writeString (bio, file))
57 | MsgDoFiles => OpenSSL.writeInt (bio, 5)
58 | MsgGrant acl => (OpenSSL.writeInt (bio, 6);
59 sendAcl (bio, acl))
60 | MsgRevoke acl => (OpenSSL.writeInt (bio, 7);
61 sendAcl (bio, acl))
62 | MsgListPerms user => (OpenSSL.writeInt (bio, 8);
63 OpenSSL.writeString (bio, user))
64 | MsgPerms classes => (OpenSSL.writeInt (bio, 9);
65 app (fn (class, values) =>
66 (OpenSSL.writeInt (bio, 1);
67 OpenSSL.writeString (bio, class);
68 app (fn value =>
69 (OpenSSL.writeInt (bio, 1);
70 OpenSSL.writeString (bio, value))) values;
71 OpenSSL.writeInt (bio, 0))) classes;
72 OpenSSL.writeInt (bio, 0))
73 | MsgWhoHas {class, value} => (OpenSSL.writeInt (bio, 10);
74 OpenSSL.writeString (bio, class);
75 OpenSSL.writeString (bio, value))
76 | MsgWhoHasResponse users => (OpenSSL.writeInt (bio, 11);
77 app (fn user =>
78 (OpenSSL.writeInt (bio, 1);
79 OpenSSL.writeString (bio, user))) users;
80 OpenSSL.writeInt (bio, 0))
81
82 fun checkIt v =
83 case v of
84 NONE => raise OpenSSL.OpenSSL "Bad Msg format"
85 | _ => v
86
87 fun recv bio =
88 case OpenSSL.readInt bio of
89 NONE => NONE
90 | SOME n =>
91 checkIt (case n of
92 1 => SOME MsgOk
93 | 2 => Option.map MsgError (OpenSSL.readString bio)
94 | 3 => Option.map MsgConfig (OpenSSL.readString bio)
95 | 4 => (case (OpenSSL.readInt bio,
96 OpenSSL.readString bio,
97 OpenSSL.readString bio,
98 OpenSSL.readString bio) of
99 (SOME action, SOME domain, SOME dir, SOME file) =>
100 SOME (MsgFile {action = i2a action,
101 domain = domain,
102 dir = dir,
103 file = file})
104 | _ => NONE)
105 | 5 => SOME MsgDoFiles
106 | 6 => (case recvAcl bio of
107 SOME acl => SOME (MsgGrant acl)
108 | _ => NONE)
109 | 7 => (case recvAcl bio of
110 SOME acl => SOME (MsgRevoke acl)
111 | _ => NONE)
112 | 8 => (case OpenSSL.readString bio of
113 SOME user => SOME (MsgListPerms user)
114 | _ => NONE)
115 | 9 => let
116 fun loop classes =
117 case OpenSSL.readInt bio of
118 SOME 0 => SOME (MsgPerms (rev classes))
119 | SOME 1 =>
120 (case OpenSSL.readString bio of
121 SOME class =>
122 let
123 fun loop' values =
124 case OpenSSL.readInt bio of
125 SOME 0 => loop ((class, rev values) :: classes)
126 | SOME 1 =>
127 (case OpenSSL.readString bio of
128 SOME value => loop' (value :: values)
129 | NONE => NONE)
130 | _ => NONE
131 in
132 loop' []
133 end
134 | NONE => NONE)
135 | _ => NONE
136 in
137 loop []
138 end
139 | 10 => (case (OpenSSL.readString bio, OpenSSL.readString bio) of
140 (SOME class, SOME value) => SOME (MsgWhoHas {class = class, value = value})
141 | _ => NONE)
142 | 11 => let
143 fun loop users =
144 case OpenSSL.readInt bio of
145 SOME 0 => SOME (MsgWhoHasResponse (rev users))
146 | SOME 1 =>
147 (case OpenSSL.readString bio of
148 SOME user => loop (user :: users)
149 | NONE => NONE)
150 | _ => NONE
151 in
152 loop []
153 end
154 | _ => NONE)
155
156 end