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