setsa
[hcoop/domtool2.git] / src / main.sml
CommitLineData
234b917a
AC
1(* HCoop Domtool (http://hcoop.sourceforge.net/)
2 * Copyright (c) 2006, Adam Chlipala
3 *
4 * This program is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU General Public License
6 * as published by the Free Software Foundation; either version 2
7 * of the License, or (at your option) any later version.
8 *
9 * This program is distributed in the hope that it will be useful,
10 * but WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 * GNU General Public License for more details.
13 *
14 * You should have received a copy of the GNU General Public License
15 * along with this program; if not, write to the Free Software
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
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
5ee41dd0 170fun requestContext f =
07cc384c 171 let
a56cc2c3
AC
172 val uid = Posix.ProcEnv.getuid ()
173 val user = Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid uid)
5ee41dd0 174
a56cc2c3
AC
175 val () = Acl.read Config.aclFile
176 val () = Domain.setUser user
5ee41dd0
AC
177
178 val () = f ()
aa56e112 179
aa56e112 180 val context = OpenSSL.context (Config.certDir ^ "/" ^ user ^ ".pem",
a088cea6 181 Config.keyDir ^ "/" ^ user ^ "/key.pem",
3b267643 182 Config.trustStore)
5ee41dd0
AC
183 in
184 (user, context)
185 end
07cc384c 186
5ee41dd0
AC
187fun requestBio f =
188 let
189 val (user, context) = requestContext f
190 in
191 (user, OpenSSL.connect (context, dispatcher))
192 end
193
194fun request fname =
195 let
196 val (user, bio) = requestBio (fn () => ignore (check fname))
559e89e9 197
3b267643
AC
198 val inf = TextIO.openIn fname
199
36e42cb8 200 fun loop lines =
3b267643 201 case TextIO.inputLine inf of
36e42cb8
AC
202 NONE => String.concat (List.rev lines)
203 | SOME line => loop (line :: lines)
204
205 val code = loop []
559e89e9 206 in
3b267643 207 TextIO.closeIn inf;
36e42cb8
AC
208 Msg.send (bio, MsgConfig code);
209 case Msg.recv bio of
210 NONE => print "Server closed connection unexpectedly.\n"
211 | SOME m =>
212 case m of
213 MsgOk => print "Configuration succeeded.\n"
214 | MsgError s => print ("Configuration failed: " ^ s ^ "\n")
215 | _ => print "Unexpected server reply.\n";
3b267643 216 OpenSSL.close bio
559e89e9 217 end
aa56e112 218 handle ErrorMsg.Error => ()
559e89e9 219
c53e82e4
AC
220fun requestDir dname =
221 let
1824f573
AC
222 val _ = ErrorMsg.reset ()
223
224 val (user, bio) = requestBio (fn () => checkDir dname)
c53e82e4
AC
225
226 val b = basis ()
227
228 val dir = Posix.FileSys.opendir dname
229
230 fun loop files =
231 case Posix.FileSys.readdir dir of
232 NONE => (Posix.FileSys.closedir dir;
233 files)
234 | SOME fname =>
235 if notTmp fname then
236 loop (OS.Path.joinDirFile {dir = dname,
237 file = fname}
238 :: files)
239 else
240 loop files
241
242 val files = loop []
243 val (_, files) = Order.order (SOME b) files
244
245 val _ = if !ErrorMsg.anyErrors then
246 raise ErrorMsg.Error
247 else
248 ()
249
250 val codes = map (fn fname =>
251 let
252 val inf = TextIO.openIn fname
253
254 fun loop lines =
255 case TextIO.inputLine inf of
256 NONE => String.concat (rev lines)
257 | SOME line => loop (line :: lines)
258 in
259 loop []
260 before TextIO.closeIn inf
261 end) files
262 in
1824f573
AC
263 if !ErrorMsg.anyErrors then
264 ()
265 else
266 (Msg.send (bio, MsgMultiConfig codes);
267 case Msg.recv bio of
268 NONE => print "Server closed connection unexpectedly.\n"
269 | SOME m =>
270 case m of
271 MsgOk => print "Configuration succeeded.\n"
272 | MsgError s => print ("Configuration failed: " ^ s ^ "\n")
273 | _ => print "Unexpected server reply.\n";
274 OpenSSL.close bio)
c53e82e4
AC
275 end
276 handle ErrorMsg.Error => ()
277
5ee41dd0
AC
278fun requestGrant acl =
279 let
280 val (user, bio) = requestBio (fn () => ())
281 in
282 Msg.send (bio, MsgGrant acl);
283 case Msg.recv bio of
284 NONE => print "Server closed connection unexpectedly.\n"
285 | SOME m =>
286 case m of
287 MsgOk => print "Grant succeeded.\n"
288 | MsgError s => print ("Grant failed: " ^ s ^ "\n")
289 | _ => print "Unexpected server reply.\n";
290 OpenSSL.close bio
291 end
292
411a85f2
AC
293fun requestRevoke acl =
294 let
295 val (user, bio) = requestBio (fn () => ())
296 in
297 Msg.send (bio, MsgRevoke acl);
298 case Msg.recv bio of
299 NONE => print "Server closed connection unexpectedly.\n"
300 | SOME m =>
301 case m of
302 MsgOk => print "Revoke succeeded.\n"
303 | MsgError s => print ("Revoke failed: " ^ s ^ "\n")
304 | _ => print "Unexpected server reply.\n";
305 OpenSSL.close bio
306 end
307
08a04eb4
AC
308fun requestListPerms user =
309 let
310 val (_, bio) = requestBio (fn () => ())
311 in
312 Msg.send (bio, MsgListPerms user);
313 (case Msg.recv bio of
314 NONE => (print "Server closed connection unexpectedly.\n";
315 NONE)
316 | SOME m =>
317 case m of
318 MsgPerms perms => SOME perms
319 | MsgError s => (print ("Listing failed: " ^ s ^ "\n");
320 NONE)
321 | _ => (print "Unexpected server reply.\n";
322 NONE))
323 before OpenSSL.close bio
324 end
325
094877b1
AC
326fun requestWhoHas perm =
327 let
328 val (_, bio) = requestBio (fn () => ())
329 in
330 Msg.send (bio, MsgWhoHas perm);
331 (case Msg.recv bio of
332 NONE => (print "Server closed connection unexpectedly.\n";
333 NONE)
334 | SOME m =>
335 case m of
336 MsgWhoHasResponse users => SOME users
337 | MsgError s => (print ("whohas failed: " ^ s ^ "\n");
338 NONE)
339 | _ => (print "Unexpected server reply.\n";
340 NONE))
341 before OpenSSL.close bio
342 end
343
1824f573
AC
344fun requestRegen () =
345 let
346 val (_, bio) = requestBio (fn () => ())
347 in
348 Msg.send (bio, MsgRegenerate);
349 case Msg.recv bio of
350 NONE => print "Server closed connection unexpectedly.\n"
351 | SOME m =>
352 case m of
353 MsgOk => print "Regeneration succeeded.\n"
354 | MsgError s => print ("Regeneration failed: " ^ s ^ "\n")
355 | _ => print "Unexpected server reply.\n";
356 OpenSSL.close bio
357 end
358
c189cbe9
AC
359fun requestRmdom dom =
360 let
361 val (_, bio) = requestBio (fn () => ())
362 in
363 Msg.send (bio, MsgRmdom dom);
364 case Msg.recv bio of
365 NONE => print "Server closed connection unexpectedly.\n"
366 | SOME m =>
367 case m of
368 MsgOk => print "Removal succeeded.\n"
369 | MsgError s => print ("Removal failed: " ^ s ^ "\n")
370 | _ => print "Unexpected server reply.\n";
371 OpenSSL.close bio
372 end
373
e69e60cc
AC
374fun requestRmuser user =
375 let
376 val (_, bio) = requestBio (fn () => ())
377 in
378 Msg.send (bio, MsgRmuser user);
379 case Msg.recv bio of
380 NONE => print "Server closed connection unexpectedly.\n"
381 | SOME m =>
382 case m of
383 MsgOk => print "Removal succeeded.\n"
384 | MsgError s => print ("Removal failed: " ^ s ^ "\n")
385 | _ => print "Unexpected server reply.\n";
386 OpenSSL.close bio
387 end
388
d541c618
AC
389fun requestDbUser dbtype =
390 let
391 val (_, bio) = requestBio (fn () => ())
392 in
393 Msg.send (bio, MsgCreateDbUser dbtype);
394 case Msg.recv bio of
395 NONE => print "Server closed connection unexpectedly.\n"
396 | SOME m =>
397 case m of
398 MsgOk => print "Your user has been created.\n"
399 | MsgError s => print ("Creation failed: " ^ s ^ "\n")
400 | _ => print "Unexpected server reply.\n";
401 OpenSSL.close bio
402 end
403
90dd48df
AC
404fun requestDbTable p =
405 let
406 val (user, bio) = requestBio (fn () => ())
407 in
408 Msg.send (bio, MsgCreateDbTable p);
409 case Msg.recv bio of
410 NONE => print "Server closed connection unexpectedly.\n"
411 | SOME m =>
412 case m of
413 MsgOk => print ("Your database " ^ user ^ "_" ^ #dbname p ^ " has been created.\n")
414 | MsgError s => print ("Creation failed: " ^ s ^ "\n")
415 | _ => print "Unexpected server reply.\n";
416 OpenSSL.close bio
417 end
418
1d3ef80e
AC
419fun requestListMailboxes domain =
420 let
421 val (_, bio) = requestBio (fn () => ())
422 in
423 Msg.send (bio, MsgListMailboxes domain);
424 (case Msg.recv bio of
2e96b9d4 425 NONE => Vmail.Error "Server closed connection unexpectedly."
1d3ef80e
AC
426 | SOME m =>
427 case m of
428 MsgMailboxes users => (Msg.send (bio, MsgOk);
429 Vmail.Listing users)
430 | MsgError s => Vmail.Error ("Creation failed: " ^ s)
2e96b9d4 431 | _ => Vmail.Error "Unexpected server reply.")
1d3ef80e
AC
432 before OpenSSL.close bio
433 end
434
08688401
AC
435fun requestNewMailbox p =
436 let
437 val (_, bio) = requestBio (fn () => ())
438 in
439 Msg.send (bio, MsgNewMailbox p);
440 case Msg.recv bio of
441 NONE => print "Server closed connection unexpectedly.\n"
442 | SOME m =>
443 case m of
444 MsgOk => print ("A mapping for " ^ #user p ^ "@" ^ #domain p ^ " has been created.\n")
445 | MsgError s => print ("Creation failed: " ^ s ^ "\n")
446 | _ => print "Unexpected server reply.\n";
447 OpenSSL.close bio
448 end
449
450fun requestPasswdMailbox p =
451 let
452 val (_, bio) = requestBio (fn () => ())
453 in
454 Msg.send (bio, MsgPasswdMailbox p);
455 case Msg.recv bio of
456 NONE => print "Server closed connection unexpectedly.\n"
457 | SOME m =>
458 case m of
459 MsgOk => print ("The password for " ^ #user p ^ "@" ^ #domain p ^ " has been changed.\n")
460 | MsgError s => print ("Set failed: " ^ s ^ "\n")
461 | _ => print "Unexpected server reply.\n";
462 OpenSSL.close bio
463 end
464
465fun requestRmMailbox p =
466 let
467 val (_, bio) = requestBio (fn () => ())
468 in
469 Msg.send (bio, MsgRmMailbox p);
470 case Msg.recv bio of
471 NONE => print "Server closed connection unexpectedly.\n"
472 | SOME m =>
473 case m of
474 MsgOk => print ("The mapping for mailbox " ^ #user p ^ "@" ^ #domain p ^ " has been deleted.\n")
475 | MsgError s => print ("Remove failed: " ^ s ^ "\n")
476 | _ => print "Unexpected server reply.\n";
477 OpenSSL.close bio
478 end
479
2e96b9d4
AC
480fun requestSaQuery addr =
481 let
482 val (_, bio) = requestBio (fn () => ())
483 in
484 Msg.send (bio, MsgSaQuery addr);
485 (case Msg.recv bio of
486 NONE => print "Server closed connection unexpectedly.\n"
487 | SOME m =>
488 case m of
489 MsgSaStatus b => (print ("SpamAssassin filtering for " ^ addr ^ " is "
490 ^ (if b then "ON" else "OFF") ^ ".\n");
491 Msg.send (bio, MsgOk))
492 | MsgError s => print ("Query failed: " ^ s ^ "\n")
493 | _ => print "Unexpected server reply.\n")
494 before OpenSSL.close bio
495 end
496
497fun requestSaSet p =
498 let
499 val (_, bio) = requestBio (fn () => ())
500 in
501 Msg.send (bio, MsgSaSet p);
502 case Msg.recv bio of
503 NONE => print "Server closed connection unexpectedly.\n"
504 | SOME m =>
505 case m of
506 MsgOk => print ("SpamAssassin filtering for " ^ #1 p ^ " is now "
507 ^ (if #2 p then "ON" else "OFF") ^ ".\n")
508 | MsgError s => print ("Set failed: " ^ s ^ "\n")
509 | _ => print "Unexpected server reply.\n";
510 OpenSSL.close bio
511 end
512
71420f8b 513fun regenerate context =
1824f573
AC
514 let
515 val b = basis ()
71420f8b
AC
516 val () = Tycheck.disallowExterns ()
517
518 val () = Domain.resetGlobal ()
519
520 fun contactNode (node, ip) =
521 if node = Config.defaultNode then
522 Domain.resetLocal ()
523 else let
524 val bio = OpenSSL.connect (context,
525 ip
526 ^ ":"
527 ^ Int.toString Config.slavePort)
528 in
529 Msg.send (bio, MsgRegenerate);
530 case Msg.recv bio of
531 NONE => print "Slave closed connection unexpectedly\n"
532 | SOME m =>
533 case m of
534 MsgOk => print ("Slave " ^ node ^ " pre-regeneration finished\n")
535 | MsgError s => print ("Slave " ^ node
536 ^ " returned error: " ^
537 s ^ "\n")
538 | _ => print ("Slave " ^ node
539 ^ " returned unexpected command\n");
540 OpenSSL.close bio
541 end
1824f573
AC
542
543 fun doUser user =
544 let
545 val _ = Domain.setUser user
546 val _ = ErrorMsg.reset ()
547
548 val dname = Config.domtoolDir user
549
550 val dir = Posix.FileSys.opendir dname
551
552 fun loop files =
553 case Posix.FileSys.readdir dir of
554 NONE => (Posix.FileSys.closedir dir;
555 files)
556 | SOME fname =>
557 if notTmp fname then
558 loop (OS.Path.joinDirFile {dir = dname,
559 file = fname}
560 :: files)
561 else
562 loop files
563
564 val files = loop []
565 val (_, files) = Order.order (SOME b) files
566 in
567 if !ErrorMsg.anyErrors then
568 print ("User " ^ user ^ "'s configuration has errors!\n")
569 else
570 app eval' files
571 end
572 handle IO.Io _ => ()
573 | OS.SysErr (s, _) => print ("System error processing user " ^ user ^ ": " ^ s ^ "\n")
574 in
71420f8b 575 app contactNode Config.nodeIps;
1824f573
AC
576 Env.pre ();
577 app doUser (Acl.users ());
578 Env.post ()
579 end
580
e69e60cc
AC
581fun rmuser user =
582 let
583 val doms = Acl.class {user = user, class = "domain"}
584 val doms = List.filter (fn dom =>
585 case Acl.whoHas {class = "domain", value = dom} of
586 [_] => true
587 | _ => false) (StringSet.listItems doms)
588 in
589 Acl.rmuser user;
590 Domain.rmdom doms
591 end
592
3b267643 593fun service () =
07cc384c 594 let
aa56e112
AC
595 val () = Acl.read Config.aclFile
596
3b267643
AC
597 val context = OpenSSL.context (Config.serverCert,
598 Config.serverKey,
599 Config.trustStore)
36e42cb8 600 val _ = Domain.set_context context
3b267643 601
60534712 602 val sock = OpenSSL.listen (context, Config.dispatcherPort)
3b267643
AC
603
604 fun loop () =
60534712 605 case OpenSSL.accept sock of
3b267643
AC
606 NONE => ()
607 | SOME bio =>
608 let
aa56e112
AC
609 val user = OpenSSL.peerCN bio
610 val () = print ("\nConnection from " ^ user ^ "\n")
611 val () = Domain.setUser user
612
08688401
AC
613 fun doIt f cleanup =
614 ((case f () of
615 (msgLocal, SOME msgRemote) =>
616 (print msgLocal;
617 print "\n";
618 Msg.send (bio, MsgError msgRemote))
619 | (msgLocal, NONE) =>
620 (print msgLocal;
621 print "\n";
622 Msg.send (bio, MsgOk)))
623 handle OpenSSL.OpenSSL _ =>
624 print "OpenSSL error\n"
625 | OS.SysErr (s, _) =>
626 (print "System error: ";
627 print s;
628 print "\n";
629 Msg.send (bio, MsgError ("System error: " ^ s))
630 handle OpenSSL.OpenSSL _ => ())
631 | Fail s =>
632 (print "Failure: ";
633 print s;
634 print "\n";
635 Msg.send (bio, MsgError ("Failure: " ^ s))
636 handle OpenSSL.OpenSSL _ => ())
637 | ErrorMsg.Error =>
638 (print "Compilation error\n";
639 Msg.send (bio, MsgError "Error during configuration evaluation")
640 handle OpenSSL.OpenSSL _ => ());
641 (cleanup ();
642 ignore (OpenSSL.readChar bio);
643 OpenSSL.close bio)
644 handle OpenSSL.OpenSSL _ => ();
645 loop ())
646
c53e82e4
AC
647 fun doConfig codes =
648 let
649 val _ = print "Configuration:\n"
650 val _ = app (fn s => (print s; print "\n")) codes
651 val _ = print "\n"
652
653 val outname = OS.FileSys.tmpName ()
654
655 fun doOne code =
656 let
657 val outf = TextIO.openOut outname
658 in
659 TextIO.output (outf, code);
660 TextIO.closeOut outf;
1824f573 661 eval' outname
c53e82e4
AC
662 end
663 in
08688401
AC
664 doIt (fn () => (Env.pre ();
665 app doOne codes;
666 Env.post ();
667 Msg.send (bio, MsgOk);
668 ("Configuration complete.", NONE)))
669 (fn () => OS.FileSys.remove outname)
c53e82e4
AC
670 end
671
2e96b9d4
AC
672 fun checkAddr s =
673 case String.fields (fn ch => ch = #"@") s of
674 [user'] =>
675 if user = user' then
676 SOME (SetSA.User s)
677 else
678 NONE
679 | [user', domain] =>
680 if Domain.validEmailUser user' andalso Domain.yourDomain domain then
681 SOME (SetSA.Email s)
682 else
683 NONE
684 | _ => NONE
685
36e42cb8
AC
686 fun cmdLoop () =
687 case Msg.recv bio of
688 NONE => (OpenSSL.close bio
689 handle OpenSSL.OpenSSL _ => ();
690 loop ())
691 | SOME m =>
692 case m of
c53e82e4
AC
693 MsgConfig code => doConfig [code]
694 | MsgMultiConfig codes => doConfig codes
5ee41dd0
AC
695
696 | MsgGrant acl =>
08688401
AC
697 doIt (fn () =>
698 if Acl.query {user = user, class = "priv", value = "all"} then
699 (Acl.grant acl;
700 Acl.write Config.aclFile;
701 ("Granted permission " ^ #value acl ^ " to " ^ #user acl ^ " in " ^ #class acl ^ ".",
702 NONE))
703 else
704 ("Unauthorized user asked to grant a permission!",
705 SOME "Not authorized to grant privileges"))
706 (fn () => ())
707
411a85f2 708 | MsgRevoke acl =>
08688401
AC
709 doIt (fn () =>
710 if Acl.query {user = user, class = "priv", value = "all"} then
711 (Acl.revoke acl;
712 Acl.write Config.aclFile;
713 ("Revoked permission " ^ #value acl ^ " from " ^ #user acl ^ " in " ^ #class acl ^ ".",
714 NONE))
715 else
716 ("Unauthorized user asked to revoke a permission!",
717 SOME "Not authorized to revoke privileges"))
718 (fn () => ())
5ee41dd0 719
08a04eb4 720 | MsgListPerms user =>
08688401
AC
721 doIt (fn () =>
722 (Msg.send (bio, MsgPerms (Acl.queryAll user));
723 ("Sent permission list for user " ^ user ^ ".",
724 NONE)))
725 (fn () => ())
08a04eb4 726
094877b1 727 | MsgWhoHas perm =>
08688401
AC
728 doIt (fn () =>
729 (Msg.send (bio, MsgWhoHasResponse (Acl.whoHas perm));
730 ("Sent whohas response for " ^ #class perm ^ " / " ^ #value perm ^ ".",
731 NONE)))
732 (fn () => ())
094877b1 733
e69e60cc 734 | MsgRmdom doms =>
08688401
AC
735 doIt (fn () =>
736 if Acl.query {user = user, class = "priv", value = "all"}
737 orelse List.all (fn dom => Acl.query {user = user, class = "domain", value = dom}) doms then
738 (Domain.rmdom doms;
739 app (fn dom =>
740 Acl.revokeFromAll {class = "domain", value = dom}) doms;
741 Acl.write Config.aclFile;
742 ("Removed domains" ^ foldl (fn (d, s) => s ^ " " ^ d) "" doms ^ ".",
743 NONE))
744 else
745 ("Unauthorized user asked to remove a domain!",
746 SOME "Not authorized to remove that domain"))
747 (fn () => ())
1824f573
AC
748
749 | MsgRegenerate =>
08688401
AC
750 doIt (fn () =>
751 if Acl.query {user = user, class = "priv", value = "regen"}
752 orelse Acl.query {user = user, class = "priv", value = "all"} then
753 (regenerate context;
754 ("Regenerated all configuration.",
755 NONE))
756 else
757 ("Unauthorized user asked to regenerate!",
758 SOME "Not authorized to regenerate"))
759 (fn () => ())
e69e60cc 760
05323cbc 761 | MsgRmuser user' =>
08688401
AC
762 doIt (fn () =>
763 if Acl.query {user = user, class = "priv", value = "all"} then
764 (rmuser user';
765 Acl.write Config.aclFile;
766 ("Removed user " ^ user' ^ ".",
767 NONE))
768 else
769 ("Unauthorized user asked to remove a user!",
770 SOME "Not authorized to remove users"))
771 (fn () => ())
d541c618 772
21d921a5 773 | MsgCreateDbUser {dbtype, passwd} =>
08688401
AC
774 doIt (fn () =>
775 case Dbms.lookup dbtype of
776 NONE => ("Database user creation request with unknown datatype type " ^ dbtype,
777 SOME ("Unknown database type " ^ dbtype))
778 | SOME handler =>
779 case #adduser handler {user = user, passwd = passwd} of
780 NONE => ("Added " ^ dbtype ^ " user " ^ user ^ ".",
781 NONE)
782 | SOME msg =>
783 ("Error adding a " ^ dbtype ^ " user " ^ user ^ ": " ^ msg,
784 SOME ("Error adding user: " ^ msg)))
785 (fn () => ())
c189cbe9 786
90dd48df 787 | MsgCreateDbTable {dbtype, dbname} =>
08688401
AC
788 doIt (fn () =>
789 if Dbms.validDbname dbname then
790 case Dbms.lookup dbtype of
791 NONE => ("Database creation request with unknown datatype type " ^ dbtype,
792 SOME ("Unknown database type " ^ dbtype))
793 | SOME handler =>
794 case #createdb handler {user = user, dbname = dbname} of
795 NONE => ("Created database " ^ user ^ "_" ^ dbname ^ ".",
796 NONE)
797 | SOME msg => ("Error creating database " ^ user ^ "_" ^ dbname ^ ": " ^ msg,
798 SOME ("Error creating database: " ^ msg))
799 else
800 ("Invalid database name " ^ user ^ "_" ^ dbname,
801 SOME ("Invalid database name " ^ dbname)))
802 (fn () => ())
803
1d3ef80e
AC
804 | MsgListMailboxes domain =>
805 doIt (fn () =>
806 if not (Domain.yourDomain domain) then
807 ("User wasn't authorized to list mailboxes for " ^ domain,
808 SOME "You're not authorized to configure that domain.")
809 else
810 case Vmail.list domain of
811 Vmail.Listing users => (Msg.send (bio, MsgMailboxes users);
812 ("Sent mailbox list for " ^ domain,
813 NONE))
814 | Vmail.Error msg => ("Error listing mailboxes for " ^ domain ^ ": " ^ msg,
815 SOME msg))
816 (fn () => ())
817
08688401
AC
818 | MsgNewMailbox {domain, user = emailUser, passwd, mailbox} =>
819 doIt (fn () =>
820 if not (Domain.yourDomain domain) then
821 ("User wasn't authorized to add a mailbox to " ^ domain,
822 SOME "You're not authorized to configure that domain.")
2e96b9d4 823 else if not (Domain.validEmailUser emailUser) then
08688401
AC
824 ("Invalid e-mail username " ^ emailUser,
825 SOME "Invalid e-mail username")
826 else if not (CharVector.all Char.isGraph passwd) then
827 ("Invalid password",
828 SOME "Invalid password; may only contain printable, non-space characters")
829 else if not (Domain.yourPath mailbox) then
830 ("User wasn't authorized to add a mailbox at " ^ mailbox,
831 SOME "You're not authorized to use that mailbox location.")
832 else
833 case Vmail.add {requester = user,
834 domain = domain, user = emailUser,
835 passwd = passwd, mailbox = mailbox} of
836 NONE => ("Added mailbox " ^ emailUser ^ "@" ^ domain ^ " at " ^ mailbox,
837 NONE)
9ffe2f0f 838 | SOME msg => ("Error adding mailbox " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
08688401
AC
839 SOME msg))
840 (fn () => ())
841
842 | MsgPasswdMailbox {domain, user = emailUser, passwd} =>
843 doIt (fn () =>
844 if not (Domain.yourDomain domain) then
845 ("User wasn't authorized to change password of a mailbox for " ^ domain,
846 SOME "You're not authorized to configure that domain.")
2e96b9d4 847 else if not (Domain.validEmailUser emailUser) then
08688401
AC
848 ("Invalid e-mail username " ^ emailUser,
849 SOME "Invalid e-mail username")
850 else if not (CharVector.all Char.isGraph passwd) then
851 ("Invalid password",
852 SOME "Invalid password; may only contain printable, non-space characters")
853 else
854 case Vmail.passwd {domain = domain, user = emailUser,
855 passwd = passwd} of
856 NONE => ("Changed password of mailbox " ^ emailUser ^ "@" ^ domain,
857 NONE)
9ffe2f0f 858 | SOME msg => ("Error changing mailbox password for " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
08688401
AC
859 SOME msg))
860 (fn () => ())
861
862 | MsgRmMailbox {domain, user = emailUser} =>
863 doIt (fn () =>
864 if not (Domain.yourDomain domain) then
865 ("User wasn't authorized to change password of a mailbox for " ^ domain,
866 SOME "You're not authorized to configure that domain.")
2e96b9d4 867 else if not (Domain.validEmailUser emailUser) then
08688401
AC
868 ("Invalid e-mail username " ^ emailUser,
869 SOME "Invalid e-mail username")
870 else
871 case Vmail.rm {domain = domain, user = emailUser} of
872 NONE => ("Deleted mailbox " ^ emailUser ^ "@" ^ domain,
873 NONE)
9ffe2f0f 874 | SOME msg => ("Error deleting mailbox " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
08688401
AC
875 SOME msg))
876 (fn () => ())
90dd48df 877
2e96b9d4
AC
878 | MsgSaQuery addr =>
879 doIt (fn () =>
880 case checkAddr addr of
881 NONE => ("User tried to query SA filtering for " ^ addr,
882 SOME "You aren't allowed to configure SA filtering for that recipient.")
883 | SOME addr' => (Msg.send (bio, MsgSaStatus (SetSA.query addr'));
884 ("Queried SA filtering status for " ^ addr,
885 NONE)))
886 (fn () => ())
887
888 | MsgSaSet (addr, b) =>
889 doIt (fn () =>
890 case checkAddr addr of
891 NONE => ("User tried to set SA filtering for " ^ addr,
892 SOME "You aren't allowed to configure SA filtering for that recipient.")
893 | SOME addr' => (SetSA.set (addr', b);
894 Msg.send (bio, MsgOk);
895 ("Set SA filtering status for " ^ addr ^ " to "
896 ^ (if b then "ON" else "OFF"),
897 NONE)))
898 (fn () => ())
899
36e42cb8 900 | _ =>
08688401
AC
901 doIt (fn () => ("Unexpected command",
902 SOME "Unexpected command"))
903 (fn () => ())
36e42cb8
AC
904 in
905 cmdLoop ()
906 end
97665758
AC
907 handle OpenSSL.OpenSSL s =>
908 (print ("OpenSSL error: " ^ s ^ "\n");
909 OpenSSL.close bio
910 handle OpenSSL.OpenSSL _ => ();
911 loop ())
912 | OS.SysErr (s, _) =>
913 (print ("System error: " ^ s ^ "\n");
914 OpenSSL.close bio
915 handle OpenSSL.OpenSSL _ => ();
916 loop ())
36e42cb8 917 in
361a1e7f 918 print "Listening for connections....\n";
36e42cb8
AC
919 loop ();
920 OpenSSL.shutdown sock
921 end
922
923fun slave () =
924 let
6e62228d 925 val host = Slave.hostname ()
36e42cb8
AC
926
927 val context = OpenSSL.context (Config.certDir ^ "/" ^ host ^ ".pem",
a088cea6 928 Config.keyDir ^ "/" ^ host ^ "/key.pem",
36e42cb8
AC
929 Config.trustStore)
930
931 val sock = OpenSSL.listen (context, Config.slavePort)
932
933 fun loop () =
934 case OpenSSL.accept sock of
935 NONE => ()
936 | SOME bio =>
937 let
938 val peer = OpenSSL.peerCN bio
939 val () = print ("\nConnection from " ^ peer ^ "\n")
3b267643 940 in
36e42cb8
AC
941 if peer <> Config.dispatcherName then
942 (print "Not authorized!\n";
943 OpenSSL.close bio;
944 loop ())
945 else let
946 fun loop' files =
947 case Msg.recv bio of
948 NONE => print "Dispatcher closed connection unexpectedly\n"
949 | SOME m =>
950 case m of
951 MsgFile file => loop' (file :: files)
952 | MsgDoFiles => (Slave.handleChanges files;
953 Msg.send (bio, MsgOk))
71420f8b
AC
954 | MsgRegenerate => (Domain.resetLocal ();
955 Msg.send (bio, MsgOk))
36e42cb8
AC
956 | _ => (print "Dispatcher sent unexpected command\n";
957 Msg.send (bio, MsgError "Unexpected command"))
958 in
959 loop' [];
960 ignore (OpenSSL.readChar bio);
961 OpenSSL.close bio;
962 loop ()
963 end
3196000d
AC
964 end handle OpenSSL.OpenSSL s =>
965 (print ("OpenSSL error: "^ s ^ "\n");
966 OpenSSL.close bio
967 handle OpenSSL.OpenSSL _ => ();
968 loop ())
7af7d4cb
AC
969 | OS.SysErr (s, _) =>
970 (print ("System error: "^ s ^ "\n");
971 OpenSSL.close bio
972 handle OpenSSL.OpenSSL _ => ();
973 loop ())
07cc384c 974 in
3b267643
AC
975 loop ();
976 OpenSSL.shutdown sock
07cc384c
AC
977 end
978
44a5ce2f 979fun listBasis () =
3196000d
AC
980 let
981 val dir = Posix.FileSys.opendir Config.libRoot
982
983 fun loop files =
984 case Posix.FileSys.readdir dir of
985 NONE => (Posix.FileSys.closedir dir;
986 files)
987 | SOME fname =>
988 if String.isSuffix ".dtl" fname then
989 loop (OS.Path.joinDirFile {dir = Config.libRoot,
990 file = fname}
991 :: files)
992 else
993 loop files
3196000d 994 in
44a5ce2f 995 loop []
3196000d
AC
996 end
997
44a5ce2f
AC
998fun autodocBasis outdir =
999 Autodoc.autodoc {outdir = outdir, infiles = listBasis ()}
1000
234b917a 1001end