Fix file paths for recursive rmdom
[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 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
64 fun send (bio, m) =
65 case m of
66 MsgOk => OpenSSL.writeInt (bio, 1)
67 | MsgError s => (OpenSSL.writeInt (bio, 2);
68 OpenSSL.writeString (bio, s))
69 | MsgConfig s => (OpenSSL.writeInt (bio, 3);
70 OpenSSL.writeString (bio, s))
71 | MsgFile {action, domain, dir, file} =>
72 (OpenSSL.writeInt (bio, 4);
73 OpenSSL.writeInt (bio, a2i action);
74 OpenSSL.writeString (bio, domain);
75 OpenSSL.writeString (bio, dir);
76 OpenSSL.writeString (bio, file))
77 | MsgDoFiles => OpenSSL.writeInt (bio, 5)
78 | MsgGrant acl => (OpenSSL.writeInt (bio, 6);
79 sendAcl (bio, acl))
80 | MsgRevoke acl => (OpenSSL.writeInt (bio, 7);
81 sendAcl (bio, acl))
82 | MsgListPerms user => (OpenSSL.writeInt (bio, 8);
83 OpenSSL.writeString (bio, user))
84 | MsgPerms classes => (OpenSSL.writeInt (bio, 9);
85 sendList (fn (bio, (class, values)) =>
86 (OpenSSL.writeString (bio, class);
87 sendList OpenSSL.writeString (bio, values)))
88 (bio, classes))
89 | MsgWhoHas {class, value} => (OpenSSL.writeInt (bio, 10);
90 OpenSSL.writeString (bio, class);
91 OpenSSL.writeString (bio, value))
92 | MsgWhoHasResponse users => (OpenSSL.writeInt (bio, 11);
93 sendList OpenSSL.writeString (bio, users))
94 | MsgMultiConfig codes => (OpenSSL.writeInt (bio, 12);
95 sendList OpenSSL.writeString (bio, codes))
96 | MsgRmdom dom => (OpenSSL.writeInt (bio, 13);
97 OpenSSL.writeString (bio, dom))
98 | MsgRegenerate => OpenSSL.writeInt (bio, 14)
99
100 fun checkIt v =
101 case v of
102 NONE => raise OpenSSL.OpenSSL "Bad Msg format"
103 | _ => v
104
105 fun recv bio =
106 case OpenSSL.readInt bio of
107 NONE => NONE
108 | SOME n =>
109 checkIt (case n of
110 1 => SOME MsgOk
111 | 2 => Option.map MsgError (OpenSSL.readString bio)
112 | 3 => Option.map MsgConfig (OpenSSL.readString bio)
113 | 4 => (case (OpenSSL.readInt bio,
114 OpenSSL.readString bio,
115 OpenSSL.readString bio,
116 OpenSSL.readString bio) of
117 (SOME action, SOME domain, SOME dir, SOME file) =>
118 SOME (MsgFile {action = i2a action,
119 domain = domain,
120 dir = dir,
121 file = file})
122 | _ => NONE)
123 | 5 => SOME MsgDoFiles
124 | 6 => (case recvAcl bio of
125 SOME acl => SOME (MsgGrant acl)
126 | _ => NONE)
127 | 7 => (case recvAcl bio of
128 SOME acl => SOME (MsgRevoke acl)
129 | _ => NONE)
130 | 8 => (case OpenSSL.readString bio of
131 SOME user => SOME (MsgListPerms user)
132 | _ => NONE)
133 | 9 => Option.map MsgPerms
134 (recvList (fn bio =>
135 case (OpenSSL.readString bio,
136 recvList OpenSSL.readString bio) of
137 (SOME class, SOME values) => SOME (class, values)
138 | _ => NONE) bio)
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 => Option.map MsgWhoHasResponse
143 (recvList OpenSSL.readString bio)
144 | 12 => Option.map MsgMultiConfig
145 (recvList OpenSSL.readString bio)
146 | 13 => Option.map MsgRmdom (OpenSSL.readString bio)
147 | 14 => SOME MsgRegenerate
148 | _ => NONE)
149
150 end