Rmuser
[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 []
c53e82e4 56 val (_, files) = Order.order NONE 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
c53e82e4
AC
95val notTmp = CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"." orelse ch = #"_" orelse ch = #"-")
96
97fun checkDir dname =
98 let
99 val b = basis ()
100
101 val dir = Posix.FileSys.opendir dname
102
103 fun loop files =
104 case Posix.FileSys.readdir dir of
105 NONE => (Posix.FileSys.closedir dir;
106 files)
107 | SOME fname =>
108 if notTmp fname then
109 loop (OS.Path.joinDirFile {dir = dname,
110 file = fname}
111 :: files)
112 else
113 loop files
114
115 val files = loop []
116 val (_, files) = Order.order (SOME b) files
117 in
118 if !ErrorMsg.anyErrors then
1824f573 119 raise ErrorMsg.Error
c53e82e4
AC
120 else
121 (foldl (fn (fname, G) => check' G fname) b files;
1824f573
AC
122 if !ErrorMsg.anyErrors then
123 raise ErrorMsg.Error
124 else
125 ())
c53e82e4
AC
126 end
127
d189ec0e 128fun reduce fname =
a3698041 129 let
d189ec0e 130 val (G, body) = check fname
a3698041
AC
131 in
132 if !ErrorMsg.anyErrors then
d189ec0e 133 NONE
a3698041 134 else
d189ec0e
AC
135 case body of
136 SOME body =>
137 let
138 val body' = Reduce.reduceExp G body
139 in
140 (*printd (PD.hovBox (PD.PPS.Rel 0,
141 [PD.string "Result:",
142 PD.space 1,
143 p_exp body']))*)
144 SOME body'
145 end
146 | _ => NONE
a3698041
AC
147 end
148
d189ec0e
AC
149fun eval fname =
150 case reduce fname of
151 (SOME body') =>
152 if !ErrorMsg.anyErrors then
36e42cb8 153 raise ErrorMsg.Error
d189ec0e 154 else
aa56e112 155 Eval.exec (Defaults.eInit ()) body'
36e42cb8 156 | NONE => raise ErrorMsg.Error
d189ec0e 157
1824f573
AC
158fun eval' fname =
159 case reduce fname of
160 (SOME body') =>
161 if !ErrorMsg.anyErrors then
162 raise ErrorMsg.Error
163 else
164 ignore (Eval.exec' (Defaults.eInit ()) body')
165 | NONE => raise ErrorMsg.Error
166
3b267643
AC
167val dispatcher =
168 Config.dispatcher ^ ":" ^ Int.toString Config.dispatcherPort
559e89e9 169
5ee41dd0 170fun requestContext f =
07cc384c 171 let
a56cc2c3
AC
172 val uid = Posix.ProcEnv.getuid ()
173 val user = Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid uid)
5ee41dd0 174
a56cc2c3
AC
175 val () = Acl.read Config.aclFile
176 val () = Domain.setUser user
5ee41dd0
AC
177
178 val () = f ()
aa56e112 179
aa56e112 180 val context = OpenSSL.context (Config.certDir ^ "/" ^ user ^ ".pem",
a088cea6 181 Config.keyDir ^ "/" ^ user ^ "/key.pem",
3b267643 182 Config.trustStore)
5ee41dd0
AC
183 in
184 (user, context)
185 end
07cc384c 186
5ee41dd0
AC
187fun requestBio f =
188 let
189 val (user, context) = requestContext f
190 in
191 (user, OpenSSL.connect (context, dispatcher))
192 end
193
194fun request fname =
195 let
196 val (user, bio) = requestBio (fn () => ignore (check fname))
559e89e9 197
3b267643
AC
198 val inf = TextIO.openIn fname
199
36e42cb8 200 fun loop lines =
3b267643 201 case TextIO.inputLine inf of
36e42cb8
AC
202 NONE => String.concat (List.rev lines)
203 | SOME line => loop (line :: lines)
204
205 val code = loop []
559e89e9 206 in
3b267643 207 TextIO.closeIn inf;
36e42cb8
AC
208 Msg.send (bio, MsgConfig code);
209 case Msg.recv bio of
210 NONE => print "Server closed connection unexpectedly.\n"
211 | SOME m =>
212 case m of
213 MsgOk => print "Configuration succeeded.\n"
214 | MsgError s => print ("Configuration failed: " ^ s ^ "\n")
215 | _ => print "Unexpected server reply.\n";
3b267643 216 OpenSSL.close bio
559e89e9 217 end
aa56e112 218 handle ErrorMsg.Error => ()
559e89e9 219
c53e82e4
AC
220fun requestDir dname =
221 let
1824f573
AC
222 val _ = ErrorMsg.reset ()
223
224 val (user, bio) = requestBio (fn () => checkDir dname)
c53e82e4
AC
225
226 val b = basis ()
227
228 val dir = Posix.FileSys.opendir dname
229
230 fun loop files =
231 case Posix.FileSys.readdir dir of
232 NONE => (Posix.FileSys.closedir dir;
233 files)
234 | SOME fname =>
235 if notTmp fname then
236 loop (OS.Path.joinDirFile {dir = dname,
237 file = fname}
238 :: files)
239 else
240 loop files
241
242 val files = loop []
243 val (_, files) = Order.order (SOME b) files
244
245 val _ = if !ErrorMsg.anyErrors then
246 raise ErrorMsg.Error
247 else
248 ()
249
250 val codes = map (fn fname =>
251 let
252 val inf = TextIO.openIn fname
253
254 fun loop lines =
255 case TextIO.inputLine inf of
256 NONE => String.concat (rev lines)
257 | SOME line => loop (line :: lines)
258 in
259 loop []
260 before TextIO.closeIn inf
261 end) files
262 in
1824f573
AC
263 if !ErrorMsg.anyErrors then
264 ()
265 else
266 (Msg.send (bio, MsgMultiConfig codes);
267 case Msg.recv bio of
268 NONE => print "Server closed connection unexpectedly.\n"
269 | SOME m =>
270 case m of
271 MsgOk => print "Configuration succeeded.\n"
272 | MsgError s => print ("Configuration failed: " ^ s ^ "\n")
273 | _ => print "Unexpected server reply.\n";
274 OpenSSL.close bio)
c53e82e4
AC
275 end
276 handle ErrorMsg.Error => ()
277
5ee41dd0
AC
278fun requestGrant acl =
279 let
280 val (user, bio) = requestBio (fn () => ())
281 in
282 Msg.send (bio, MsgGrant acl);
283 case Msg.recv bio of
284 NONE => print "Server closed connection unexpectedly.\n"
285 | SOME m =>
286 case m of
287 MsgOk => print "Grant succeeded.\n"
288 | MsgError s => print ("Grant failed: " ^ s ^ "\n")
289 | _ => print "Unexpected server reply.\n";
290 OpenSSL.close bio
291 end
292
411a85f2
AC
293fun requestRevoke acl =
294 let
295 val (user, bio) = requestBio (fn () => ())
296 in
297 Msg.send (bio, MsgRevoke acl);
298 case Msg.recv bio of
299 NONE => print "Server closed connection unexpectedly.\n"
300 | SOME m =>
301 case m of
302 MsgOk => print "Revoke succeeded.\n"
303 | MsgError s => print ("Revoke failed: " ^ s ^ "\n")
304 | _ => print "Unexpected server reply.\n";
305 OpenSSL.close bio
306 end
307
08a04eb4
AC
308fun requestListPerms user =
309 let
310 val (_, bio) = requestBio (fn () => ())
311 in
312 Msg.send (bio, MsgListPerms user);
313 (case Msg.recv bio of
314 NONE => (print "Server closed connection unexpectedly.\n";
315 NONE)
316 | SOME m =>
317 case m of
318 MsgPerms perms => SOME perms
319 | MsgError s => (print ("Listing failed: " ^ s ^ "\n");
320 NONE)
321 | _ => (print "Unexpected server reply.\n";
322 NONE))
323 before OpenSSL.close bio
324 end
325
094877b1
AC
326fun requestWhoHas perm =
327 let
328 val (_, bio) = requestBio (fn () => ())
329 in
330 Msg.send (bio, MsgWhoHas perm);
331 (case Msg.recv bio of
332 NONE => (print "Server closed connection unexpectedly.\n";
333 NONE)
334 | SOME m =>
335 case m of
336 MsgWhoHasResponse users => SOME users
337 | MsgError s => (print ("whohas failed: " ^ s ^ "\n");
338 NONE)
339 | _ => (print "Unexpected server reply.\n";
340 NONE))
341 before OpenSSL.close bio
342 end
343
1824f573
AC
344fun requestRegen () =
345 let
346 val (_, bio) = requestBio (fn () => ())
347 in
348 Msg.send (bio, MsgRegenerate);
349 case Msg.recv bio of
350 NONE => print "Server closed connection unexpectedly.\n"
351 | SOME m =>
352 case m of
353 MsgOk => print "Regeneration succeeded.\n"
354 | MsgError s => print ("Regeneration failed: " ^ s ^ "\n")
355 | _ => print "Unexpected server reply.\n";
356 OpenSSL.close bio
357 end
358
c189cbe9
AC
359fun requestRmdom dom =
360 let
361 val (_, bio) = requestBio (fn () => ())
362 in
363 Msg.send (bio, MsgRmdom dom);
364 case Msg.recv bio of
365 NONE => print "Server closed connection unexpectedly.\n"
366 | SOME m =>
367 case m of
368 MsgOk => print "Removal succeeded.\n"
369 | MsgError s => print ("Removal failed: " ^ s ^ "\n")
370 | _ => print "Unexpected server reply.\n";
371 OpenSSL.close bio
372 end
373
e69e60cc
AC
374fun requestRmuser user =
375 let
376 val (_, bio) = requestBio (fn () => ())
377 in
378 Msg.send (bio, MsgRmuser user);
379 case Msg.recv bio of
380 NONE => print "Server closed connection unexpectedly.\n"
381 | SOME m =>
382 case m of
383 MsgOk => print "Removal succeeded.\n"
384 | MsgError s => print ("Removal failed: " ^ s ^ "\n")
385 | _ => print "Unexpected server reply.\n";
386 OpenSSL.close bio
387 end
388
71420f8b 389fun regenerate context =
1824f573
AC
390 let
391 val b = basis ()
71420f8b
AC
392 val () = Tycheck.disallowExterns ()
393
394 val () = Domain.resetGlobal ()
395
396 fun contactNode (node, ip) =
397 if node = Config.defaultNode then
398 Domain.resetLocal ()
399 else let
400 val bio = OpenSSL.connect (context,
401 ip
402 ^ ":"
403 ^ Int.toString Config.slavePort)
404 in
405 Msg.send (bio, MsgRegenerate);
406 case Msg.recv bio of
407 NONE => print "Slave closed connection unexpectedly\n"
408 | SOME m =>
409 case m of
410 MsgOk => print ("Slave " ^ node ^ " pre-regeneration finished\n")
411 | MsgError s => print ("Slave " ^ node
412 ^ " returned error: " ^
413 s ^ "\n")
414 | _ => print ("Slave " ^ node
415 ^ " returned unexpected command\n");
416 OpenSSL.close bio
417 end
1824f573
AC
418
419 fun doUser user =
420 let
421 val _ = Domain.setUser user
422 val _ = ErrorMsg.reset ()
423
424 val dname = Config.domtoolDir user
425
426 val dir = Posix.FileSys.opendir dname
427
428 fun loop files =
429 case Posix.FileSys.readdir dir of
430 NONE => (Posix.FileSys.closedir dir;
431 files)
432 | SOME fname =>
433 if notTmp fname then
434 loop (OS.Path.joinDirFile {dir = dname,
435 file = fname}
436 :: files)
437 else
438 loop files
439
440 val files = loop []
441 val (_, files) = Order.order (SOME b) files
442 in
443 if !ErrorMsg.anyErrors then
444 print ("User " ^ user ^ "'s configuration has errors!\n")
445 else
446 app eval' files
447 end
448 handle IO.Io _ => ()
449 | OS.SysErr (s, _) => print ("System error processing user " ^ user ^ ": " ^ s ^ "\n")
450 in
71420f8b 451 app contactNode Config.nodeIps;
1824f573
AC
452 Env.pre ();
453 app doUser (Acl.users ());
454 Env.post ()
455 end
456
e69e60cc
AC
457fun rmuser user =
458 let
459 val doms = Acl.class {user = user, class = "domain"}
460 val doms = List.filter (fn dom =>
461 case Acl.whoHas {class = "domain", value = dom} of
462 [_] => true
463 | _ => false) (StringSet.listItems doms)
464 in
465 Acl.rmuser user;
466 Domain.rmdom doms
467 end
468
3b267643 469fun service () =
07cc384c 470 let
aa56e112
AC
471 val () = Acl.read Config.aclFile
472
3b267643
AC
473 val context = OpenSSL.context (Config.serverCert,
474 Config.serverKey,
475 Config.trustStore)
36e42cb8 476 val _ = Domain.set_context context
3b267643 477
60534712 478 val sock = OpenSSL.listen (context, Config.dispatcherPort)
3b267643
AC
479
480 fun loop () =
60534712 481 case OpenSSL.accept sock of
3b267643
AC
482 NONE => ()
483 | SOME bio =>
484 let
aa56e112
AC
485 val user = OpenSSL.peerCN bio
486 val () = print ("\nConnection from " ^ user ^ "\n")
487 val () = Domain.setUser user
488
c53e82e4
AC
489 fun doConfig codes =
490 let
491 val _ = print "Configuration:\n"
492 val _ = app (fn s => (print s; print "\n")) codes
493 val _ = print "\n"
494
495 val outname = OS.FileSys.tmpName ()
496
497 fun doOne code =
498 let
499 val outf = TextIO.openOut outname
500 in
501 TextIO.output (outf, code);
502 TextIO.closeOut outf;
1824f573 503 eval' outname
c53e82e4
AC
504 end
505 in
1824f573
AC
506 (Env.pre ();
507 app doOne codes;
508 Env.post ();
c53e82e4
AC
509 Msg.send (bio, MsgOk))
510 handle ErrorMsg.Error =>
511 (print "Compilation error\n";
512 Msg.send (bio,
513 MsgError "Error during configuration evaluation"))
514 | OpenSSL.OpenSSL s =>
515 (print "OpenSSL error\n";
516 Msg.send (bio,
517 MsgError
518 ("Error during configuration evaluation: "
519 ^ s)));
520 OS.FileSys.remove outname;
521 (ignore (OpenSSL.readChar bio);
522 OpenSSL.close bio)
523 handle OpenSSL.OpenSSL _ => ();
524 loop ()
525 end
526
36e42cb8
AC
527 fun cmdLoop () =
528 case Msg.recv bio of
529 NONE => (OpenSSL.close bio
530 handle OpenSSL.OpenSSL _ => ();
531 loop ())
532 | SOME m =>
533 case m of
c53e82e4
AC
534 MsgConfig code => doConfig [code]
535 | MsgMultiConfig codes => doConfig codes
5ee41dd0
AC
536
537 | MsgGrant acl =>
be1bea4c 538 if Acl.query {user = user, class = "priv", value = "all"} then
5ee41dd0
AC
539 ((Acl.grant acl;
540 Acl.write Config.aclFile;
411a85f2
AC
541 Msg.send (bio, MsgOk);
542 print ("Granted permission " ^ #value acl ^ " to " ^ #user acl ^ " in " ^ #class acl ^ ".\n"))
5ee41dd0
AC
543 handle OpenSSL.OpenSSL s =>
544 (print "OpenSSL error\n";
545 Msg.send (bio,
546 MsgError
547 ("Error during granting: "
548 ^ s)));
549 (ignore (OpenSSL.readChar bio);
550 OpenSSL.close bio)
551 handle OpenSSL.OpenSSL _ => ();
552 loop ())
553 else
554 ((Msg.send (bio, MsgError "Not authorized to grant privileges");
411a85f2
AC
555 print "Unauthorized user asked to grant a permission!\n";
556 ignore (OpenSSL.readChar bio);
557 OpenSSL.close bio)
558 handle OpenSSL.OpenSSL _ => ();
559 loop ())
560
561 | MsgRevoke acl =>
be1bea4c 562 if Acl.query {user = user, class = "priv", value = "all"} then
411a85f2
AC
563 ((Acl.revoke acl;
564 Acl.write Config.aclFile;
565 Msg.send (bio, MsgOk);
566 print ("Revoked permission " ^ #value acl ^ " from " ^ #user acl ^ " in " ^ #class acl ^ ".\n"))
567 handle OpenSSL.OpenSSL s =>
568 (print "OpenSSL error\n";
569 Msg.send (bio,
570 MsgError
571 ("Error during revocation: "
572 ^ s)));
573 (ignore (OpenSSL.readChar bio);
574 OpenSSL.close bio)
575 handle OpenSSL.OpenSSL _ => ();
576 loop ())
577 else
578 ((Msg.send (bio, MsgError "Not authorized to revoke privileges");
579 print "Unauthorized user asked to revoke a permission!\n";
5ee41dd0
AC
580 ignore (OpenSSL.readChar bio);
581 OpenSSL.close bio)
582 handle OpenSSL.OpenSSL _ => ();
583 loop ())
584
08a04eb4
AC
585 | MsgListPerms user =>
586 ((Msg.send (bio, MsgPerms (Acl.queryAll user));
587 print ("Sent permission list for user " ^ user ^ ".\n"))
588 handle OpenSSL.OpenSSL s =>
589 (print "OpenSSL error\n";
590 Msg.send (bio,
591 MsgError
592 ("Error during permission listing: "
593 ^ s)));
594 (ignore (OpenSSL.readChar bio);
595 OpenSSL.close bio)
596 handle OpenSSL.OpenSSL _ => ();
597 loop ())
598
094877b1
AC
599 | MsgWhoHas perm =>
600 ((Msg.send (bio, MsgWhoHasResponse (Acl.whoHas perm));
601 print ("Sent whohas response for " ^ #class perm ^ " / " ^ #value perm ^ ".\n"))
602 handle OpenSSL.OpenSSL s =>
603 (print "OpenSSL error\n";
604 Msg.send (bio,
605 MsgError
606 ("Error during whohas: "
607 ^ s)));
608 (ignore (OpenSSL.readChar bio);
609 OpenSSL.close bio)
610 handle OpenSSL.OpenSSL _ => ();
611 loop ())
612
e69e60cc 613 | MsgRmdom doms =>
c189cbe9 614 if Acl.query {user = user, class = "priv", value = "all"}
e69e60cc
AC
615 orelse List.all (fn dom => Acl.query {user = user, class = "domain", value = dom}) doms then
616 ((Domain.rmdom doms;
617 app (fn dom =>
618 Acl.revokeFromAll {class = "domain", value = dom}) doms;
619 Acl.write Config.aclFile;
c189cbe9 620 Msg.send (bio, MsgOk);
e69e60cc 621 print ("Removed domains" ^ foldl (fn (d, s) => s ^ " " ^ d) "" doms ^ ".\n"))
c189cbe9
AC
622 handle OpenSSL.OpenSSL s =>
623 (print "OpenSSL error\n";
624 Msg.send (bio,
625 MsgError
626 ("Error during revocation: "
627 ^ s)));
628 (ignore (OpenSSL.readChar bio);
629 OpenSSL.close bio)
630 handle OpenSSL.OpenSSL _ => ();
631 loop ())
632 else
633 ((Msg.send (bio, MsgError "Not authorized to remove that domain");
634 print "Unauthorized user asked to remove a domain!\n";
635 ignore (OpenSSL.readChar bio);
636 OpenSSL.close bio)
637 handle OpenSSL.OpenSSL _ => ();
1824f573
AC
638 loop ())
639
640 | MsgRegenerate =>
641 if Acl.query {user = user, class = "priv", value = "regen"}
642 orelse Acl.query {user = user, class = "priv", value = "all"} then
71420f8b 643 ((regenerate context;
1824f573
AC
644 Msg.send (bio, MsgOk);
645 print "Regenerated all configuration.\n")
646 handle OpenSSL.OpenSSL s =>
647 (print "OpenSSL error\n";
648 Msg.send (bio,
649 MsgError
650 ("Error during regeneration: "
651 ^ s)));
652 (ignore (OpenSSL.readChar bio);
653 OpenSSL.close bio)
654 handle OpenSSL.OpenSSL _ => ();
655 loop ())
656 else
657 ((Msg.send (bio, MsgError "Not authorized to regeneration");
658 print "Unauthorized user asked to regenerate!\n";
659 ignore (OpenSSL.readChar bio);
660 OpenSSL.close bio)
661 handle OpenSSL.OpenSSL _ => ();
e69e60cc
AC
662 loop ())
663
664 | MsgRmuser user =>
665 if Acl.query {user = user, class = "priv", value = "all"} then
666 ((rmuser user;
667 Acl.write Config.aclFile;
668 Msg.send (bio, MsgOk);
669 print ("Removed user " ^ user ^ ".\n"))
670 handle OpenSSL.OpenSSL s =>
671 (print "OpenSSL error\n";
672 Msg.send (bio,
673 MsgError
674 ("Error during revocation: "
675 ^ s)));
676 (ignore (OpenSSL.readChar bio);
677 OpenSSL.close bio)
678 handle OpenSSL.OpenSSL _ => ();
679 loop ())
680 else
681 ((Msg.send (bio, MsgError "Not authorized to remove users");
682 print "Unauthorized user asked to remove a user!\n";
683 ignore (OpenSSL.readChar bio);
684 OpenSSL.close bio)
685 handle OpenSSL.OpenSSL _ => ();
c189cbe9
AC
686 loop ())
687
36e42cb8
AC
688 | _ =>
689 (Msg.send (bio, MsgError "Unexpected command")
690 handle OpenSSL.OpenSSL _ => ();
691 OpenSSL.close bio
692 handle OpenSSL.OpenSSL _ => ();
693 loop ())
694 in
695 cmdLoop ()
696 end
97665758
AC
697 handle OpenSSL.OpenSSL s =>
698 (print ("OpenSSL error: " ^ s ^ "\n");
699 OpenSSL.close bio
700 handle OpenSSL.OpenSSL _ => ();
701 loop ())
702 | OS.SysErr (s, _) =>
703 (print ("System error: " ^ s ^ "\n");
704 OpenSSL.close bio
705 handle OpenSSL.OpenSSL _ => ();
706 loop ())
36e42cb8 707 in
361a1e7f 708 print "Listening for connections....\n";
36e42cb8
AC
709 loop ();
710 OpenSSL.shutdown sock
711 end
712
713fun slave () =
714 let
6e62228d 715 val host = Slave.hostname ()
36e42cb8
AC
716
717 val context = OpenSSL.context (Config.certDir ^ "/" ^ host ^ ".pem",
a088cea6 718 Config.keyDir ^ "/" ^ host ^ "/key.pem",
36e42cb8
AC
719 Config.trustStore)
720
721 val sock = OpenSSL.listen (context, Config.slavePort)
722
723 fun loop () =
724 case OpenSSL.accept sock of
725 NONE => ()
726 | SOME bio =>
727 let
728 val peer = OpenSSL.peerCN bio
729 val () = print ("\nConnection from " ^ peer ^ "\n")
3b267643 730 in
36e42cb8
AC
731 if peer <> Config.dispatcherName then
732 (print "Not authorized!\n";
733 OpenSSL.close bio;
734 loop ())
735 else let
736 fun loop' files =
737 case Msg.recv bio of
738 NONE => print "Dispatcher closed connection unexpectedly\n"
739 | SOME m =>
740 case m of
741 MsgFile file => loop' (file :: files)
742 | MsgDoFiles => (Slave.handleChanges files;
743 Msg.send (bio, MsgOk))
71420f8b
AC
744 | MsgRegenerate => (Domain.resetLocal ();
745 Msg.send (bio, MsgOk))
36e42cb8
AC
746 | _ => (print "Dispatcher sent unexpected command\n";
747 Msg.send (bio, MsgError "Unexpected command"))
748 in
749 loop' [];
750 ignore (OpenSSL.readChar bio);
751 OpenSSL.close bio;
752 loop ()
753 end
3196000d
AC
754 end handle OpenSSL.OpenSSL s =>
755 (print ("OpenSSL error: "^ s ^ "\n");
756 OpenSSL.close bio
757 handle OpenSSL.OpenSSL _ => ();
758 loop ())
7af7d4cb
AC
759 | OS.SysErr (s, _) =>
760 (print ("System error: "^ s ^ "\n");
761 OpenSSL.close bio
762 handle OpenSSL.OpenSSL _ => ();
763 loop ())
07cc384c 764 in
3b267643
AC
765 loop ();
766 OpenSSL.shutdown sock
07cc384c
AC
767 end
768
3196000d
AC
769fun autodocBasis outdir =
770 let
771 val dir = Posix.FileSys.opendir Config.libRoot
772
773 fun loop files =
774 case Posix.FileSys.readdir dir of
775 NONE => (Posix.FileSys.closedir dir;
776 files)
777 | SOME fname =>
778 if String.isSuffix ".dtl" fname then
779 loop (OS.Path.joinDirFile {dir = Config.libRoot,
780 file = fname}
781 :: files)
782 else
783 loop files
784
785 val files = loop []
786 in
787 Autodoc.autodoc {outdir = outdir, infiles = files}
788 end
789
234b917a 790end