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