whohas
[hcoop/domtool2.git] / src / main.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 (* Main interface *)
20
21 structure Main :> MAIN = struct
22
23 open Ast MsgTypes Print
24
25 structure SM = StringMap
26
27 fun init () = Acl.read Config.aclFile
28
29 fun check' G fname =
30 let
31 val prog = Parse.parse fname
32 in
33 if !ErrorMsg.anyErrors then
34 G
35 else
36 Tycheck.checkFile G (Defaults.tInit ()) prog
37 end
38
39 fun basis () =
40 let
41 val dir = Posix.FileSys.opendir Config.libRoot
42
43 fun loop files =
44 case Posix.FileSys.readdir dir of
45 NONE => (Posix.FileSys.closedir dir;
46 files)
47 | SOME fname =>
48 if String.isSuffix ".dtl" fname then
49 loop (OS.Path.joinDirFile {dir = Config.libRoot,
50 file = fname}
51 :: files)
52 else
53 loop files
54
55 val files = loop []
56 val (_, files) = Order.order files
57 in
58 if !ErrorMsg.anyErrors then
59 Env.empty
60 else
61 (Tycheck.allowExterns ();
62 foldl (fn (fname, G) => check' G fname) Env.empty files
63 before Tycheck.disallowExterns ())
64 end
65
66 fun check fname =
67 let
68 val _ = ErrorMsg.reset ()
69 val _ = Env.preTycheck ()
70
71 val b = basis ()
72 in
73 if !ErrorMsg.anyErrors then
74 raise ErrorMsg.Error
75 else
76 let
77 val _ = Tycheck.disallowExterns ()
78 val _ = ErrorMsg.reset ()
79 val prog = Parse.parse fname
80 in
81 if !ErrorMsg.anyErrors then
82 raise ErrorMsg.Error
83 else
84 let
85 val G' = Tycheck.checkFile b (Defaults.tInit ()) prog
86 in
87 if !ErrorMsg.anyErrors then
88 raise ErrorMsg.Error
89 else
90 (G', #3 prog)
91 end
92 end
93 end
94
95 fun reduce fname =
96 let
97 val (G, body) = check fname
98 in
99 if !ErrorMsg.anyErrors then
100 NONE
101 else
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
114 end
115
116 fun eval fname =
117 case reduce fname of
118 (SOME body') =>
119 if !ErrorMsg.anyErrors then
120 raise ErrorMsg.Error
121 else
122 Eval.exec (Defaults.eInit ()) body'
123 | NONE => raise ErrorMsg.Error
124
125 val dispatcher =
126 Config.dispatcher ^ ":" ^ Int.toString Config.dispatcherPort
127
128 fun requestContext f =
129 let
130 val uid = Posix.ProcEnv.getuid ()
131 val user = Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid uid)
132
133 val () = Acl.read Config.aclFile
134 val () = Domain.setUser user
135
136 val () = f ()
137
138 val context = OpenSSL.context (Config.certDir ^ "/" ^ user ^ ".pem",
139 Config.keyDir ^ "/" ^ user ^ "/key.pem",
140 Config.trustStore)
141 in
142 (user, context)
143 end
144
145 fun requestBio f =
146 let
147 val (user, context) = requestContext f
148 in
149 (user, OpenSSL.connect (context, dispatcher))
150 end
151
152 fun request fname =
153 let
154 val (user, bio) = requestBio (fn () => ignore (check fname))
155
156 val inf = TextIO.openIn fname
157
158 fun loop lines =
159 case TextIO.inputLine inf of
160 NONE => String.concat (List.rev lines)
161 | SOME line => loop (line :: lines)
162
163 val code = loop []
164 in
165 TextIO.closeIn inf;
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";
174 OpenSSL.close bio
175 end
176 handle ErrorMsg.Error => ()
177
178 fun 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
193 fun requestRevoke acl =
194 let
195 val (user, bio) = requestBio (fn () => ())
196 in
197 Msg.send (bio, MsgRevoke acl);
198 case Msg.recv bio of
199 NONE => print "Server closed connection unexpectedly.\n"
200 | SOME m =>
201 case m of
202 MsgOk => print "Revoke succeeded.\n"
203 | MsgError s => print ("Revoke failed: " ^ s ^ "\n")
204 | _ => print "Unexpected server reply.\n";
205 OpenSSL.close bio
206 end
207
208 fun requestListPerms user =
209 let
210 val (_, bio) = requestBio (fn () => ())
211 in
212 Msg.send (bio, MsgListPerms user);
213 (case Msg.recv bio of
214 NONE => (print "Server closed connection unexpectedly.\n";
215 NONE)
216 | SOME m =>
217 case m of
218 MsgPerms perms => SOME perms
219 | MsgError s => (print ("Listing failed: " ^ s ^ "\n");
220 NONE)
221 | _ => (print "Unexpected server reply.\n";
222 NONE))
223 before OpenSSL.close bio
224 end
225
226 fun requestWhoHas perm =
227 let
228 val (_, bio) = requestBio (fn () => ())
229 in
230 Msg.send (bio, MsgWhoHas perm);
231 (case Msg.recv bio of
232 NONE => (print "Server closed connection unexpectedly.\n";
233 NONE)
234 | SOME m =>
235 case m of
236 MsgWhoHasResponse users => SOME users
237 | MsgError s => (print ("whohas failed: " ^ s ^ "\n");
238 NONE)
239 | _ => (print "Unexpected server reply.\n";
240 NONE))
241 before OpenSSL.close bio
242 end
243
244 fun service () =
245 let
246 val () = Acl.read Config.aclFile
247
248 val context = OpenSSL.context (Config.serverCert,
249 Config.serverKey,
250 Config.trustStore)
251 val _ = Domain.set_context context
252
253 val sock = OpenSSL.listen (context, Config.dispatcherPort)
254
255 fun loop () =
256 case OpenSSL.accept sock of
257 NONE => ()
258 | SOME bio =>
259 let
260 val user = OpenSSL.peerCN bio
261 val () = print ("\nConnection from " ^ user ^ "\n")
262 val () = Domain.setUser user
263
264 fun cmdLoop () =
265 case Msg.recv bio of
266 NONE => (OpenSSL.close bio
267 handle OpenSSL.OpenSSL _ => ();
268 loop ())
269 | SOME m =>
270 case m of
271 MsgConfig code =>
272 let
273 val _ = print "Configuration:\n"
274 val _ = print code
275 val _ = print "\n"
276
277 val outname = OS.FileSys.tmpName ()
278 val outf = TextIO.openOut outname
279 in
280 TextIO.output (outf, code);
281 TextIO.closeOut outf;
282 (eval outname;
283 Msg.send (bio, MsgOk))
284 handle ErrorMsg.Error =>
285 (print "Compilation error\n";
286 Msg.send (bio,
287 MsgError "Error during configuration evaluation"))
288 | OpenSSL.OpenSSL s =>
289 (print "OpenSSL error\n";
290 Msg.send (bio,
291 MsgError
292 ("Error during configuration evaluation: "
293 ^ s)));
294 OS.FileSys.remove outname;
295 (ignore (OpenSSL.readChar bio);
296 OpenSSL.close bio)
297 handle OpenSSL.OpenSSL _ => ();
298 loop ()
299 end
300
301 | MsgGrant acl =>
302 if Acl.query {user = user, class = "group", value = "root"} then
303 ((Acl.grant acl;
304 Acl.write Config.aclFile;
305 Msg.send (bio, MsgOk);
306 print ("Granted permission " ^ #value acl ^ " to " ^ #user acl ^ " in " ^ #class acl ^ ".\n"))
307 handle OpenSSL.OpenSSL s =>
308 (print "OpenSSL error\n";
309 Msg.send (bio,
310 MsgError
311 ("Error during granting: "
312 ^ s)));
313 (ignore (OpenSSL.readChar bio);
314 OpenSSL.close bio)
315 handle OpenSSL.OpenSSL _ => ();
316 loop ())
317 else
318 ((Msg.send (bio, MsgError "Not authorized to grant privileges");
319 print "Unauthorized user asked to grant a permission!\n";
320 ignore (OpenSSL.readChar bio);
321 OpenSSL.close bio)
322 handle OpenSSL.OpenSSL _ => ();
323 loop ())
324
325 | MsgRevoke acl =>
326 if Acl.query {user = user, class = "group", value = "root"} then
327 ((Acl.revoke acl;
328 Acl.write Config.aclFile;
329 Msg.send (bio, MsgOk);
330 print ("Revoked permission " ^ #value acl ^ " from " ^ #user acl ^ " in " ^ #class acl ^ ".\n"))
331 handle OpenSSL.OpenSSL s =>
332 (print "OpenSSL error\n";
333 Msg.send (bio,
334 MsgError
335 ("Error during revocation: "
336 ^ s)));
337 (ignore (OpenSSL.readChar bio);
338 OpenSSL.close bio)
339 handle OpenSSL.OpenSSL _ => ();
340 loop ())
341 else
342 ((Msg.send (bio, MsgError "Not authorized to revoke privileges");
343 print "Unauthorized user asked to revoke a permission!\n";
344 ignore (OpenSSL.readChar bio);
345 OpenSSL.close bio)
346 handle OpenSSL.OpenSSL _ => ();
347 loop ())
348
349 | MsgListPerms user =>
350 ((Msg.send (bio, MsgPerms (Acl.queryAll user));
351 print ("Sent permission list for user " ^ user ^ ".\n"))
352 handle OpenSSL.OpenSSL s =>
353 (print "OpenSSL error\n";
354 Msg.send (bio,
355 MsgError
356 ("Error during permission listing: "
357 ^ s)));
358 (ignore (OpenSSL.readChar bio);
359 OpenSSL.close bio)
360 handle OpenSSL.OpenSSL _ => ();
361 loop ())
362
363 | MsgWhoHas perm =>
364 ((Msg.send (bio, MsgWhoHasResponse (Acl.whoHas perm));
365 print ("Sent whohas response for " ^ #class perm ^ " / " ^ #value perm ^ ".\n"))
366 handle OpenSSL.OpenSSL s =>
367 (print "OpenSSL error\n";
368 Msg.send (bio,
369 MsgError
370 ("Error during whohas: "
371 ^ s)));
372 (ignore (OpenSSL.readChar bio);
373 OpenSSL.close bio)
374 handle OpenSSL.OpenSSL _ => ();
375 loop ())
376
377 | _ =>
378 (Msg.send (bio, MsgError "Unexpected command")
379 handle OpenSSL.OpenSSL _ => ();
380 OpenSSL.close bio
381 handle OpenSSL.OpenSSL _ => ();
382 loop ())
383 in
384 cmdLoop ()
385 end
386 handle OpenSSL.OpenSSL s =>
387 (print ("OpenSSL error: " ^ s ^ "\n");
388 OpenSSL.close bio
389 handle OpenSSL.OpenSSL _ => ();
390 loop ())
391 | OS.SysErr (s, _) =>
392 (print ("System error: " ^ s ^ "\n");
393 OpenSSL.close bio
394 handle OpenSSL.OpenSSL _ => ();
395 loop ())
396 in
397 print "Listening for connections....\n";
398 loop ();
399 OpenSSL.shutdown sock
400 end
401
402 fun slave () =
403 let
404 val host = Slave.hostname ()
405
406 val context = OpenSSL.context (Config.certDir ^ "/" ^ host ^ ".pem",
407 Config.keyDir ^ "/" ^ host ^ "/key.pem",
408 Config.trustStore)
409
410 val sock = OpenSSL.listen (context, Config.slavePort)
411
412 fun loop () =
413 case OpenSSL.accept sock of
414 NONE => ()
415 | SOME bio =>
416 let
417 val peer = OpenSSL.peerCN bio
418 val () = print ("\nConnection from " ^ peer ^ "\n")
419 in
420 if peer <> Config.dispatcherName then
421 (print "Not authorized!\n";
422 OpenSSL.close bio;
423 loop ())
424 else let
425 fun loop' files =
426 case Msg.recv bio of
427 NONE => print "Dispatcher closed connection unexpectedly\n"
428 | SOME m =>
429 case m of
430 MsgFile file => loop' (file :: files)
431 | MsgDoFiles => (Slave.handleChanges files;
432 Msg.send (bio, MsgOk))
433 | _ => (print "Dispatcher sent unexpected command\n";
434 Msg.send (bio, MsgError "Unexpected command"))
435 in
436 loop' [];
437 ignore (OpenSSL.readChar bio);
438 OpenSSL.close bio;
439 loop ()
440 end
441 end handle OpenSSL.OpenSSL s =>
442 (print ("OpenSSL error: "^ s ^ "\n");
443 OpenSSL.close bio
444 handle OpenSSL.OpenSSL _ => ();
445 loop ())
446 | OS.SysErr (s, _) =>
447 (print ("System error: "^ s ^ "\n");
448 OpenSSL.close bio
449 handle OpenSSL.OpenSSL _ => ();
450 loop ())
451 in
452 loop ();
453 OpenSSL.shutdown sock
454 end
455
456 fun autodocBasis outdir =
457 let
458 val dir = Posix.FileSys.opendir Config.libRoot
459
460 fun loop files =
461 case Posix.FileSys.readdir dir of
462 NONE => (Posix.FileSys.closedir dir;
463 files)
464 | SOME fname =>
465 if String.isSuffix ".dtl" fname then
466 loop (OS.Path.joinDirFile {dir = Config.libRoot,
467 file = fname}
468 :: files)
469 else
470 loop files
471
472 val files = loop []
473 in
474 Autodoc.autodoc {outdir = outdir, infiles = files}
475 end
476
477 end