Less noisy pinging and shutting down
[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
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"}
1286 orelse List.all (fn dom => Acl.query {user = user, class = "domain", value = dom}) doms then
1287 (Domain.rmdom doms;
1288 app (fn dom =>
1289 Acl.revokeFromAll {class = "domain", value = dom}) doms;
1290 Acl.write Config.aclFile;
1291 ("Removed domains" ^ foldl (fn (d, s) => s ^ " " ^ d) "" doms ^ ".",
1292 NONE))
1293 else
1294 ("Unauthorized user asked to remove a domain!",
1295 SOME "Not authorized to remove that domain"))
1296 (fn () => ())
1297
1298 | MsgRegenerate =>
1299 doIt (fn () =>
1300 if Acl.query {user = user, class = "priv", value = "regen"}
1301 orelse Acl.query {user = user, class = "priv", value = "all"} then
1302 (if regenerate context then
1303 ("Regenerated all configuration.",
1304 NONE)
1305 else
1306 ("Error regenerating configuration!",
1307 SOME "Error regenerating configuration! Consult /var/log/domtool.log."))
1308 else
1309 ("Unauthorized user asked to regenerate!",
1310 SOME "Not authorized to regenerate"))
1311 (fn () => ())
1312
1313 | MsgRegenerateTc =>
1314 doIt (fn () =>
1315 if Acl.query {user = user, class = "priv", value = "regen"}
1316 orelse Acl.query {user = user, class = "priv", value = "all"} then
1317 (if regenerateTc context then
1318 ("Checked all configuration.",
1319 NONE)
1320 else
1321 ("Found a compilation error!",
1322 SOME "Found a compilation error! Consult /var/log/domtool.log."))
1323 else
1324 ("Unauthorized user asked to regenerate -tc!",
1325 SOME "Not authorized to regenerate -tc"))
1326 (fn () => ())
1327
1328 | MsgRmuser user' =>
1329 doIt (fn () =>
1330 if Acl.query {user = user, class = "priv", value = "all"} then
1331 (rmuser user';
1332 Acl.write Config.aclFile;
1333 ("Removed user " ^ user' ^ ".",
1334 NONE))
1335 else
1336 ("Unauthorized user asked to remove a user!",
1337 SOME "Not authorized to remove users"))
1338 (fn () => ())
1339
1340 | MsgCreateDbUser {dbtype, passwd} =>
1341 doIt (fn () =>
1342 case Dbms.lookup dbtype of
1343 NONE => ("Database user creation request with unknown datatype type " ^ dbtype,
1344 SOME ("Unknown database type " ^ dbtype))
1345 | SOME handler =>
1346 case #adduser handler {user = user, passwd = passwd} of
1347 NONE => ("Added " ^ dbtype ^ " user " ^ user ^ ".",
1348 NONE)
1349 | SOME msg =>
1350 ("Error adding a " ^ dbtype ^ " user " ^ user ^ ": " ^ msg,
1351 SOME ("Error adding user: " ^ msg)))
1352 (fn () => ())
1353
1354 | MsgDbPasswd {dbtype, passwd} =>
1355 doIt (fn () =>
1356 case Dbms.lookup dbtype of
1357 NONE => ("Database passwd request with unknown datatype type " ^ dbtype,
1358 SOME ("Unknown database type " ^ dbtype))
1359 | SOME handler =>
1360 case #passwd handler {user = user, passwd = passwd} of
1361 NONE => ("Changed " ^ dbtype ^ " password of user " ^ user ^ ".",
1362 NONE)
1363 | SOME msg =>
1364 ("Error setting " ^ dbtype ^ " password of user " ^ user ^ ": " ^ msg,
1365 SOME ("Error adding user: " ^ msg)))
1366 (fn () => ())
1367
7adeee33 1368 | MsgCreateDb {dbtype, dbname} =>
2ee50226
AC
1369 doIt (fn () =>
1370 if Dbms.validDbname dbname then
1371 case Dbms.lookup dbtype of
1372 NONE => ("Database creation request with unknown datatype type " ^ dbtype,
1373 SOME ("Unknown database type " ^ dbtype))
1374 | SOME handler =>
1375 case #createdb handler {user = user, dbname = dbname} of
1376 NONE => ("Created database " ^ user ^ "_" ^ dbname ^ ".",
1377 NONE)
1378 | SOME msg => ("Error creating database " ^ user ^ "_" ^ dbname ^ ": " ^ msg,
1379 SOME ("Error creating database: " ^ msg))
1380 else
1381 ("Invalid database name " ^ user ^ "_" ^ dbname,
1382 SOME ("Invalid database name " ^ dbname)))
1383 (fn () => ())
1384
1385 | MsgDropDb {dbtype, dbname} =>
1386 doIt (fn () =>
1387 if Dbms.validDbname dbname then
1388 case Dbms.lookup dbtype of
1389 NONE => ("Database drop request with unknown datatype type " ^ dbtype,
1390 SOME ("Unknown database type " ^ dbtype))
1391 | SOME handler =>
1392 case #dropdb handler {user = user, dbname = dbname} of
1393 NONE => ("Drop database " ^ user ^ "_" ^ dbname ^ ".",
1394 NONE)
1395 | SOME msg => ("Error dropping database " ^ user ^ "_" ^ dbname ^ ": " ^ msg,
1396 SOME ("Error dropping database: " ^ msg))
1397 else
1398 ("Invalid database name " ^ user ^ "_" ^ dbname,
99cc4144
AC
1399 SOME ("Invalid database name " ^ dbname)))
1400 (fn () => ())
1401
1402 | MsgGrantDb {dbtype, dbname} =>
1403 doIt (fn () =>
1404 if Dbms.validDbname dbname then
1405 case Dbms.lookup dbtype of
1406 NONE => ("Database drop request with unknown datatype type " ^ dbtype,
1407 SOME ("Unknown database type " ^ dbtype))
1408 | SOME handler =>
1409 case #grant handler {user = user, dbname = dbname} of
1410 NONE => ("Grant permissions to database " ^ user ^ "_" ^ dbname ^ ".",
1411 NONE)
1412 | SOME msg => ("Error granting permissions to database " ^ user ^ "_" ^ dbname ^ ": " ^ msg,
1413 SOME ("Error granting permissions to database: " ^ msg))
1414 else
1415 ("Invalid database name " ^ user ^ "_" ^ dbname,
2ee50226
AC
1416 SOME ("Invalid database name " ^ dbname)))
1417 (fn () => ())
1418
1419 | MsgListMailboxes domain =>
1420 doIt (fn () =>
1421 if not (Domain.yourDomain domain) then
1422 ("User wasn't authorized to list mailboxes for " ^ domain,
1423 SOME "You're not authorized to configure that domain.")
1424 else
1425 case Vmail.list domain of
1426 Vmail.Listing users => (Msg.send (bio, MsgMailboxes users);
1427 ("Sent mailbox list for " ^ domain,
1428 NONE))
1429 | Vmail.Error msg => ("Error listing mailboxes for " ^ domain ^ ": " ^ msg,
1430 SOME msg))
1431 (fn () => ())
1432
1433 | MsgNewMailbox {domain, user = emailUser, passwd, mailbox} =>
1434 doIt (fn () =>
1435 if not (Domain.yourDomain domain) then
1436 ("User wasn't authorized to add a mailbox to " ^ domain,
1437 SOME "You're not authorized to configure that domain.")
1438 else if not (Domain.validEmailUser emailUser) then
1439 ("Invalid e-mail username " ^ emailUser,
1440 SOME "Invalid e-mail username")
1441 else if not (CharVector.all Char.isGraph passwd) then
1442 ("Invalid password",
1443 SOME "Invalid password; may only contain printable, non-space characters")
1444 else if not (Domain.yourPath mailbox) then
1445 ("User wasn't authorized to add a mailbox at " ^ mailbox,
3bf720f7
AC
1446 SOME ("You're not authorized to use that mailbox location. ("
1447 ^ mailbox ^ ")"))
2ee50226
AC
1448 else
1449 case Vmail.add {requester = user,
1450 domain = domain, user = emailUser,
1451 passwd = passwd, mailbox = mailbox} of
1452 NONE => ("Added mailbox " ^ emailUser ^ "@" ^ domain ^ " at " ^ mailbox,
1453 NONE)
1454 | SOME msg => ("Error adding mailbox " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
1455 SOME msg))
1456 (fn () => ())
1457
1458 | MsgPasswdMailbox {domain, user = emailUser, passwd} =>
1459 doIt (fn () =>
1460 if not (Domain.yourDomain domain) then
1461 ("User wasn't authorized to change password of a mailbox for " ^ domain,
1462 SOME "You're not authorized to configure that domain.")
1463 else if not (Domain.validEmailUser emailUser) then
1464 ("Invalid e-mail username " ^ emailUser,
1465 SOME "Invalid e-mail username")
1466 else if not (CharVector.all Char.isGraph passwd) then
1467 ("Invalid password",
1468 SOME "Invalid password; may only contain printable, non-space characters")
1469 else
1470 case Vmail.passwd {domain = domain, user = emailUser,
1471 passwd = passwd} of
1472 NONE => ("Changed password of mailbox " ^ emailUser ^ "@" ^ domain,
1473 NONE)
1474 | SOME msg => ("Error changing mailbox password for " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
1475 SOME msg))
1476 (fn () => ())
1477
1478 | MsgRmMailbox {domain, user = emailUser} =>
1479 doIt (fn () =>
1480 if not (Domain.yourDomain domain) then
1481 ("User wasn't authorized to change password of a mailbox for " ^ domain,
1482 SOME "You're not authorized to configure that domain.")
1483 else if not (Domain.validEmailUser emailUser) then
1484 ("Invalid e-mail username " ^ emailUser,
1485 SOME "Invalid e-mail username")
1486 else
1487 case Vmail.rm {domain = domain, user = emailUser} of
1488 NONE => ("Deleted mailbox " ^ emailUser ^ "@" ^ domain,
1489 NONE)
1490 | SOME msg => ("Error deleting mailbox " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
1491 SOME msg))
1492 (fn () => ())
1493
1494 | MsgSaQuery addr =>
1495 doIt (fn () =>
1496 case checkAddr addr of
1497 NONE => ("User tried to query SA filtering for " ^ addr,
1498 SOME "You aren't allowed to configure SA filtering for that recipient.")
1499 | SOME addr' => (Msg.send (bio, MsgSaStatus (SetSA.query addr'));
1500 ("Queried SA filtering status for " ^ addr,
1501 NONE)))
1502 (fn () => ())
1503
1504 | MsgSaSet (addr, b) =>
1505 doIt (fn () =>
1506 case checkAddr addr of
1507 NONE => ("User tried to set SA filtering for " ^ addr,
1508 SOME "You aren't allowed to configure SA filtering for that recipient.")
1509 | SOME addr' => (SetSA.set (addr', b);
1510 Msg.send (bio, MsgOk);
1511 ("Set SA filtering status for " ^ addr ^ " to "
1512 ^ (if b then "ON" else "OFF"),
1513 NONE)))
1514 (fn () => ())
1515
1516 | MsgSmtpLogReq domain =>
1517 doIt (fn () =>
1518 if not (Domain.yourDomain domain) then
1519 ("Unauthorized user tried to request SMTP logs for " ^ domain,
1520 SOME "You aren't authorized to configure that domain.")
1521 else
1522 (SmtpLog.search (fn line => Msg.send (bio, MsgSmtpLogRes line))
1523 domain;
1524 ("Requested SMTP logs for " ^ domain,
1525 NONE)))
1526 (fn () => ())
1527
1528 | MsgQuery q =>
1529 doIt (fn () => (Msg.send (bio, answerQuery q);
1530 (describeQuery q,
1531 NONE)))
1532 (fn () => ())
1533
00a077ab
AC
1534 | MsgMysqlFixperms =>
1535 doIt (fn () => if OS.Process.isSuccess
1536 (OS.Process.system "/usr/bin/sudo -H /afs/hcoop.net/common/etc/scripts/mysql-grant-table-drop") then
1537 ("Requested mysql-fixperms",
1538 NONE)
1539 else
1540 ("Requested mysql-fixperms, but execution failed!",
1541 SOME "Script execution failed."))
1542 (fn () => ())
1543
1ffc47a6
AC
1544 | MsgDescribe dom =>
1545 doIt (fn () => if not (Domain.validDomain dom) then
1546 ("Requested description of invalid domain " ^ dom,
1547 SOME "Invalid domain name")
1548 else if not (Domain.yourDomain dom
1549 orelse Acl.query {user = user, class = "priv", value = "all"}) then
1550 ("Requested description of " ^ dom ^ ", but not allowed access",
1551 SOME "Access denied")
1552 else
1553 (Msg.send (bio, MsgDescription (Domain.describe dom));
1554 ("Sent description of domain " ^ dom,
1555 NONE)))
1556 (fn () => ())
1557
2ee50226
AC
1558 | _ =>
1559 doIt (fn () => ("Unexpected command",
1560 SOME "Unexpected command"))
1561 (fn () => ())
1562 in
1563 cmdLoop ()
1564 end
1565 handle e as (OpenSSL.OpenSSL s) =>
1566 (print ("OpenSSL error: " ^ s ^ "\n");
1567 app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);
1568 OpenSSL.close bio
08688401
AC
1569 handle OpenSSL.OpenSSL _ => ();
1570 loop ())
2ee50226
AC
1571 | OS.SysErr (s, _) =>
1572 (print ("System error: " ^ s ^ "\n");
1573 OpenSSL.close bio
1574 handle OpenSSL.OpenSSL _ => ();
1575 loop ())
1576 | IO.Io {name, function, cause} =>
1577 (print ("IO error: " ^ function ^ " for " ^ name ^ "\n");
1578 app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory cause);
1579 OpenSSL.close bio
1580 handle OpenSSL.OpenSSL _ => ();
1581 loop ())
314ce7bd
AC
1582 | OS.Path.InvalidArc =>
1583 (print "Invalid arc\n";
1584 OpenSSL.close bio
1585 handle OpenSSL.OpenSSL _ => ();
1586 loop ())
2ee50226
AC
1587 | e =>
1588 (print "Unknown exception in main loop!\n";
1589 app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);
1590 OpenSSL.close bio
1591 handle OpenSSL.OpenSSL _ => ();
1592 loop ()))
1593 handle e as (OpenSSL.OpenSSL s) =>
1594 (print ("OpenSSL error: " ^ s ^ "\n");
1595 app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);
1596 loop ())
1597 | OS.SysErr (s, _) =>
1598 (print ("System error: " ^ s ^ "\n");
1599 loop ())
1600 | IO.Io {name, function, cause} =>
1601 (print ("IO error: " ^ function ^ " for " ^ name ^ "\n");
1602 app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory cause);
1603 loop ())
1604 | e =>
1605 (print "Unknown exception in main loop!\n";
1606 app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);
1607 loop ())
36e42cb8 1608 in
c9731b9b 1609 print ("Domtool dispatcher starting up at " ^ now () ^ "\n");
361a1e7f 1610 print "Listening for connections....\n";
36e42cb8
AC
1611 loop ();
1612 OpenSSL.shutdown sock
1613 end
1614
1615fun slave () =
1616 let
6e62228d 1617 val host = Slave.hostname ()
36e42cb8 1618
d22c1f00
AC
1619 val context = context (Config.certDir ^ "/" ^ host ^ ".pem",
1620 Config.keyDir ^ "/" ^ host ^ "/key.pem",
1621 Config.trustStore)
36e42cb8
AC
1622
1623 val sock = OpenSSL.listen (context, Config.slavePort)
1624
c9731b9b
AC
1625 val _ = print ("Slave server starting at " ^ now () ^ "\n")
1626
36e42cb8
AC
1627 fun loop () =
1628 case OpenSSL.accept sock of
1629 NONE => ()
1630 | SOME bio =>
1631 let
1632 val peer = OpenSSL.peerCN bio
c9731b9b 1633 val () = print ("\nConnection from " ^ peer ^ " at " ^ now () ^ "\n")
3b267643 1634 in
c9731b9b 1635 if peer = Config.dispatcherName then let
36e42cb8
AC
1636 fun loop' files =
1637 case Msg.recv bio of
1638 NONE => print "Dispatcher closed connection unexpectedly\n"
1639 | SOME m =>
1640 case m of
1641 MsgFile file => loop' (file :: files)
1642 | MsgDoFiles => (Slave.handleChanges files;
1643 Msg.send (bio, MsgOk))
71420f8b
AC
1644 | MsgRegenerate => (Domain.resetLocal ();
1645 Msg.send (bio, MsgOk))
36e42cb8
AC
1646 | _ => (print "Dispatcher sent unexpected command\n";
1647 Msg.send (bio, MsgError "Unexpected command"))
1648 in
1649 loop' [];
1650 ignore (OpenSSL.readChar bio);
1651 OpenSSL.close bio;
1652 loop ()
1653 end
c9731b9b
AC
1654 else if peer = "domtool" then
1655 case Msg.recv bio of
1656 SOME MsgShutdown => (OpenSSL.close bio;
1657 print ("Shutting down at " ^ now () ^ "\n\n"))
1658 | _ => (OpenSSL.close bio;
1659 loop ())
1660 else
a95a0107
AC
1661 case Msg.recv bio of
1662 SOME (MsgQuery q) => (print (describeQuery q ^ "\n");
1663 Msg.send (bio, answerQuery q);
1664 ignore (OpenSSL.readChar bio);
1665 OpenSSL.close bio;
1666 loop ())
1667 | _ => (OpenSSL.close bio;
1668 loop ())
3196000d 1669 end handle OpenSSL.OpenSSL s =>
7cf60536 1670 (print ("OpenSSL error: " ^ s ^ "\n");
3196000d
AC
1671 OpenSSL.close bio
1672 handle OpenSSL.OpenSSL _ => ();
1673 loop ())
95a9abd1
AC
1674 | e as OS.SysErr (s, _) =>
1675 (app (fn s => print (s ^ "\n")) (SMLofNJ.exnHistory e);
1676 print ("System error: "^ s ^ "\n");
7af7d4cb
AC
1677 OpenSSL.close bio
1678 handle OpenSSL.OpenSSL _ => ();
1679 loop ())
7cf60536
AC
1680 | IO.Io {function, name, ...} =>
1681 (print ("IO error: " ^ function ^ ": " ^ name ^ "\n");
1682 OpenSSL.close bio
1683 handle OpenSSL.OpenSSL _ => ();
1684 loop ())
1685 | e =>
1686 (app (fn s => print (s ^ "\n")) (SMLofNJ.exnHistory e);
1687 print "Uncaught exception!\n";
1688 OpenSSL.close bio
1689 handle OpenSSL.OpenSSL _ => ();
1690 loop ())
07cc384c 1691 in
3b267643
AC
1692 loop ();
1693 OpenSSL.shutdown sock
07cc384c
AC
1694 end
1695
44a5ce2f 1696fun listBasis () =
3196000d
AC
1697 let
1698 val dir = Posix.FileSys.opendir Config.libRoot
1699
1700 fun loop files =
1701 case Posix.FileSys.readdir dir of
1702 NONE => (Posix.FileSys.closedir dir;
1703 files)
1704 | SOME fname =>
1705 if String.isSuffix ".dtl" fname then
1706 loop (OS.Path.joinDirFile {dir = Config.libRoot,
1707 file = fname}
1708 :: files)
1709 else
1710 loop files
3196000d 1711 in
44a5ce2f 1712 loop []
3196000d
AC
1713 end
1714
44a5ce2f
AC
1715fun autodocBasis outdir =
1716 Autodoc.autodoc {outdir = outdir, infiles = listBasis ()}
1717
234b917a 1718end