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