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