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