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