Reduce toplevel environment decls and allow them in user config
[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);
1555 Msg.send (bio, MsgOk);
1556 ("Set SA filtering status for " ^ addr ^ " to "
1557 ^ (if b then "ON" else "OFF"),
1558 NONE)))
1559 (fn () => ())
1560
1561 | MsgSmtpLogReq domain =>
1562 doIt (fn () =>
1563 if not (Domain.yourDomain domain) then
1564 ("Unauthorized user tried to request SMTP logs for " ^ domain,
1565 SOME "You aren't authorized to configure that domain.")
1566 else
1567 (SmtpLog.search (fn line => Msg.send (bio, MsgSmtpLogRes line))
1568 domain;
1569 ("Requested SMTP logs for " ^ domain,
1570 NONE)))
1571 (fn () => ())
1572
1573 | MsgQuery q =>
1574 doIt (fn () => (Msg.send (bio, answerQuery q);
1575 (describeQuery q,
1576 NONE)))
1577 (fn () => ())
1ffc47a6
AC
1578 | MsgDescribe dom =>
1579 doIt (fn () => if not (Domain.validDomain dom) then
1580 ("Requested description of invalid domain " ^ dom,
1581 SOME "Invalid domain name")
1582 else if not (Domain.yourDomain dom
1583 orelse Acl.query {user = user, class = "priv", value = "all"}) then
1584 ("Requested description of " ^ dom ^ ", but not allowed access",
1585 SOME "Access denied")
1586 else
1587 (Msg.send (bio, MsgDescription (Domain.describe dom));
1588 ("Sent description of domain " ^ dom,
1589 NONE)))
1590 (fn () => ())
1591
563e7792 1592 | MsgReUsers =>
072a71cf
AC
1593 doIt (fn () => if Acl.query {user = user, class = "priv", value = "regen"}
1594 orelse Acl.query {user = user, class = "priv", value = "all"} then
1595 (usersChanged ();
1596 ("Users change callbacks run", NONE))
1597 else
1598 ("Unauthorized user asked to reusers!",
1599 SOME "You aren't authorized to regenerate files."))
563e7792
AC
1600 (fn () => ())
1601
2ee50226
AC
1602 | _ =>
1603 doIt (fn () => ("Unexpected command",
1604 SOME "Unexpected command"))
1605 (fn () => ())
1606 in
1607 cmdLoop ()
1608 end
1609 handle e as (OpenSSL.OpenSSL s) =>
1610 (print ("OpenSSL error: " ^ s ^ "\n");
1611 app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);
1612 OpenSSL.close bio
08688401
AC
1613 handle OpenSSL.OpenSSL _ => ();
1614 loop ())
2ee50226
AC
1615 | OS.SysErr (s, _) =>
1616 (print ("System error: " ^ s ^ "\n");
1617 OpenSSL.close bio
1618 handle OpenSSL.OpenSSL _ => ();
1619 loop ())
1620 | IO.Io {name, function, cause} =>
1621 (print ("IO error: " ^ function ^ " for " ^ name ^ "\n");
1622 app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory cause);
1623 OpenSSL.close bio
1624 handle OpenSSL.OpenSSL _ => ();
1625 loop ())
314ce7bd
AC
1626 | OS.Path.InvalidArc =>
1627 (print "Invalid arc\n";
1628 OpenSSL.close bio
1629 handle OpenSSL.OpenSSL _ => ();
1630 loop ())
2ee50226
AC
1631 | e =>
1632 (print "Unknown exception in main loop!\n";
1633 app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);
1634 OpenSSL.close bio
1635 handle OpenSSL.OpenSSL _ => ();
1636 loop ()))
1637 handle e as (OpenSSL.OpenSSL s) =>
1638 (print ("OpenSSL error: " ^ s ^ "\n");
1639 app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);
1640 loop ())
1641 | OS.SysErr (s, _) =>
1642 (print ("System error: " ^ s ^ "\n");
1643 loop ())
1644 | IO.Io {name, function, cause} =>
1645 (print ("IO error: " ^ function ^ " for " ^ name ^ "\n");
1646 app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory cause);
1647 loop ())
1648 | e =>
1649 (print "Unknown exception in main loop!\n";
1650 app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);
1651 loop ())
36e42cb8 1652 in
c9731b9b 1653 print ("Domtool dispatcher starting up at " ^ now () ^ "\n");
361a1e7f 1654 print "Listening for connections....\n";
36e42cb8
AC
1655 loop ();
1656 OpenSSL.shutdown sock
1657 end
1658
1659fun slave () =
1660 let
6e62228d 1661 val host = Slave.hostname ()
36e42cb8 1662
d22c1f00
AC
1663 val context = context (Config.certDir ^ "/" ^ host ^ ".pem",
1664 Config.keyDir ^ "/" ^ host ^ "/key.pem",
1665 Config.trustStore)
36e42cb8
AC
1666
1667 val sock = OpenSSL.listen (context, Config.slavePort)
1668
c9731b9b
AC
1669 val _ = print ("Slave server starting at " ^ now () ^ "\n")
1670
36e42cb8 1671 fun loop () =
4f3ef3c5 1672 (case OpenSSL.accept sock of
4f5a3f95
AC
1673 NONE => ()
1674 | SOME bio =>
1675 let
1676 val peer = OpenSSL.peerCN bio
1677 val () = print ("\nConnection from " ^ peer ^ " at " ^ now () ^ "\n")
1678 in
1679 if peer = Config.dispatcherName then let
1680 fun loop' files =
1681 case Msg.recv bio of
1682 NONE => print "Dispatcher closed connection unexpectedly\n"
1683 | SOME m =>
1684 case m of
1685 MsgFile file => loop' (file :: files)
1686 | MsgDoFiles => (Slave.handleChanges files;
1687 Msg.send (bio, MsgOk))
1688 | MsgRegenerate => (Domain.resetLocal ();
1689 Msg.send (bio, MsgOk))
9b8c6dc8
AC
1690 | MsgVmailChanged => (if Vmail.doChanged () then
1691 Msg.send (bio, MsgOk)
1692 else
1693 Msg.send (bio, MsgError "userdb update failed"))
4f5a3f95
AC
1694 | _ => (print "Dispatcher sent unexpected command\n";
1695 Msg.send (bio, MsgError "Unexpected command"))
1696 in
1697 loop' [];
1698 ignore (OpenSSL.readChar bio);
1699 OpenSSL.close bio;
1700 loop ()
1701 end
1702 else if peer = "domtool" then
1703 case Msg.recv bio of
1704 SOME MsgShutdown => (OpenSSL.close bio;
1705 print ("Shutting down at " ^ now () ^ "\n\n"))
1706 | _ => (OpenSSL.close bio;
1707 loop ())
1708 else
c362e4cc
CE
1709 let
1710 val doIt = doIt' loop bio
1711 val user = peer
1712 in
1713 case Msg.recv bio of
1714 NONE => (OpenSSL.close bio
1715 handle OpenSSL.OpenSSL _ => ();
1716 loop ())
1717 | SOME m =>
1718 case m of
1719 (MsgQuery q) => (print (describeQuery q ^ "\n");
1720 Msg.send (bio, answerQuery q);
1721 ignore (OpenSSL.readChar bio);
1722 OpenSSL.close bio;
1723 loop ())
1724 | MsgCreateDbUser {dbtype, passwd} =>
1725 doIt (fn () =>
1726 case Dbms.lookup dbtype of
1727 NONE => ("Database user creation request with unknown datatype type " ^ dbtype,
1728 SOME ("Unknown database type " ^ dbtype))
1729 | SOME handler =>
1730 case #adduser handler {user = user, passwd = passwd} of
1731 NONE => ("Added " ^ dbtype ^ " user " ^ user ^ ".",
1732 NONE)
1733 | SOME msg =>
1734 ("Error adding a " ^ dbtype ^ " user " ^ user ^ ": " ^ msg,
1735 SOME ("Error adding user: " ^ msg)))
1736 (fn () => ())
1737
1738 | MsgDbPasswd {dbtype, passwd} =>
1739 doIt (fn () =>
1740 case Dbms.lookup dbtype of
1741 NONE => ("Database passwd request with unknown datatype type " ^ dbtype,
1742 SOME ("Unknown database type " ^ dbtype))
1743 | SOME handler =>
1744 case #passwd handler {user = user, passwd = passwd} of
1745 NONE => ("Changed " ^ dbtype ^ " password of user " ^ user ^ ".",
1746 NONE)
1747 | SOME msg =>
1748 ("Error setting " ^ dbtype ^ " password of user " ^ user ^ ": " ^ msg,
1749 SOME ("Error adding user: " ^ msg)))
1750 (fn () => ())
1751
1752 | MsgCreateDb {dbtype, dbname, encoding} =>
1753 doIt (fn () =>
1754 if Dbms.validDbname dbname then
1755 case Dbms.lookup dbtype of
1756 NONE => ("Database creation request with unknown datatype type " ^ dbtype,
1757 SOME ("Unknown database type " ^ dbtype))
1758 | SOME handler =>
1759 if not (Dbms.validEncoding encoding) then
1760 ("Invalid encoding " ^ valOf encoding ^ " requested for database creation.",
1761 SOME "Invalid encoding")
1762 else
1763 case #createdb handler {user = user, dbname = dbname, encoding = encoding} of
1764 NONE => ("Created database " ^ user ^ "_" ^ dbname ^ ".",
1765 NONE)
1766 | SOME msg => ("Error creating database " ^ user ^ "_" ^ dbname ^ ": " ^ msg,
1767 SOME ("Error creating database: " ^ msg))
1768 else
1769 ("Invalid database name " ^ user ^ "_" ^ dbname,
1770 SOME ("Invalid database name " ^ dbname)))
1771 (fn () => ())
1772
1773 | MsgDropDb {dbtype, dbname} =>
1774 doIt (fn () =>
1775 if Dbms.validDbname dbname then
1776 case Dbms.lookup dbtype of
1777 NONE => ("Database drop request with unknown datatype type " ^ dbtype,
1778 SOME ("Unknown database type " ^ dbtype))
1779 | SOME handler =>
1780 case #dropdb handler {user = user, dbname = dbname} of
1781 NONE => ("Drop database " ^ user ^ "_" ^ dbname ^ ".",
1782 NONE)
1783 | SOME msg => ("Error dropping database " ^ user ^ "_" ^ dbname ^ ": " ^ msg,
1784 SOME ("Error dropping database: " ^ msg))
1785 else
1786 ("Invalid database name " ^ user ^ "_" ^ dbname,
1787 SOME ("Invalid database name " ^ dbname)))
1788 (fn () => ())
1789
1790 | MsgGrantDb {dbtype, dbname} =>
1791 doIt (fn () =>
1792 if Dbms.validDbname dbname then
1793 case Dbms.lookup dbtype of
1794 NONE => ("Database drop request with unknown datatype type " ^ dbtype,
1795 SOME ("Unknown database type " ^ dbtype))
1796 | SOME handler =>
1797 case #grant handler {user = user, dbname = dbname} of
1798 NONE => ("Grant permissions to database " ^ user ^ "_" ^ dbname ^ ".",
1799 NONE)
1800 | SOME msg => ("Error granting permissions to database " ^ user ^ "_" ^ dbname ^ ": " ^ msg,
1801 SOME ("Error granting permissions to database: " ^ msg))
1802 else
1803 ("Invalid database name " ^ user ^ "_" ^ dbname,
1804 SOME ("Invalid database name " ^ dbname)))
1805 (fn () => ())
caba7e27
CE
1806 | MsgMysqlFixperms =>
1807 (print "Starting mysql-fixperms\n";
1808 doIt (fn () => if OS.Process.isSuccess
1809 (OS.Process.system "/usr/bin/sudo -H /afs/hcoop.net/common/etc/scripts/mysql-grant-table-drop") then
1810 ("Requested mysql-fixperms",
1811 NONE)
1812 else
1813 ("Requested mysql-fixperms, but execution failed!",
1814 SOME "Script execution failed."))
1815 (fn () => ()))
73b95423 1816 | MsgFirewallRegen =>
4f3ef3c5
CE
1817 doIt (fn () => (Acl.read Config.aclFile;
1818 if Acl.query {user = user, class = "priv", value = "all"} then
1819 if List.exists (fn x => x = host) Config.Firewall.firewallNodes then
1820 if (Firewall.generateFirewallConfig (Firewall.parseRules ()) andalso Firewall.publishConfig ())
1821 then
1822 ("Firewall rules regenerated.", NONE)
1823 else
1b96e27d
CE
1824 ("Rules regeneration failed!", SOME "Script execution failed.")
1825 else ("Node not controlled by domtool firewall.", SOME (host))
4f3ef3c5
CE
1826 else
1827 ("Not authorized to regenerate firewall.", SOME ("Unauthorized user " ^ user ^ " attempted to regenerated firewall"))))
73b95423 1828 (fn () => ())
caba7e27 1829
c362e4cc
CE
1830 | _ => (OpenSSL.close bio;
1831 loop ())
1832 end
4f5a3f95
AC
1833 end handle OpenSSL.OpenSSL s =>
1834 (print ("OpenSSL error: " ^ s ^ "\n");
1835 OpenSSL.close bio
1836 handle OpenSSL.OpenSSL _ => ();
1837 loop ())
1838 | e as OS.SysErr (s, _) =>
1839 (app (fn s => print (s ^ "\n")) (SMLofNJ.exnHistory e);
1840 print ("System error: "^ s ^ "\n");
1841 OpenSSL.close bio
1842 handle OpenSSL.OpenSSL _ => ();
1843 loop ())
1844 | IO.Io {function, name, ...} =>
1845 (print ("IO error: " ^ function ^ ": " ^ name ^ "\n");
1846 OpenSSL.close bio
1847 handle OpenSSL.OpenSSL _ => ();
1848 loop ())
1849 | e =>
1850 (app (fn s => print (s ^ "\n")) (SMLofNJ.exnHistory e);
1851 print "Uncaught exception!\n";
1852 OpenSSL.close bio
1853 handle OpenSSL.OpenSSL _ => ();
1854 loop ()))
1855 handle OpenSSL.OpenSSL s =>
1856 (print ("OpenSSL error: " ^ s ^ "\n");
1857 loop ())
1858 | e =>
1859 (app (fn s => print (s ^ "\n")) (SMLofNJ.exnHistory e);
1860 print "Uncaught exception!\n";
1861 loop ())
07cc384c 1862 in
3b267643
AC
1863 loop ();
1864 OpenSSL.shutdown sock
07cc384c
AC
1865 end
1866
44a5ce2f 1867fun listBasis () =
3196000d
AC
1868 let
1869 val dir = Posix.FileSys.opendir Config.libRoot
1870
1871 fun loop files =
1872 case Posix.FileSys.readdir dir of
1873 NONE => (Posix.FileSys.closedir dir;
1874 files)
1875 | SOME fname =>
1876 if String.isSuffix ".dtl" fname then
1877 loop (OS.Path.joinDirFile {dir = Config.libRoot,
1878 file = fname}
1879 :: files)
1880 else
1881 loop files
3196000d 1882 in
44a5ce2f 1883 loop []
3196000d
AC
1884 end
1885
44a5ce2f
AC
1886fun autodocBasis outdir =
1887 Autodoc.autodoc {outdir = outdir, infiles = listBasis ()}
1888
234b917a 1889end