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