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