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