1 (* HCoop
Domtool (http
://hcoop
.sourceforge
.net
/)
2 * Copyright (c
) 2006, Adam Chlipala
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
.
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
.
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
.
19 (* Network messages
*)
21 structure Msg
:> MSG
= struct
23 open OpenSSL MsgTypes Slave
32 | _
=> raise OpenSSL
.OpenSSL
"Bad action number to deserialize"
34 fun sendAcl (bio
, {user
, class
, value
}) =
35 (OpenSSL
.writeString (bio
, user
);
36 OpenSSL
.writeString (bio
, class
);
37 OpenSSL
.writeString (bio
, value
))
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
}
44 fun sendList
f (bio
, ls
) =
46 (OpenSSL
.writeInt (bio
, 1);
48 OpenSSL
.writeInt (bio
, 0))
53 case OpenSSL
.readInt bio
of
54 SOME
0 => SOME (rev ls
)
57 SOME x
=> loop (x
:: ls
)
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);
80 | MsgRevoke acl
=> (OpenSSL
.writeInt (bio
, 7);
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
)))
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 doms
=> (OpenSSL
.writeInt (bio
, 13);
97 sendList OpenSSL
.writeString (bio
, doms
))
98 | MsgRegenerate
=> OpenSSL
.writeInt (bio
, 14)
99 | MsgRmuser dom
=> (OpenSSL
.writeInt (bio
, 15);
100 OpenSSL
.writeString (bio
, dom
))
101 | MsgCreateDbUser s
=> (OpenSSL
.writeInt (bio
, 16);
102 OpenSSL
.writeString (bio
, s
))
103 | MsgCreateDbTable
{dbtype
, dbname
} => (OpenSSL
.writeInt (bio
, 17);
104 OpenSSL
.writeString (bio
, dbtype
);
105 OpenSSL
.writeString (bio
, dbname
))
109 NONE
=> raise OpenSSL
.OpenSSL
"Bad Msg format"
113 case OpenSSL
.readInt bio
of
118 |
2 => Option
.map
MsgError (OpenSSL
.readString bio
)
119 |
3 => Option
.map
MsgConfig (OpenSSL
.readString bio
)
120 |
4 => (case (OpenSSL
.readInt bio
,
121 OpenSSL
.readString bio
,
122 OpenSSL
.readString bio
,
123 OpenSSL
.readString bio
) of
124 (SOME action
, SOME domain
, SOME dir
, SOME file
) =>
125 SOME (MsgFile
{action
= i2a action
,
130 |
5 => SOME MsgDoFiles
131 |
6 => (case recvAcl bio
of
132 SOME acl
=> SOME (MsgGrant acl
)
134 |
7 => (case recvAcl bio
of
135 SOME acl
=> SOME (MsgRevoke acl
)
137 |
8 => (case OpenSSL
.readString bio
of
138 SOME user
=> SOME (MsgListPerms user
)
140 |
9 => Option
.map MsgPerms
142 case (OpenSSL
.readString bio
,
143 recvList OpenSSL
.readString bio
) of
144 (SOME class
, SOME values
) => SOME (class
, values
)
146 |
10 => (case (OpenSSL
.readString bio
, OpenSSL
.readString bio
) of
147 (SOME class
, SOME value
) => SOME (MsgWhoHas
{class
= class
, value
= value
})
149 |
11 => Option
.map MsgWhoHasResponse
150 (recvList OpenSSL
.readString bio
)
151 |
12 => Option
.map MsgMultiConfig
152 (recvList OpenSSL
.readString bio
)
153 |
13 => Option
.map
MsgRmdom (recvList OpenSSL
.readString bio
)
154 |
14 => SOME MsgRegenerate
155 |
15 => Option
.map
MsgRmuser (OpenSSL
.readString bio
)
156 |
16 => Option
.map
MsgCreateDbUser (OpenSSL
.readString bio
)
157 |
17 => (case (OpenSSL
.readString bio
, OpenSSL
.readString bio
) of
158 (SOME dbtype
, SOME dbname
) =>
159 SOME (MsgCreateDbTable
{dbtype
= dbtype
, dbname
= dbname
})