Add rmuser command
[hcoop/zz_old/domtool2-proto.git] / src / main.sml
CommitLineData
e680130a 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.
ae3a5b8c 17 *)
e680130a 18
19(* Main interface *)
20
21structure Main :> MAIN = struct
22
d330d9b8 23open Ast MsgTypes Print
e680130a 24
85af7d3e 25structure SM = StringMap
26
53d222a3 27fun init () = Acl.read Config.aclFile
e680130a 28
17ef447e 29fun check' G fname =
a11c0ff3 30 let
31 val prog = Parse.parse fname
32 in
33 if !ErrorMsg.anyErrors then
17ef447e 34 G
a11c0ff3 35 else
53d222a3 36 Tycheck.checkFile G (Defaults.tInit ()) prog
a11c0ff3 37 end
38
17ef447e 39fun basis () =
e680130a 40 let
17ef447e 41 val dir = Posix.FileSys.opendir Config.libRoot
42
43 fun loop files =
44 case Posix.FileSys.readdir dir of
c12828f2 45 NONE => (Posix.FileSys.closedir dir;
46 files)
17ef447e 47 | SOME fname =>
48 if String.isSuffix ".dtl" fname then
c12828f2 49 loop (OS.Path.joinDirFile {dir = Config.libRoot,
50 file = fname}
17ef447e 51 :: files)
52 else
53 loop files
54
55 val files = loop []
c8a739af 56 val (_, files) = Order.order NONE files
17ef447e 57 in
85af7d3e 58 if !ErrorMsg.anyErrors then
59 Env.empty
60 else
89c9edc9 61 (Tycheck.allowExterns ();
62 foldl (fn (fname, G) => check' G fname) Env.empty files
63 before Tycheck.disallowExterns ())
17ef447e 64 end
65
66fun check fname =
67 let
68 val _ = ErrorMsg.reset ()
4e8a3f2b 69 val _ = Env.preTycheck ()
17ef447e 70
71 val b = basis ()
e680130a 72 in
73 if !ErrorMsg.anyErrors then
d330d9b8 74 raise ErrorMsg.Error
e680130a 75 else
76 let
89c9edc9 77 val _ = Tycheck.disallowExterns ()
4cc63b03 78 val _ = ErrorMsg.reset ()
17ef447e 79 val prog = Parse.parse fname
e680130a 80 in
add6f172 81 if !ErrorMsg.anyErrors then
d330d9b8 82 raise ErrorMsg.Error
add6f172 83 else
17ef447e 84 let
53d222a3 85 val G' = Tycheck.checkFile b (Defaults.tInit ()) prog
17ef447e 86 in
d330d9b8 87 if !ErrorMsg.anyErrors then
88 raise ErrorMsg.Error
89 else
90 (G', #3 prog)
17ef447e 91 end
e680130a 92 end
93 end
94
c8a739af 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
f92c6883 119 raise ErrorMsg.Error
c8a739af 120 else
121 (foldl (fn (fname, G) => check' G fname) b files;
f92c6883 122 if !ErrorMsg.anyErrors then
123 raise ErrorMsg.Error
124 else
125 ())
c8a739af 126 end
127
17ef447e 128fun reduce fname =
a11c0ff3 129 let
17ef447e 130 val (G, body) = check fname
a11c0ff3 131 in
132 if !ErrorMsg.anyErrors then
17ef447e 133 NONE
a11c0ff3 134 else
17ef447e 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
a11c0ff3 147 end
148
17ef447e 149fun eval fname =
150 case reduce fname of
151 (SOME body') =>
152 if !ErrorMsg.anyErrors then
d330d9b8 153 raise ErrorMsg.Error
17ef447e 154 else
53d222a3 155 Eval.exec (Defaults.eInit ()) body'
d330d9b8 156 | NONE => raise ErrorMsg.Error
17ef447e 157
f92c6883 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
2569e66d 167val dispatcher =
168 Config.dispatcher ^ ":" ^ Int.toString Config.dispatcherPort
1f8889bd 169
e2130d9c 170fun requestContext f =
904eb905 171 let
3ff08fe1 172 val uid = Posix.ProcEnv.getuid ()
173 val user = Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid uid)
e2130d9c 174
3ff08fe1 175 val () = Acl.read Config.aclFile
176 val () = Domain.setUser user
e2130d9c 177
178 val () = f ()
53d222a3 179
53d222a3 180 val context = OpenSSL.context (Config.certDir ^ "/" ^ user ^ ".pem",
514b7936 181 Config.keyDir ^ "/" ^ user ^ "/key.pem",
2569e66d 182 Config.trustStore)
e2130d9c 183 in
184 (user, context)
185 end
904eb905 186
e2130d9c 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))
1f8889bd 197
2569e66d 198 val inf = TextIO.openIn fname
199
d330d9b8 200 fun loop lines =
2569e66d 201 case TextIO.inputLine inf of
d330d9b8 202 NONE => String.concat (List.rev lines)
203 | SOME line => loop (line :: lines)
204
205 val code = loop []
1f8889bd 206 in
2569e66d 207 TextIO.closeIn inf;
d330d9b8 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";
2569e66d 216 OpenSSL.close bio
1f8889bd 217 end
53d222a3 218 handle ErrorMsg.Error => ()
1f8889bd 219
c8a739af 220fun requestDir dname =
221 let
f92c6883 222 val _ = ErrorMsg.reset ()
223
224 val (user, bio) = requestBio (fn () => checkDir dname)
c8a739af 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
f92c6883 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)
c8a739af 275 end
276 handle ErrorMsg.Error => ()
277
e2130d9c 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
d1aa6a21 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
646381db 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
d0e75410 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
f92c6883 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
7d32cf2f 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
aba1f07e 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
0ea0ecfa 389fun regenerate context =
f92c6883 390 let
391 val b = basis ()
0ea0ecfa 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
f92c6883 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
0ea0ecfa 451 app contactNode Config.nodeIps;
f92c6883 452 Env.pre ();
453 app doUser (Acl.users ());
454 Env.post ()
455 end
456
aba1f07e 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
2569e66d 469fun service () =
904eb905 470 let
53d222a3 471 val () = Acl.read Config.aclFile
472
2569e66d 473 val context = OpenSSL.context (Config.serverCert,
474 Config.serverKey,
475 Config.trustStore)
d330d9b8 476 val _ = Domain.set_context context
2569e66d 477
cbb8f260 478 val sock = OpenSSL.listen (context, Config.dispatcherPort)
2569e66d 479
480 fun loop () =
cbb8f260 481 case OpenSSL.accept sock of
2569e66d 482 NONE => ()
483 | SOME bio =>
484 let
53d222a3 485 val user = OpenSSL.peerCN bio
486 val () = print ("\nConnection from " ^ user ^ "\n")
487 val () = Domain.setUser user
488
c8a739af 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;
f92c6883 503 eval' outname
c8a739af 504 end
505 in
f92c6883 506 (Env.pre ();
507 app doOne codes;
508 Env.post ();
c8a739af 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
d330d9b8 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
c8a739af 534 MsgConfig code => doConfig [code]
535 | MsgMultiConfig codes => doConfig codes
e2130d9c 536
537 | MsgGrant acl =>
1bb29dea 538 if Acl.query {user = user, class = "priv", value = "all"} then
e2130d9c 539 ((Acl.grant acl;
540 Acl.write Config.aclFile;
d1aa6a21 541 Msg.send (bio, MsgOk);
542 print ("Granted permission " ^ #value acl ^ " to " ^ #user acl ^ " in " ^ #class acl ^ ".\n"))
e2130d9c 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");
d1aa6a21 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 =>
1bb29dea 562 if Acl.query {user = user, class = "priv", value = "all"} then
d1aa6a21 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";
e2130d9c 580 ignore (OpenSSL.readChar bio);
581 OpenSSL.close bio)
582 handle OpenSSL.OpenSSL _ => ();
583 loop ())
584
646381db 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
d0e75410 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
aba1f07e 613 | MsgRmdom doms =>
7d32cf2f 614 if Acl.query {user = user, class = "priv", value = "all"}
aba1f07e 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;
7d32cf2f 620 Msg.send (bio, MsgOk);
aba1f07e 621 print ("Removed domains" ^ foldl (fn (d, s) => s ^ " " ^ d) "" doms ^ ".\n"))
7d32cf2f 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 _ => ();
f92c6883 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
0ea0ecfa 643 ((regenerate context;
f92c6883 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 _ => ();
aba1f07e 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 _ => ();
7d32cf2f 686 loop ())
687
d330d9b8 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
7e90e261 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 ())
d330d9b8 707 in
0cfb3669 708 print "Listening for connections....\n";
d330d9b8 709 loop ();
710 OpenSSL.shutdown sock
711 end
712
713fun slave () =
714 let
f58a3627 715 val host = Slave.hostname ()
d330d9b8 716
717 val context = OpenSSL.context (Config.certDir ^ "/" ^ host ^ ".pem",
514b7936 718 Config.keyDir ^ "/" ^ host ^ "/key.pem",
d330d9b8 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")
2569e66d 730 in
d330d9b8 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))
0ea0ecfa 744 | MsgRegenerate => (Domain.resetLocal ();
745 Msg.send (bio, MsgOk))
d330d9b8 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
91c5a390 754 end handle OpenSSL.OpenSSL s =>
755 (print ("OpenSSL error: "^ s ^ "\n");
756 OpenSSL.close bio
757 handle OpenSSL.OpenSSL _ => ();
758 loop ())
1d2fd26b 759 | OS.SysErr (s, _) =>
760 (print ("System error: "^ s ^ "\n");
761 OpenSSL.close bio
762 handle OpenSSL.OpenSSL _ => ();
763 loop ())
904eb905 764 in
2569e66d 765 loop ();
766 OpenSSL.shutdown sock
904eb905 767 end
768
91c5a390 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
e680130a 790end