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