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