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