Privilege setting code
[hcoop/domtool2.git] / src / main.sml
CommitLineData
234b917a
AC
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.
dac62e84 17 *)
234b917a
AC
18
19(* Main interface *)
20
21structure Main :> MAIN = struct
22
36e42cb8 23open Ast MsgTypes Print
234b917a 24
6ae327f8
AC
25structure SM = StringMap
26
aa56e112 27fun init () = Acl.read Config.aclFile
234b917a 28
d189ec0e 29fun check' G fname =
a3698041
AC
30 let
31 val prog = Parse.parse fname
32 in
33 if !ErrorMsg.anyErrors then
d189ec0e 34 G
a3698041 35 else
aa56e112 36 Tycheck.checkFile G (Defaults.tInit ()) prog
a3698041
AC
37 end
38
d189ec0e 39fun basis () =
234b917a 40 let
d189ec0e
AC
41 val dir = Posix.FileSys.opendir Config.libRoot
42
43 fun loop files =
44 case Posix.FileSys.readdir dir of
d612d62c
AC
45 NONE => (Posix.FileSys.closedir dir;
46 files)
d189ec0e
AC
47 | SOME fname =>
48 if String.isSuffix ".dtl" fname then
d612d62c
AC
49 loop (OS.Path.joinDirFile {dir = Config.libRoot,
50 file = fname}
d189ec0e
AC
51 :: files)
52 else
53 loop files
54
55 val files = loop []
3196000d 56 val (_, files) = Order.order files
d189ec0e 57 in
6ae327f8
AC
58 if !ErrorMsg.anyErrors then
59 Env.empty
60 else
b3159a70
AC
61 (Tycheck.allowExterns ();
62 foldl (fn (fname, G) => check' G fname) Env.empty files
63 before Tycheck.disallowExterns ())
d189ec0e
AC
64 end
65
66fun check fname =
67 let
68 val _ = ErrorMsg.reset ()
12adf55a 69 val _ = Env.preTycheck ()
d189ec0e
AC
70
71 val b = basis ()
234b917a
AC
72 in
73 if !ErrorMsg.anyErrors then
36e42cb8 74 raise ErrorMsg.Error
234b917a
AC
75 else
76 let
b3159a70 77 val _ = Tycheck.disallowExterns ()
7f012ffd 78 val _ = ErrorMsg.reset ()
d189ec0e 79 val prog = Parse.parse fname
234b917a 80 in
492c1cff 81 if !ErrorMsg.anyErrors then
36e42cb8 82 raise ErrorMsg.Error
492c1cff 83 else
d189ec0e 84 let
aa56e112 85 val G' = Tycheck.checkFile b (Defaults.tInit ()) prog
d189ec0e 86 in
36e42cb8
AC
87 if !ErrorMsg.anyErrors then
88 raise ErrorMsg.Error
89 else
90 (G', #3 prog)
d189ec0e 91 end
234b917a
AC
92 end
93 end
94
d189ec0e 95fun reduce fname =
a3698041 96 let
d189ec0e 97 val (G, body) = check fname
a3698041
AC
98 in
99 if !ErrorMsg.anyErrors then
d189ec0e 100 NONE
a3698041 101 else
d189ec0e
AC
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
a3698041
AC
114 end
115
d189ec0e
AC
116fun eval fname =
117 case reduce fname of
118 (SOME body') =>
119 if !ErrorMsg.anyErrors then
36e42cb8 120 raise ErrorMsg.Error
d189ec0e 121 else
aa56e112 122 Eval.exec (Defaults.eInit ()) body'
36e42cb8 123 | NONE => raise ErrorMsg.Error
d189ec0e 124
3b267643
AC
125val dispatcher =
126 Config.dispatcher ^ ":" ^ Int.toString Config.dispatcherPort
559e89e9 127
5ee41dd0 128fun requestContext f =
07cc384c 129 let
a56cc2c3
AC
130 val uid = Posix.ProcEnv.getuid ()
131 val user = Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid uid)
5ee41dd0 132
a56cc2c3
AC
133 val () = Acl.read Config.aclFile
134 val () = Domain.setUser user
5ee41dd0
AC
135
136 val () = f ()
aa56e112 137
aa56e112 138 val context = OpenSSL.context (Config.certDir ^ "/" ^ user ^ ".pem",
a088cea6 139 Config.keyDir ^ "/" ^ user ^ "/key.pem",
3b267643 140 Config.trustStore)
5ee41dd0
AC
141 in
142 (user, context)
143 end
07cc384c 144
5ee41dd0
AC
145fun requestBio f =
146 let
147 val (user, context) = requestContext f
148 in
149 (user, OpenSSL.connect (context, dispatcher))
150 end
151
152fun request fname =
153 let
154 val (user, bio) = requestBio (fn () => ignore (check fname))
559e89e9 155
3b267643
AC
156 val inf = TextIO.openIn fname
157
36e42cb8 158 fun loop lines =
3b267643 159 case TextIO.inputLine inf of
36e42cb8
AC
160 NONE => String.concat (List.rev lines)
161 | SOME line => loop (line :: lines)
162
163 val code = loop []
559e89e9 164 in
3b267643 165 TextIO.closeIn inf;
36e42cb8
AC
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";
3b267643 174 OpenSSL.close bio
559e89e9 175 end
aa56e112 176 handle ErrorMsg.Error => ()
559e89e9 177
5ee41dd0
AC
178fun 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
3b267643 193fun service () =
07cc384c 194 let
aa56e112
AC
195 val () = Acl.read Config.aclFile
196
3b267643
AC
197 val context = OpenSSL.context (Config.serverCert,
198 Config.serverKey,
199 Config.trustStore)
36e42cb8 200 val _ = Domain.set_context context
3b267643 201
60534712 202 val sock = OpenSSL.listen (context, Config.dispatcherPort)
3b267643
AC
203
204 fun loop () =
60534712 205 case OpenSSL.accept sock of
3b267643
AC
206 NONE => ()
207 | SOME bio =>
208 let
aa56e112
AC
209 val user = OpenSSL.peerCN bio
210 val () = print ("\nConnection from " ^ user ^ "\n")
211 val () = Domain.setUser user
212
36e42cb8
AC
213 fun cmdLoop () =
214 case Msg.recv bio of
215 NONE => (OpenSSL.close bio
216 handle OpenSSL.OpenSSL _ => ();
217 loop ())
218 | SOME m =>
219 case m of
220 MsgConfig code =>
221 let
222 val _ = print "Configuration:\n"
223 val _ = print code
224 val _ = print "\n"
3b267643 225
36e42cb8
AC
226 val outname = OS.FileSys.tmpName ()
227 val outf = TextIO.openOut outname
228 in
229 TextIO.output (outf, code);
230 TextIO.closeOut outf;
231 (eval outname;
232 Msg.send (bio, MsgOk))
97665758
AC
233 handle ErrorMsg.Error =>
234 (print "Compilation error\n";
235 Msg.send (bio,
236 MsgError "Error during configuration evaluation"))
237 | OpenSSL.OpenSSL s =>
238 (print "OpenSSL error\n";
239 Msg.send (bio,
240 MsgError
241 ("Error during configuration evaluation: "
242 ^ s)));
5ee41dd0
AC
243 OS.FileSys.remove outname;
244 (ignore (OpenSSL.readChar bio);
245 OpenSSL.close bio)
246 handle OpenSSL.OpenSSL _ => ();
247 loop ()
36e42cb8 248 end
5ee41dd0
AC
249
250 | MsgGrant acl =>
251 if Acl.query {user = user, class = "group", value = "root"} then
252 ((Acl.grant acl;
253 Acl.write Config.aclFile;
254 Msg.send (bio, MsgOk))
255 handle OpenSSL.OpenSSL s =>
256 (print "OpenSSL error\n";
257 Msg.send (bio,
258 MsgError
259 ("Error during granting: "
260 ^ s)));
261 (ignore (OpenSSL.readChar bio);
262 OpenSSL.close bio)
263 handle OpenSSL.OpenSSL _ => ();
264 loop ())
265 else
266 ((Msg.send (bio, MsgError "Not authorized to grant privileges");
267 ignore (OpenSSL.readChar bio);
268 OpenSSL.close bio)
269 handle OpenSSL.OpenSSL _ => ();
270 loop ())
271
36e42cb8
AC
272 | _ =>
273 (Msg.send (bio, MsgError "Unexpected command")
274 handle OpenSSL.OpenSSL _ => ();
275 OpenSSL.close bio
276 handle OpenSSL.OpenSSL _ => ();
277 loop ())
278 in
279 cmdLoop ()
280 end
97665758
AC
281 handle OpenSSL.OpenSSL s =>
282 (print ("OpenSSL error: " ^ s ^ "\n");
283 OpenSSL.close bio
284 handle OpenSSL.OpenSSL _ => ();
285 loop ())
286 | OS.SysErr (s, _) =>
287 (print ("System error: " ^ s ^ "\n");
288 OpenSSL.close bio
289 handle OpenSSL.OpenSSL _ => ();
290 loop ())
36e42cb8 291 in
361a1e7f 292 print "Listening for connections....\n";
36e42cb8
AC
293 loop ();
294 OpenSSL.shutdown sock
295 end
296
297fun slave () =
298 let
6e62228d 299 val host = Slave.hostname ()
36e42cb8
AC
300
301 val context = OpenSSL.context (Config.certDir ^ "/" ^ host ^ ".pem",
a088cea6 302 Config.keyDir ^ "/" ^ host ^ "/key.pem",
36e42cb8
AC
303 Config.trustStore)
304
305 val sock = OpenSSL.listen (context, Config.slavePort)
306
307 fun loop () =
308 case OpenSSL.accept sock of
309 NONE => ()
310 | SOME bio =>
311 let
312 val peer = OpenSSL.peerCN bio
313 val () = print ("\nConnection from " ^ peer ^ "\n")
3b267643 314 in
36e42cb8
AC
315 if peer <> Config.dispatcherName then
316 (print "Not authorized!\n";
317 OpenSSL.close bio;
318 loop ())
319 else let
320 fun loop' files =
321 case Msg.recv bio of
322 NONE => print "Dispatcher closed connection unexpectedly\n"
323 | SOME m =>
324 case m of
325 MsgFile file => loop' (file :: files)
326 | MsgDoFiles => (Slave.handleChanges files;
327 Msg.send (bio, MsgOk))
328 | _ => (print "Dispatcher sent unexpected command\n";
329 Msg.send (bio, MsgError "Unexpected command"))
330 in
331 loop' [];
332 ignore (OpenSSL.readChar bio);
333 OpenSSL.close bio;
334 loop ()
335 end
3196000d
AC
336 end handle OpenSSL.OpenSSL s =>
337 (print ("OpenSSL error: "^ s ^ "\n");
338 OpenSSL.close bio
339 handle OpenSSL.OpenSSL _ => ();
340 loop ())
7af7d4cb
AC
341 | OS.SysErr (s, _) =>
342 (print ("System error: "^ s ^ "\n");
343 OpenSSL.close bio
344 handle OpenSSL.OpenSSL _ => ();
345 loop ())
07cc384c 346 in
3b267643
AC
347 loop ();
348 OpenSSL.shutdown sock
07cc384c
AC
349 end
350
3196000d
AC
351fun autodocBasis outdir =
352 let
353 val dir = Posix.FileSys.opendir Config.libRoot
354
355 fun loop files =
356 case Posix.FileSys.readdir dir of
357 NONE => (Posix.FileSys.closedir dir;
358 files)
359 | SOME fname =>
360 if String.isSuffix ".dtl" fname then
361 loop (OS.Path.joinDirFile {dir = Config.libRoot,
362 file = fname}
363 :: files)
364 else
365 loop files
366
367 val files = loop []
368 in
369 Autodoc.autodoc {outdir = outdir, infiles = files}
370 end
371
234b917a 372end