Make regen work even when someone has compilation errors
[hcoop/domtool2.git] / src / main.sml
CommitLineData
234b917a 1(* HCoop Domtool (http://hcoop.sourceforge.net/)
f8ef6c20 2 * Copyright (c) 2006-2007, Adam Chlipala
234b917a
AC
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
c9731b9b
AC
170val self =
171 "localhost:" ^ Int.toString Config.slavePort
172
d22c1f00
AC
173fun context x =
174 (OpenSSL.context false x)
175 handle e as OpenSSL.OpenSSL _ =>
176 (print "Couldn't find your certificate.\nYou probably haven't been given any Domtool privileges.\n";
177 raise e)
178
5ee41dd0 179fun requestContext f =
07cc384c 180 let
573a0ebc
AC
181 val user =
182 case Posix.ProcEnv.getenv "DOMTOOL_USER" of
183 NONE =>
184 let
185 val uid = Posix.ProcEnv.getuid ()
186 in
187 Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid uid)
188 end
189 | SOME user => user
5ee41dd0 190
a56cc2c3
AC
191 val () = Acl.read Config.aclFile
192 val () = Domain.setUser user
5ee41dd0
AC
193
194 val () = f ()
aa56e112 195
d22c1f00
AC
196 val context = context (Config.certDir ^ "/" ^ user ^ ".pem",
197 Config.keyDir ^ "/" ^ user ^ "/key.pem",
198 Config.trustStore)
5ee41dd0
AC
199 in
200 (user, context)
201 end
07cc384c 202
5ee41dd0
AC
203fun requestBio f =
204 let
205 val (user, context) = requestContext f
206 in
207 (user, OpenSSL.connect (context, dispatcher))
208 end
209
c9731b9b
AC
210fun requestSlaveBio () =
211 let
212 val (user, context) = requestContext (fn () => ())
213 in
214 (user, OpenSSL.connect (context, self))
215 end
216
5ee41dd0
AC
217fun request fname =
218 let
219 val (user, bio) = requestBio (fn () => ignore (check fname))
559e89e9 220
3b267643
AC
221 val inf = TextIO.openIn fname
222
36e42cb8 223 fun loop lines =
3b267643 224 case TextIO.inputLine inf of
36e42cb8
AC
225 NONE => String.concat (List.rev lines)
226 | SOME line => loop (line :: lines)
227
228 val code = loop []
559e89e9 229 in
3b267643 230 TextIO.closeIn inf;
36e42cb8
AC
231 Msg.send (bio, MsgConfig code);
232 case Msg.recv bio of
233 NONE => print "Server closed connection unexpectedly.\n"
234 | SOME m =>
235 case m of
236 MsgOk => print "Configuration succeeded.\n"
237 | MsgError s => print ("Configuration failed: " ^ s ^ "\n")
238 | _ => print "Unexpected server reply.\n";
3b267643 239 OpenSSL.close bio
559e89e9 240 end
aa56e112 241 handle ErrorMsg.Error => ()
559e89e9 242
c53e82e4
AC
243fun requestDir dname =
244 let
1824f573
AC
245 val _ = ErrorMsg.reset ()
246
247 val (user, bio) = requestBio (fn () => checkDir dname)
c53e82e4
AC
248
249 val b = basis ()
250
251 val dir = Posix.FileSys.opendir dname
252
253 fun loop files =
254 case Posix.FileSys.readdir dir of
255 NONE => (Posix.FileSys.closedir dir;
256 files)
257 | SOME fname =>
258 if notTmp fname then
259 loop (OS.Path.joinDirFile {dir = dname,
260 file = fname}
261 :: files)
262 else
263 loop files
264
265 val files = loop []
266 val (_, files) = Order.order (SOME b) files
267
268 val _ = if !ErrorMsg.anyErrors then
269 raise ErrorMsg.Error
270 else
271 ()
272
273 val codes = map (fn fname =>
274 let
275 val inf = TextIO.openIn fname
276
277 fun loop lines =
278 case TextIO.inputLine inf of
279 NONE => String.concat (rev lines)
280 | SOME line => loop (line :: lines)
281 in
282 loop []
283 before TextIO.closeIn inf
284 end) files
285 in
1824f573
AC
286 if !ErrorMsg.anyErrors then
287 ()
288 else
289 (Msg.send (bio, MsgMultiConfig codes);
290 case Msg.recv bio of
291 NONE => print "Server closed connection unexpectedly.\n"
292 | SOME m =>
293 case m of
294 MsgOk => print "Configuration succeeded.\n"
295 | MsgError s => print ("Configuration failed: " ^ s ^ "\n")
296 | _ => print "Unexpected server reply.\n";
297 OpenSSL.close bio)
c53e82e4
AC
298 end
299 handle ErrorMsg.Error => ()
300
62260c5f
AC
301fun requestPing () =
302 let
303 val (_, bio) = requestBio (fn () => ())
304 in
305 OpenSSL.close bio;
306 OS.Process.success
307 end
308 handle _ => OS.Process.failure
309
9f27d58f
AC
310fun requestShutdown () =
311 let
312 val (_, bio) = requestBio (fn () => ())
313 in
314 Msg.send (bio, MsgShutdown);
315 case Msg.recv bio of
316 NONE => print "Server closed connection unexpectedly.\n"
317 | SOME m =>
318 case m of
319 MsgOk => print "Shutdown begun.\n"
320 | MsgError s => print ("Shutdown failed: " ^ s ^ "\n")
321 | _ => print "Unexpected server reply.\n";
322 OpenSSL.close bio
323 end
324
c9731b9b
AC
325fun requestSlavePing () =
326 let
327 val (_, bio) = requestSlaveBio ()
328 in
329 OpenSSL.close bio;
330 OS.Process.success
331 end
332 handle _ => OS.Process.failure
333
334fun requestSlaveShutdown () =
335 let
336 val (_, bio) = requestSlaveBio ()
337 in
338 Msg.send (bio, MsgShutdown);
339 case Msg.recv bio of
340 NONE => print "Server closed connection unexpectedly.\n"
341 | SOME m =>
342 case m of
343 MsgOk => print "Shutdown begun.\n"
344 | MsgError s => print ("Shutdown failed: " ^ s ^ "\n")
345 | _ => print "Unexpected server reply.\n";
346 OpenSSL.close bio
347 end
348
5ee41dd0
AC
349fun requestGrant acl =
350 let
351 val (user, bio) = requestBio (fn () => ())
352 in
353 Msg.send (bio, MsgGrant acl);
354 case Msg.recv bio of
355 NONE => print "Server closed connection unexpectedly.\n"
356 | SOME m =>
357 case m of
358 MsgOk => print "Grant succeeded.\n"
359 | MsgError s => print ("Grant failed: " ^ s ^ "\n")
360 | _ => print "Unexpected server reply.\n";
361 OpenSSL.close bio
362 end
363
411a85f2
AC
364fun requestRevoke acl =
365 let
366 val (user, bio) = requestBio (fn () => ())
367 in
368 Msg.send (bio, MsgRevoke acl);
369 case Msg.recv bio of
370 NONE => print "Server closed connection unexpectedly.\n"
371 | SOME m =>
372 case m of
373 MsgOk => print "Revoke succeeded.\n"
374 | MsgError s => print ("Revoke failed: " ^ s ^ "\n")
375 | _ => print "Unexpected server reply.\n";
376 OpenSSL.close bio
377 end
378
08a04eb4
AC
379fun requestListPerms user =
380 let
381 val (_, bio) = requestBio (fn () => ())
382 in
383 Msg.send (bio, MsgListPerms user);
384 (case Msg.recv bio of
385 NONE => (print "Server closed connection unexpectedly.\n";
386 NONE)
387 | SOME m =>
388 case m of
389 MsgPerms perms => SOME perms
390 | MsgError s => (print ("Listing failed: " ^ s ^ "\n");
391 NONE)
392 | _ => (print "Unexpected server reply.\n";
393 NONE))
394 before OpenSSL.close bio
395 end
396
094877b1
AC
397fun requestWhoHas perm =
398 let
399 val (_, bio) = requestBio (fn () => ())
400 in
401 Msg.send (bio, MsgWhoHas perm);
402 (case Msg.recv bio of
403 NONE => (print "Server closed connection unexpectedly.\n";
404 NONE)
405 | SOME m =>
406 case m of
407 MsgWhoHasResponse users => SOME users
408 | MsgError s => (print ("whohas failed: " ^ s ^ "\n");
409 NONE)
410 | _ => (print "Unexpected server reply.\n";
411 NONE))
412 before OpenSSL.close bio
413 end
414
1824f573
AC
415fun requestRegen () =
416 let
417 val (_, bio) = requestBio (fn () => ())
418 in
419 Msg.send (bio, MsgRegenerate);
420 case Msg.recv bio of
421 NONE => print "Server closed connection unexpectedly.\n"
422 | SOME m =>
423 case m of
424 MsgOk => print "Regeneration succeeded.\n"
425 | MsgError s => print ("Regeneration failed: " ^ s ^ "\n")
426 | _ => print "Unexpected server reply.\n";
427 OpenSSL.close bio
428 end
429
c189cbe9
AC
430fun requestRmdom dom =
431 let
432 val (_, bio) = requestBio (fn () => ())
433 in
434 Msg.send (bio, MsgRmdom dom);
435 case Msg.recv bio of
436 NONE => print "Server closed connection unexpectedly.\n"
437 | SOME m =>
438 case m of
439 MsgOk => print "Removal succeeded.\n"
440 | MsgError s => print ("Removal failed: " ^ s ^ "\n")
441 | _ => print "Unexpected server reply.\n";
442 OpenSSL.close bio
443 end
444
e69e60cc
AC
445fun requestRmuser user =
446 let
447 val (_, bio) = requestBio (fn () => ())
448 in
449 Msg.send (bio, MsgRmuser user);
450 case Msg.recv bio of
451 NONE => print "Server closed connection unexpectedly.\n"
452 | SOME m =>
453 case m of
454 MsgOk => print "Removal succeeded.\n"
455 | MsgError s => print ("Removal failed: " ^ s ^ "\n")
456 | _ => print "Unexpected server reply.\n";
457 OpenSSL.close bio
458 end
459
d541c618
AC
460fun requestDbUser dbtype =
461 let
462 val (_, bio) = requestBio (fn () => ())
463 in
464 Msg.send (bio, MsgCreateDbUser dbtype);
465 case Msg.recv bio of
466 NONE => print "Server closed connection unexpectedly.\n"
467 | SOME m =>
468 case m of
469 MsgOk => print "Your user has been created.\n"
470 | MsgError s => print ("Creation failed: " ^ s ^ "\n")
471 | _ => print "Unexpected server reply.\n";
472 OpenSSL.close bio
473 end
474
86aa5de7
AC
475fun requestDbPasswd rc =
476 let
477 val (_, bio) = requestBio (fn () => ())
478 in
479 Msg.send (bio, MsgDbPasswd rc);
480 case Msg.recv bio of
481 NONE => print "Server closed connection unexpectedly.\n"
482 | SOME m =>
483 case m of
484 MsgOk => print "Your password has been changed.\n"
485 | MsgError s => print ("Password set failed: " ^ s ^ "\n")
486 | _ => print "Unexpected server reply.\n";
487 OpenSSL.close bio
488 end
489
90dd48df
AC
490fun requestDbTable p =
491 let
492 val (user, bio) = requestBio (fn () => ())
493 in
494 Msg.send (bio, MsgCreateDbTable p);
495 case Msg.recv bio of
496 NONE => print "Server closed connection unexpectedly.\n"
497 | SOME m =>
498 case m of
499 MsgOk => print ("Your database " ^ user ^ "_" ^ #dbname p ^ " has been created.\n")
500 | MsgError s => print ("Creation failed: " ^ s ^ "\n")
501 | _ => print "Unexpected server reply.\n";
502 OpenSSL.close bio
503 end
504
1d3ef80e
AC
505fun requestListMailboxes domain =
506 let
507 val (_, bio) = requestBio (fn () => ())
508 in
509 Msg.send (bio, MsgListMailboxes domain);
510 (case Msg.recv bio of
2e96b9d4 511 NONE => Vmail.Error "Server closed connection unexpectedly."
1d3ef80e
AC
512 | SOME m =>
513 case m of
514 MsgMailboxes users => (Msg.send (bio, MsgOk);
515 Vmail.Listing users)
516 | MsgError s => Vmail.Error ("Creation failed: " ^ s)
2e96b9d4 517 | _ => Vmail.Error "Unexpected server reply.")
1d3ef80e
AC
518 before OpenSSL.close bio
519 end
520
08688401
AC
521fun requestNewMailbox p =
522 let
523 val (_, bio) = requestBio (fn () => ())
524 in
525 Msg.send (bio, MsgNewMailbox p);
526 case Msg.recv bio of
527 NONE => print "Server closed connection unexpectedly.\n"
528 | SOME m =>
529 case m of
530 MsgOk => print ("A mapping for " ^ #user p ^ "@" ^ #domain p ^ " has been created.\n")
531 | MsgError s => print ("Creation failed: " ^ s ^ "\n")
532 | _ => print "Unexpected server reply.\n";
533 OpenSSL.close bio
534 end
535
536fun requestPasswdMailbox p =
537 let
538 val (_, bio) = requestBio (fn () => ())
539 in
540 Msg.send (bio, MsgPasswdMailbox p);
541 case Msg.recv bio of
542 NONE => print "Server closed connection unexpectedly.\n"
543 | SOME m =>
544 case m of
545 MsgOk => print ("The password for " ^ #user p ^ "@" ^ #domain p ^ " has been changed.\n")
546 | MsgError s => print ("Set failed: " ^ s ^ "\n")
547 | _ => print "Unexpected server reply.\n";
548 OpenSSL.close bio
549 end
550
551fun requestRmMailbox p =
552 let
553 val (_, bio) = requestBio (fn () => ())
554 in
555 Msg.send (bio, MsgRmMailbox p);
556 case Msg.recv bio of
557 NONE => print "Server closed connection unexpectedly.\n"
558 | SOME m =>
559 case m of
560 MsgOk => print ("The mapping for mailbox " ^ #user p ^ "@" ^ #domain p ^ " has been deleted.\n")
561 | MsgError s => print ("Remove failed: " ^ s ^ "\n")
562 | _ => print "Unexpected server reply.\n";
563 OpenSSL.close bio
564 end
565
2e96b9d4
AC
566fun requestSaQuery addr =
567 let
568 val (_, bio) = requestBio (fn () => ())
569 in
570 Msg.send (bio, MsgSaQuery addr);
571 (case Msg.recv bio of
572 NONE => print "Server closed connection unexpectedly.\n"
573 | SOME m =>
574 case m of
575 MsgSaStatus b => (print ("SpamAssassin filtering for " ^ addr ^ " is "
576 ^ (if b then "ON" else "OFF") ^ ".\n");
577 Msg.send (bio, MsgOk))
578 | MsgError s => print ("Query failed: " ^ s ^ "\n")
579 | _ => print "Unexpected server reply.\n")
580 before OpenSSL.close bio
581 end
582
583fun requestSaSet p =
584 let
585 val (_, bio) = requestBio (fn () => ())
586 in
587 Msg.send (bio, MsgSaSet p);
588 case Msg.recv bio of
589 NONE => print "Server closed connection unexpectedly.\n"
590 | SOME m =>
591 case m of
592 MsgOk => print ("SpamAssassin filtering for " ^ #1 p ^ " is now "
593 ^ (if #2 p then "ON" else "OFF") ^ ".\n")
594 | MsgError s => print ("Set failed: " ^ s ^ "\n")
595 | _ => print "Unexpected server reply.\n";
596 OpenSSL.close bio
597 end
598
2bc5ed22
AC
599fun requestSmtpLog domain =
600 let
601 val (_, bio) = requestBio (fn () => ())
602
603 val _ = Msg.send (bio, MsgSmtpLogReq domain)
604
605 fun loop () =
606 case Msg.recv bio of
607 NONE => print "Server closed connection unexpectedly.\n"
608 | SOME m =>
609 case m of
610 MsgOk => ()
611 | MsgSmtpLogRes line => (print line;
612 loop ())
613 | MsgError s => print ("Log search failed: " ^ s ^ "\n")
614 | _ => print "Unexpected server reply.\n"
615 in
616 loop ();
617 OpenSSL.close bio
618 end
619
75585a67
AC
620fun requestApt {node, pkg} =
621 let
a95a0107
AC
622 val (user, context) = requestContext (fn () => ())
623 val bio = OpenSSL.connect (context, if node = Config.masterNode then
624 dispatcher
625 else
626 Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
75585a67 627
a95a0107 628 val _ = Msg.send (bio, MsgQuery (QApt pkg))
75585a67
AC
629
630 fun loop () =
631 case Msg.recv bio of
632 NONE => (print "Server closed connection unexpectedly.\n";
633 OS.Process.failure)
634 | SOME m =>
635 case m of
636 MsgYes => (print "Package is installed.\n";
637 OS.Process.success)
638 | MsgNo => (print "Package is not installed.\n";
639 OS.Process.failure)
640 | MsgError s => (print ("APT query failed: " ^ s ^ "\n");
641 OS.Process.failure)
642 | _ => (print "Unexpected server reply.\n";
643 OS.Process.failure)
644 in
645 loop ()
646 before OpenSSL.close bio
647 end
648
d351d679
AC
649fun requestCron {node, uname} =
650 let
651 val (user, context) = requestContext (fn () => ())
652 val bio = OpenSSL.connect (context, if node = Config.masterNode then
653 dispatcher
654 else
655 Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
656
657 val _ = Msg.send (bio, MsgQuery (QCron uname))
658
659 fun loop () =
660 case Msg.recv bio of
661 NONE => (print "Server closed connection unexpectedly.\n";
662 OS.Process.failure)
663 | SOME m =>
664 case m of
665 MsgYes => (print "User has cron permissions.\n";
666 OS.Process.success)
667 | MsgNo => (print "User does not have cron permissions.\n";
668 OS.Process.failure)
669 | MsgError s => (print ("Cron query failed: " ^ s ^ "\n");
670 OS.Process.failure)
671 | _ => (print "Unexpected server reply.\n";
672 OS.Process.failure)
673 in
674 loop ()
675 before OpenSSL.close bio
676 end
677
678fun requestFtp {node, uname} =
679 let
680 val (user, context) = requestContext (fn () => ())
681 val bio = OpenSSL.connect (context, if node = Config.masterNode then
682 dispatcher
683 else
684 Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
685
686 val _ = Msg.send (bio, MsgQuery (QFtp uname))
687
688 fun loop () =
689 case Msg.recv bio of
690 NONE => (print "Server closed connection unexpectedly.\n";
691 OS.Process.failure)
692 | SOME m =>
693 case m of
694 MsgYes => (print "User has FTP permissions.\n";
695 OS.Process.success)
696 | MsgNo => (print "User does not have FTP permissions.\n";
697 OS.Process.failure)
698 | MsgError s => (print ("FTP query failed: " ^ s ^ "\n");
699 OS.Process.failure)
700 | _ => (print "Unexpected server reply.\n";
701 OS.Process.failure)
702 in
703 loop ()
704 before OpenSSL.close bio
705 end
706
4d5126e1
AC
707fun requestTrustedPath {node, uname} =
708 let
709 val (user, context) = requestContext (fn () => ())
710 val bio = OpenSSL.connect (context, if node = Config.masterNode then
711 dispatcher
712 else
713 Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
714
715 val _ = Msg.send (bio, MsgQuery (QTrustedPath uname))
716
717 fun loop () =
718 case Msg.recv bio of
719 NONE => (print "Server closed connection unexpectedly.\n";
720 OS.Process.failure)
721 | SOME m =>
722 case m of
723 MsgYes => (print "User has trusted path restriction.\n";
724 OS.Process.success)
725 | MsgNo => (print "User does not have trusted path restriction.\n";
726 OS.Process.failure)
727 | MsgError s => (print ("Trusted path query failed: " ^ s ^ "\n");
728 OS.Process.failure)
729 | _ => (print "Unexpected server reply.\n";
730 OS.Process.failure)
731 in
732 loop ()
733 before OpenSSL.close bio
734 end
735
737c68d4
AC
736fun requestSocketPerm {node, uname} =
737 let
738 val (user, context) = requestContext (fn () => ())
739 val bio = OpenSSL.connect (context, if node = Config.masterNode then
740 dispatcher
741 else
742 Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
743
744 val _ = Msg.send (bio, MsgQuery (QSocket uname))
745
746 fun loop () =
747 case Msg.recv bio of
748 NONE => (print "Server closed connection unexpectedly.\n";
749 OS.Process.failure)
750 | SOME m =>
751 case m of
752 MsgSocket p => (case p of
753 Any => print "Any\n"
754 | Client => print "Client\n"
755 | Server => print "Server\n"
756 | Nada => print "Nada\n";
757 OS.Process.success)
758 | MsgError s => (print ("Socket permission query failed: " ^ s ^ "\n");
759 OS.Process.failure)
760 | _ => (print "Unexpected server reply.\n";
761 OS.Process.failure)
762 in
763 loop ()
764 before OpenSSL.close bio
765 end
766
f9548f16
AC
767fun requestFirewall {node, uname} =
768 let
769 val (user, context) = requestContext (fn () => ())
770 val bio = OpenSSL.connect (context, if node = Config.masterNode then
771 dispatcher
772 else
773 Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
774
775 val _ = Msg.send (bio, MsgQuery (QFirewall uname))
776
777 fun loop () =
778 case Msg.recv bio of
779 NONE => (print "Server closed connection unexpectedly.\n";
780 OS.Process.failure)
781 | SOME m =>
782 case m of
783 MsgFirewall ls => (app (fn s => (print s; print "\n")) ls;
784 OS.Process.success)
785 | MsgError s => (print ("Firewall query failed: " ^ s ^ "\n");
786 OS.Process.failure)
787 | _ => (print "Unexpected server reply.\n";
788 OS.Process.failure)
789 in
790 loop ()
791 before OpenSSL.close bio
792 end
793
71420f8b 794fun regenerate context =
1824f573 795 let
6f3525e4
AC
796 val _ = ErrorMsg.reset ()
797
1824f573 798 val b = basis ()
71420f8b
AC
799 val () = Tycheck.disallowExterns ()
800
801 val () = Domain.resetGlobal ()
802
803 fun contactNode (node, ip) =
804 if node = Config.defaultNode then
805 Domain.resetLocal ()
806 else let
807 val bio = OpenSSL.connect (context,
808 ip
809 ^ ":"
810 ^ Int.toString Config.slavePort)
811 in
812 Msg.send (bio, MsgRegenerate);
813 case Msg.recv bio of
814 NONE => print "Slave closed connection unexpectedly\n"
815 | SOME m =>
816 case m of
817 MsgOk => print ("Slave " ^ node ^ " pre-regeneration finished\n")
818 | MsgError s => print ("Slave " ^ node
819 ^ " returned error: " ^
820 s ^ "\n")
821 | _ => print ("Slave " ^ node
822 ^ " returned unexpected command\n");
823 OpenSSL.close bio
824 end
1824f573
AC
825
826 fun doUser user =
827 let
828 val _ = Domain.setUser user
829 val _ = ErrorMsg.reset ()
830
831 val dname = Config.domtoolDir user
832
833 val dir = Posix.FileSys.opendir dname
834
835 fun loop files =
836 case Posix.FileSys.readdir dir of
837 NONE => (Posix.FileSys.closedir dir;
838 files)
839 | SOME fname =>
840 if notTmp fname then
841 loop (OS.Path.joinDirFile {dir = dname,
842 file = fname}
843 :: files)
844 else
845 loop files
846
847 val files = loop []
848 val (_, files) = Order.order (SOME b) files
849 in
850 if !ErrorMsg.anyErrors then
45f333d9
AC
851 (ErrorMsg.reset ();
852 print ("User " ^ user ^ "'s configuration has errors!\n"))
1824f573
AC
853 else
854 app eval' files
855 end
856 handle IO.Io _ => ()
857 | OS.SysErr (s, _) => print ("System error processing user " ^ user ^ ": " ^ s ^ "\n")
45f333d9
AC
858 | ErrorMsg.Error => (ErrorMsg.reset ();
859 print ("User " ^ user ^ " had a compilation error.\n"))
809b0173 860 | _ => print "Unknown exception during regeneration!\n"
1824f573 861 in
71420f8b 862 app contactNode Config.nodeIps;
1824f573
AC
863 Env.pre ();
864 app doUser (Acl.users ());
865 Env.post ()
866 end
867
e69e60cc
AC
868fun rmuser user =
869 let
870 val doms = Acl.class {user = user, class = "domain"}
871 val doms = List.filter (fn dom =>
872 case Acl.whoHas {class = "domain", value = dom} of
873 [_] => true
874 | _ => false) (StringSet.listItems doms)
875 in
876 Acl.rmuser user;
877 Domain.rmdom doms
878 end
879
c9731b9b
AC
880fun now () = Date.toString (Date.fromTimeUniv (Time.now ()))
881
a95a0107
AC
882fun answerQuery q =
883 case q of
884 QApt pkg => if Apt.installed pkg then MsgYes else MsgNo
d351d679
AC
885 | QCron user => if Cron.allowed user then MsgYes else MsgNo
886 | QFtp user => if Ftp.allowed user then MsgYes else MsgNo
4d5126e1 887 | QTrustedPath user => if TrustedPath.query user then MsgYes else MsgNo
737c68d4 888 | QSocket user => MsgSocket (SocketPerm.query user)
f9548f16 889 | QFirewall user => MsgFirewall (Firewall.query user)
a95a0107
AC
890
891fun describeQuery q =
892 case q of
893 QApt pkg => "Requested installation status of package " ^ pkg
d351d679
AC
894 | QCron user => "Asked about cron permissions for user " ^ user
895 | QFtp user => "Asked about FTP permissions for user " ^ user
4d5126e1 896 | QTrustedPath user => "Asked about trusted path settings for user " ^ user
737c68d4 897 | QSocket user => "Asked about socket permissions for user " ^ user
f9548f16 898 | QFirewall user => "Asked about firewall rules for user " ^ user
a95a0107 899
3b267643 900fun service () =
07cc384c 901 let
aa56e112
AC
902 val () = Acl.read Config.aclFile
903
d22c1f00
AC
904 val context = context (Config.serverCert,
905 Config.serverKey,
906 Config.trustStore)
36e42cb8 907 val _ = Domain.set_context context
3b267643 908
60534712 909 val sock = OpenSSL.listen (context, Config.dispatcherPort)
3b267643
AC
910
911 fun loop () =
60534712 912 case OpenSSL.accept sock of
3b267643
AC
913 NONE => ()
914 | SOME bio =>
915 let
aa56e112 916 val user = OpenSSL.peerCN bio
c9731b9b 917 val () = print ("\nConnection from " ^ user ^ " at " ^ now () ^ "\n")
aa56e112
AC
918 val () = Domain.setUser user
919
08688401
AC
920 fun doIt f cleanup =
921 ((case f () of
922 (msgLocal, SOME msgRemote) =>
923 (print msgLocal;
924 print "\n";
925 Msg.send (bio, MsgError msgRemote))
926 | (msgLocal, NONE) =>
927 (print msgLocal;
928 print "\n";
929 Msg.send (bio, MsgOk)))
930 handle OpenSSL.OpenSSL _ =>
931 print "OpenSSL error\n"
932 | OS.SysErr (s, _) =>
933 (print "System error: ";
934 print s;
935 print "\n";
936 Msg.send (bio, MsgError ("System error: " ^ s))
937 handle OpenSSL.OpenSSL _ => ())
938 | Fail s =>
939 (print "Failure: ";
940 print s;
941 print "\n";
942 Msg.send (bio, MsgError ("Failure: " ^ s))
943 handle OpenSSL.OpenSSL _ => ())
944 | ErrorMsg.Error =>
945 (print "Compilation error\n";
946 Msg.send (bio, MsgError "Error during configuration evaluation")
947 handle OpenSSL.OpenSSL _ => ());
948 (cleanup ();
949 ignore (OpenSSL.readChar bio);
950 OpenSSL.close bio)
951 handle OpenSSL.OpenSSL _ => ();
952 loop ())
953
c53e82e4
AC
954 fun doConfig codes =
955 let
956 val _ = print "Configuration:\n"
957 val _ = app (fn s => (print s; print "\n")) codes
958 val _ = print "\n"
959
960 val outname = OS.FileSys.tmpName ()
961
962 fun doOne code =
963 let
964 val outf = TextIO.openOut outname
965 in
966 TextIO.output (outf, code);
967 TextIO.closeOut outf;
1824f573 968 eval' outname
c53e82e4
AC
969 end
970 in
08688401
AC
971 doIt (fn () => (Env.pre ();
972 app doOne codes;
973 Env.post ();
974 Msg.send (bio, MsgOk);
975 ("Configuration complete.", NONE)))
976 (fn () => OS.FileSys.remove outname)
c53e82e4
AC
977 end
978
2e96b9d4
AC
979 fun checkAddr s =
980 case String.fields (fn ch => ch = #"@") s of
981 [user'] =>
982 if user = user' then
983 SOME (SetSA.User s)
984 else
985 NONE
986 | [user', domain] =>
987 if Domain.validEmailUser user' andalso Domain.yourDomain domain then
988 SOME (SetSA.Email s)
989 else
990 NONE
991 | _ => NONE
992
36e42cb8
AC
993 fun cmdLoop () =
994 case Msg.recv bio of
995 NONE => (OpenSSL.close bio
996 handle OpenSSL.OpenSSL _ => ();
997 loop ())
998 | SOME m =>
999 case m of
c53e82e4
AC
1000 MsgConfig code => doConfig [code]
1001 | MsgMultiConfig codes => doConfig codes
5ee41dd0 1002
9f27d58f 1003 | MsgShutdown =>
62260c5f
AC
1004 if Acl.query {user = user, class = "priv", value = "all"}
1005 orelse Acl.query {user = user, class = "priv", value = "shutdown"} then
c9731b9b 1006 print ("Domtool dispatcher shutting down at " ^ now () ^ "\n\n")
9f27d58f 1007 else
62260c5f
AC
1008 (print "Unauthorized shutdown command!\n";
1009 OpenSSL.close bio
9f27d58f
AC
1010 handle OpenSSL.OpenSSL _ => ();
1011 loop ())
1012
5ee41dd0 1013 | MsgGrant acl =>
08688401
AC
1014 doIt (fn () =>
1015 if Acl.query {user = user, class = "priv", value = "all"} then
1016 (Acl.grant acl;
1017 Acl.write Config.aclFile;
1018 ("Granted permission " ^ #value acl ^ " to " ^ #user acl ^ " in " ^ #class acl ^ ".",
1019 NONE))
1020 else
1021 ("Unauthorized user asked to grant a permission!",
1022 SOME "Not authorized to grant privileges"))
1023 (fn () => ())
1024
411a85f2 1025 | MsgRevoke acl =>
08688401
AC
1026 doIt (fn () =>
1027 if Acl.query {user = user, class = "priv", value = "all"} then
1028 (Acl.revoke acl;
1029 Acl.write Config.aclFile;
1030 ("Revoked permission " ^ #value acl ^ " from " ^ #user acl ^ " in " ^ #class acl ^ ".",
1031 NONE))
1032 else
1033 ("Unauthorized user asked to revoke a permission!",
1034 SOME "Not authorized to revoke privileges"))
1035 (fn () => ())
5ee41dd0 1036
08a04eb4 1037 | MsgListPerms user =>
08688401
AC
1038 doIt (fn () =>
1039 (Msg.send (bio, MsgPerms (Acl.queryAll user));
1040 ("Sent permission list for user " ^ user ^ ".",
1041 NONE)))
1042 (fn () => ())
08a04eb4 1043
094877b1 1044 | MsgWhoHas perm =>
08688401
AC
1045 doIt (fn () =>
1046 (Msg.send (bio, MsgWhoHasResponse (Acl.whoHas perm));
1047 ("Sent whohas response for " ^ #class perm ^ " / " ^ #value perm ^ ".",
1048 NONE)))
1049 (fn () => ())
094877b1 1050
e69e60cc 1051 | MsgRmdom doms =>
08688401
AC
1052 doIt (fn () =>
1053 if Acl.query {user = user, class = "priv", value = "all"}
1054 orelse List.all (fn dom => Acl.query {user = user, class = "domain", value = dom}) doms then
1055 (Domain.rmdom doms;
1056 app (fn dom =>
1057 Acl.revokeFromAll {class = "domain", value = dom}) doms;
1058 Acl.write Config.aclFile;
1059 ("Removed domains" ^ foldl (fn (d, s) => s ^ " " ^ d) "" doms ^ ".",
1060 NONE))
1061 else
1062 ("Unauthorized user asked to remove a domain!",
1063 SOME "Not authorized to remove that domain"))
1064 (fn () => ())
1824f573
AC
1065
1066 | MsgRegenerate =>
08688401
AC
1067 doIt (fn () =>
1068 if Acl.query {user = user, class = "priv", value = "regen"}
1069 orelse Acl.query {user = user, class = "priv", value = "all"} then
1070 (regenerate context;
1071 ("Regenerated all configuration.",
1072 NONE))
1073 else
1074 ("Unauthorized user asked to regenerate!",
1075 SOME "Not authorized to regenerate"))
1076 (fn () => ())
e69e60cc 1077
05323cbc 1078 | MsgRmuser user' =>
08688401
AC
1079 doIt (fn () =>
1080 if Acl.query {user = user, class = "priv", value = "all"} then
1081 (rmuser user';
1082 Acl.write Config.aclFile;
1083 ("Removed user " ^ user' ^ ".",
1084 NONE))
1085 else
1086 ("Unauthorized user asked to remove a user!",
1087 SOME "Not authorized to remove users"))
1088 (fn () => ())
d541c618 1089
21d921a5 1090 | MsgCreateDbUser {dbtype, passwd} =>
08688401
AC
1091 doIt (fn () =>
1092 case Dbms.lookup dbtype of
1093 NONE => ("Database user creation request with unknown datatype type " ^ dbtype,
1094 SOME ("Unknown database type " ^ dbtype))
1095 | SOME handler =>
1096 case #adduser handler {user = user, passwd = passwd} of
1097 NONE => ("Added " ^ dbtype ^ " user " ^ user ^ ".",
1098 NONE)
1099 | SOME msg =>
1100 ("Error adding a " ^ dbtype ^ " user " ^ user ^ ": " ^ msg,
1101 SOME ("Error adding user: " ^ msg)))
1102 (fn () => ())
c189cbe9 1103
86aa5de7
AC
1104 | MsgDbPasswd {dbtype, passwd} =>
1105 doIt (fn () =>
1106 case Dbms.lookup dbtype of
1107 NONE => ("Database passwd request with unknown datatype type " ^ dbtype,
1108 SOME ("Unknown database type " ^ dbtype))
1109 | SOME handler =>
1110 case #passwd handler {user = user, passwd = passwd} of
1111 NONE => ("Changed " ^ dbtype ^ " password of user " ^ user ^ ".",
1112 NONE)
1113 | SOME msg =>
1114 ("Error setting " ^ dbtype ^ " password of user " ^ user ^ ": " ^ msg,
1115 SOME ("Error adding user: " ^ msg)))
1116 (fn () => ())
1117
90dd48df 1118 | MsgCreateDbTable {dbtype, dbname} =>
08688401
AC
1119 doIt (fn () =>
1120 if Dbms.validDbname dbname then
1121 case Dbms.lookup dbtype of
1122 NONE => ("Database creation request with unknown datatype type " ^ dbtype,
1123 SOME ("Unknown database type " ^ dbtype))
1124 | SOME handler =>
1125 case #createdb handler {user = user, dbname = dbname} of
1126 NONE => ("Created database " ^ user ^ "_" ^ dbname ^ ".",
1127 NONE)
1128 | SOME msg => ("Error creating database " ^ user ^ "_" ^ dbname ^ ": " ^ msg,
1129 SOME ("Error creating database: " ^ msg))
1130 else
1131 ("Invalid database name " ^ user ^ "_" ^ dbname,
1132 SOME ("Invalid database name " ^ dbname)))
1133 (fn () => ())
1134
1d3ef80e
AC
1135 | MsgListMailboxes domain =>
1136 doIt (fn () =>
1137 if not (Domain.yourDomain domain) then
1138 ("User wasn't authorized to list mailboxes for " ^ domain,
1139 SOME "You're not authorized to configure that domain.")
1140 else
1141 case Vmail.list domain of
1142 Vmail.Listing users => (Msg.send (bio, MsgMailboxes users);
1143 ("Sent mailbox list for " ^ domain,
1144 NONE))
1145 | Vmail.Error msg => ("Error listing mailboxes for " ^ domain ^ ": " ^ msg,
1146 SOME msg))
1147 (fn () => ())
1148
08688401
AC
1149 | MsgNewMailbox {domain, user = emailUser, passwd, mailbox} =>
1150 doIt (fn () =>
1151 if not (Domain.yourDomain domain) then
1152 ("User wasn't authorized to add a mailbox to " ^ domain,
1153 SOME "You're not authorized to configure that domain.")
2e96b9d4 1154 else if not (Domain.validEmailUser emailUser) then
08688401
AC
1155 ("Invalid e-mail username " ^ emailUser,
1156 SOME "Invalid e-mail username")
1157 else if not (CharVector.all Char.isGraph passwd) then
1158 ("Invalid password",
1159 SOME "Invalid password; may only contain printable, non-space characters")
1160 else if not (Domain.yourPath mailbox) then
1161 ("User wasn't authorized to add a mailbox at " ^ mailbox,
1162 SOME "You're not authorized to use that mailbox location.")
1163 else
1164 case Vmail.add {requester = user,
1165 domain = domain, user = emailUser,
1166 passwd = passwd, mailbox = mailbox} of
1167 NONE => ("Added mailbox " ^ emailUser ^ "@" ^ domain ^ " at " ^ mailbox,
1168 NONE)
9ffe2f0f 1169 | SOME msg => ("Error adding mailbox " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
08688401
AC
1170 SOME msg))
1171 (fn () => ())
1172
1173 | MsgPasswdMailbox {domain, user = emailUser, passwd} =>
1174 doIt (fn () =>
1175 if not (Domain.yourDomain domain) then
1176 ("User wasn't authorized to change password of a mailbox for " ^ domain,
1177 SOME "You're not authorized to configure that domain.")
2e96b9d4 1178 else if not (Domain.validEmailUser emailUser) then
08688401
AC
1179 ("Invalid e-mail username " ^ emailUser,
1180 SOME "Invalid e-mail username")
1181 else if not (CharVector.all Char.isGraph passwd) then
1182 ("Invalid password",
1183 SOME "Invalid password; may only contain printable, non-space characters")
1184 else
1185 case Vmail.passwd {domain = domain, user = emailUser,
1186 passwd = passwd} of
1187 NONE => ("Changed password of mailbox " ^ emailUser ^ "@" ^ domain,
1188 NONE)
9ffe2f0f 1189 | SOME msg => ("Error changing mailbox password for " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
08688401
AC
1190 SOME msg))
1191 (fn () => ())
1192
1193 | MsgRmMailbox {domain, user = emailUser} =>
1194 doIt (fn () =>
1195 if not (Domain.yourDomain domain) then
1196 ("User wasn't authorized to change password of a mailbox for " ^ domain,
1197 SOME "You're not authorized to configure that domain.")
2e96b9d4 1198 else if not (Domain.validEmailUser emailUser) then
08688401
AC
1199 ("Invalid e-mail username " ^ emailUser,
1200 SOME "Invalid e-mail username")
1201 else
1202 case Vmail.rm {domain = domain, user = emailUser} of
1203 NONE => ("Deleted mailbox " ^ emailUser ^ "@" ^ domain,
1204 NONE)
9ffe2f0f 1205 | SOME msg => ("Error deleting mailbox " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
08688401
AC
1206 SOME msg))
1207 (fn () => ())
90dd48df 1208
2e96b9d4
AC
1209 | MsgSaQuery addr =>
1210 doIt (fn () =>
1211 case checkAddr addr of
1212 NONE => ("User tried to query SA filtering for " ^ addr,
1213 SOME "You aren't allowed to configure SA filtering for that recipient.")
1214 | SOME addr' => (Msg.send (bio, MsgSaStatus (SetSA.query addr'));
1215 ("Queried SA filtering status for " ^ addr,
1216 NONE)))
1217 (fn () => ())
1218
1219 | MsgSaSet (addr, b) =>
1220 doIt (fn () =>
1221 case checkAddr addr of
1222 NONE => ("User tried to set SA filtering for " ^ addr,
1223 SOME "You aren't allowed to configure SA filtering for that recipient.")
1224 | SOME addr' => (SetSA.set (addr', b);
1225 Msg.send (bio, MsgOk);
1226 ("Set SA filtering status for " ^ addr ^ " to "
1227 ^ (if b then "ON" else "OFF"),
1228 NONE)))
1229 (fn () => ())
1230
2bc5ed22
AC
1231 | MsgSmtpLogReq domain =>
1232 doIt (fn () =>
1233 if not (Domain.yourDomain domain) then
1234 ("Unauthorized user tried to request SMTP logs for " ^ domain,
1235 SOME "You aren't authorized to configure that domain.")
1236 else
1237 (SmtpLog.search (fn line => Msg.send (bio, MsgSmtpLogRes line))
1238 domain;
1239 ("Requested SMTP logs for " ^ domain,
1240 NONE)))
1241 (fn () => ())
1242
a95a0107
AC
1243 | MsgQuery q =>
1244 doIt (fn () => (Msg.send (bio, answerQuery q);
1245 (describeQuery q,
75585a67
AC
1246 NONE)))
1247 (fn () => ())
1248
36e42cb8 1249 | _ =>
08688401
AC
1250 doIt (fn () => ("Unexpected command",
1251 SOME "Unexpected command"))
1252 (fn () => ())
36e42cb8
AC
1253 in
1254 cmdLoop ()
1255 end
97665758
AC
1256 handle OpenSSL.OpenSSL s =>
1257 (print ("OpenSSL error: " ^ s ^ "\n");
1258 OpenSSL.close bio
1259 handle OpenSSL.OpenSSL _ => ();
1260 loop ())
1261 | OS.SysErr (s, _) =>
1262 (print ("System error: " ^ s ^ "\n");
1263 OpenSSL.close bio
1264 handle OpenSSL.OpenSSL _ => ();
1265 loop ())
5cab5a98
AC
1266 | IO.Io {name, function, cause} =>
1267 (print ("IO error: " ^ function ^ " for " ^ name ^ "\n");
1268 app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory cause);
1269 OpenSSL.close bio
1270 handle OpenSSL.OpenSSL _ => ();
1271 loop ())
e0b80e65 1272 | e =>
809b0173 1273 (print "Unknown exception in main loop!\n";
e0b80e65 1274 app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);
809b0173
AC
1275 OpenSSL.close bio
1276 handle OpenSSL.OpenSSL _ => ();
1277 loop ())
36e42cb8 1278 in
c9731b9b 1279 print ("Domtool dispatcher starting up at " ^ now () ^ "\n");
361a1e7f 1280 print "Listening for connections....\n";
36e42cb8
AC
1281 loop ();
1282 OpenSSL.shutdown sock
1283 end
1284
1285fun slave () =
1286 let
6e62228d 1287 val host = Slave.hostname ()
36e42cb8 1288
d22c1f00
AC
1289 val context = context (Config.certDir ^ "/" ^ host ^ ".pem",
1290 Config.keyDir ^ "/" ^ host ^ "/key.pem",
1291 Config.trustStore)
36e42cb8
AC
1292
1293 val sock = OpenSSL.listen (context, Config.slavePort)
1294
c9731b9b
AC
1295 val _ = print ("Slave server starting at " ^ now () ^ "\n")
1296
36e42cb8
AC
1297 fun loop () =
1298 case OpenSSL.accept sock of
1299 NONE => ()
1300 | SOME bio =>
1301 let
1302 val peer = OpenSSL.peerCN bio
c9731b9b 1303 val () = print ("\nConnection from " ^ peer ^ " at " ^ now () ^ "\n")
3b267643 1304 in
c9731b9b 1305 if peer = Config.dispatcherName then let
36e42cb8
AC
1306 fun loop' files =
1307 case Msg.recv bio of
1308 NONE => print "Dispatcher closed connection unexpectedly\n"
1309 | SOME m =>
1310 case m of
1311 MsgFile file => loop' (file :: files)
1312 | MsgDoFiles => (Slave.handleChanges files;
1313 Msg.send (bio, MsgOk))
71420f8b
AC
1314 | MsgRegenerate => (Domain.resetLocal ();
1315 Msg.send (bio, MsgOk))
36e42cb8
AC
1316 | _ => (print "Dispatcher sent unexpected command\n";
1317 Msg.send (bio, MsgError "Unexpected command"))
1318 in
1319 loop' [];
1320 ignore (OpenSSL.readChar bio);
1321 OpenSSL.close bio;
1322 loop ()
1323 end
c9731b9b
AC
1324 else if peer = "domtool" then
1325 case Msg.recv bio of
1326 SOME MsgShutdown => (OpenSSL.close bio;
1327 print ("Shutting down at " ^ now () ^ "\n\n"))
1328 | _ => (OpenSSL.close bio;
1329 loop ())
1330 else
a95a0107
AC
1331 case Msg.recv bio of
1332 SOME (MsgQuery q) => (print (describeQuery q ^ "\n");
1333 Msg.send (bio, answerQuery q);
1334 ignore (OpenSSL.readChar bio);
1335 OpenSSL.close bio;
1336 loop ())
1337 | _ => (OpenSSL.close bio;
1338 loop ())
3196000d
AC
1339 end handle OpenSSL.OpenSSL s =>
1340 (print ("OpenSSL error: "^ s ^ "\n");
1341 OpenSSL.close bio
1342 handle OpenSSL.OpenSSL _ => ();
1343 loop ())
95a9abd1
AC
1344 | e as OS.SysErr (s, _) =>
1345 (app (fn s => print (s ^ "\n")) (SMLofNJ.exnHistory e);
1346 print ("System error: "^ s ^ "\n");
7af7d4cb
AC
1347 OpenSSL.close bio
1348 handle OpenSSL.OpenSSL _ => ();
1349 loop ())
07cc384c 1350 in
3b267643
AC
1351 loop ();
1352 OpenSSL.shutdown sock
07cc384c
AC
1353 end
1354
44a5ce2f 1355fun listBasis () =
3196000d
AC
1356 let
1357 val dir = Posix.FileSys.opendir Config.libRoot
1358
1359 fun loop files =
1360 case Posix.FileSys.readdir dir of
1361 NONE => (Posix.FileSys.closedir dir;
1362 files)
1363 | SOME fname =>
1364 if String.isSuffix ".dtl" fname then
1365 loop (OS.Path.joinDirFile {dir = Config.libRoot,
1366 file = fname}
1367 :: files)
1368 else
1369 loop files
3196000d 1370 in
44a5ce2f 1371 loop []
3196000d
AC
1372 end
1373
44a5ce2f
AC
1374fun autodocBasis outdir =
1375 Autodoc.autodoc {outdir = outdir, infiles = listBasis ()}
1376
234b917a 1377end