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