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