src/main.sml

   1 (* HCoop Domtool (http://hcoop.sourceforge.net/)
   2  * Copyright (c) 2006-2009, Adam Chlipala
   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.
  17  *)
  18
  19 (* Main interface *)
  20
  21 structure Main :> MAIN = struct
  22
  23 open Ast MsgTypes Print
  24
  25 structure SM = StringMap
  26
  27 fun init () = Acl.read Config.aclFile
  28
  29 fun isLib fname = OS.Path.file fname = "lib.dtl"
  30
  31 fun 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
  41 fun check' G fname =
  42     let
  43         val prog = Parse.parse fname
  44         val prog = wrapFile (fname, prog)
  45     in
  46         if !ErrorMsg.anyErrors then
  47             G
  48         else
  49             (if isLib fname then
  50                  ()
  51              else
  52                  Option.app (Unused.check G) (#3 prog);
  53              Tycheck.checkFile G (Defaults.tInit prog) prog)
  54     end
  55
  56 fun basis () =
  57     let
  58         val dir = Posix.FileSys.opendir Config.libRoot
  59
  60         fun loop files =
  61             case Posix.FileSys.readdir dir of
  62                 NONE => (Posix.FileSys.closedir dir;
  63                          files)
  64               | SOME fname =>
  65                 if String.isSuffix ".dtl" fname then
  66                     loop (OS.Path.joinDirFile {dir = Config.libRoot,
  67                                                file = fname}
  68                           :: files)
  69                 else
  70                     loop files
  71
  72         val files = loop []
  73         val (_, files) = Order.order NONE files
  74     in
  75         if !ErrorMsg.anyErrors then
  76             Env.empty
  77         else
  78             (Tycheck.allowExterns ();
  79              foldl (fn (fname, G) => check' G fname) Env.empty files
  80              before Tycheck.disallowExterns ())
  81     end
  82
  83 (* val b = basis () *)
  84
  85 fun check G fname =
  86     let
  87         val _ = ErrorMsg.reset ()
  88         val _ = Env.preTycheck ()
  89     in
  90         if !ErrorMsg.anyErrors then
  91             raise ErrorMsg.Error
  92         else
  93             let
  94                 val _ = Tycheck.disallowExterns ()
  95                 val _ = ErrorMsg.reset ()
  96                 val prog = Parse.parse fname
  97                 val prog = wrapFile (fname, prog)
  98             in
  99                 if !ErrorMsg.anyErrors then
 100                     raise ErrorMsg.Error
 101                 else
 102                     let
 103                         val G' = Tycheck.checkFile G (Defaults.tInit prog) prog
 104                     in
 105                         if !ErrorMsg.anyErrors then
 106                             raise ErrorMsg.Error
 107                         else
 108                             (if isLib fname then
 109                                  ()
 110                              else
 111                                  Option.app (Unused.check G) (#3 prog);
 112                              (G', #3 prog))
 113                     end
 114             end
 115     end
 116
 117 fun notTmp s =
 118     String.sub (s, 0) <> #"."
 119     andalso CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"." orelse ch = #"_" orelse ch = #"-") s
 120
 121 fun 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
 138 fun checkDir' dname =
 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
 160             raise ErrorMsg.Error
 161         else
 162             (foldl (fn (fname, G) => check' G fname) b files;
 163              if !ErrorMsg.anyErrors then
 164                  raise ErrorMsg.Error
 165              else
 166                  ())
 167     end
 168
 169 fun checkDir dname =
 170     (setupUser ();
 171      checkDir' dname)
 172
 173 fun reduce G fname =
 174     let
 175         val (G, body) = check G fname
 176     in
 177         if !ErrorMsg.anyErrors then
 178             (G, NONE)
 179         else
 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']))*)
 189                     (G, SOME body')
 190                 end
 191               | _ => (G, NONE)
 192     end
 193
 194 (*(Defaults.eInit ())*)
 195
 196 fun eval G evs fname =
 197     case reduce G fname of
 198         (G, SOME body') =>
 199         if !ErrorMsg.anyErrors then
 200             raise ErrorMsg.Error
 201         else
 202             let
 203                 val evs' = Eval.exec' evs body'
 204             in
 205                 (G, evs')
 206             end
 207       | (G, NONE) => (G, evs)
 208
 209 val dispatcher =
 210     Config.dispatcher ^ ":" ^ Int.toString Config.dispatcherPort
 211
 212 val self =
 213     "localhost:" ^ Int.toString Config.slavePort
 214
 215 fun context x =
 216     (OpenSSL.context false x)
 217     handle e as OpenSSL.OpenSSL s =>
 218            (print "Couldn't find your certificate.\nYou probably haven't been given any Domtool privileges.\n";
 219             print ("I looked in: " ^ #1 x ^ "\n");
 220             print ("Additional information: " ^ s ^ "\n");
 221             raise e)
 222
 223 fun requestContext f =
 224     let
 225         val user = setupUser ()
 226
 227         val () = f ()
 228
 229         val context = context (Config.certDir ^ "/" ^ user ^ ".pem",
 230                                Config.keyDir ^ "/" ^ user ^ "/key.pem",
 231                                Config.trustStore)
 232     in
 233         (user, context)
 234     end
 235
 236 fun requestBio' printErr f =
 237     let
 238         val (user, context) = requestContext f
 239     in
 240         (user, OpenSSL.connect printErr (context, dispatcher))
 241     end
 242
 243 val requestBio = requestBio' true
 244
 245 fun requestSlaveBio' printErr =
 246     let
 247         val (user, context) = requestContext (fn () => ())
 248     in
 249         (user, OpenSSL.connect printErr (context, self))
 250     end
 251
 252 fun requestSlaveBio () = requestSlaveBio' true
 253
 254 fun request (fname, libOpt) =
 255     let
 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
 269
 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
 278
 279         val code = readFile fname
 280         val msg = case libOpt of
 281                       NONE => MsgConfig code
 282                     | SOME fname' => MsgMultiConfig [readFile fname', code]
 283     in
 284         Msg.send (bio, msg);
 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";
 292         OpenSSL.close bio
 293     end
 294     handle ErrorMsg.Error => ()
 295
 296 fun requestDir dname =
 297     let
 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";
 303                      print "files in your ~/.domtool directory?\n";
 304                      OS.Process.exit OS.Process.failure)
 305
 306         val _ = ErrorMsg.reset ()
 307
 308         val (user, bio) = requestBio (fn () => checkDir' dname)
 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
 330                     raise ErrorMsg.Error
 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
 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)
 359     end
 360     handle ErrorMsg.Error => ()
 361
 362 fun requestPing () =
 363     let
 364         val (_, bio) = requestBio' false (fn () => ())
 365     in
 366         OpenSSL.close bio;
 367         OS.Process.success
 368     end
 369     handle _ => OS.Process.failure
 370
 371 fun requestShutdown () =
 372     let
 373         val (_, bio) = requestBio (fn () => ())
 374     in
 375         Msg.send (bio, MsgShutdown);
 376         case Msg.recv bio of
 377             NONE => ()
 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
 386 fun requestSlavePing () =
 387     let
 388         val (_, bio) = requestSlaveBio' false
 389     in
 390         OpenSSL.close bio;
 391         OS.Process.success
 392     end
 393     handle _ => OS.Process.failure
 394
 395 fun requestSlaveShutdown () =
 396     let
 397         val (_, bio) = requestSlaveBio ()
 398     in
 399         Msg.send (bio, MsgShutdown);
 400         case Msg.recv bio of
 401             NONE => ()
 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
 410 fun 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
 425 fun 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
 440 fun 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
 458 fun 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
 476 fun 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
 491 fun 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
 506 fun 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
 521 fun 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
 536 fun requestDbUser dbtype =
 537     let
 538         val (_, context) = requestContext (fn () => ())
 539         val bio = OpenSSL.connect true (context,
 540                                         Config.Dbms.dbmsNode ^ ":" ^ Int.toString Config.slavePort)
 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
 553 fun requestDbPasswd rc =
 554     let
 555         val (_, context) = requestContext (fn () => ())
 556         val bio = OpenSSL.connect true (context,
 557                                         Config.Dbms.dbmsNode ^ ":" ^ Int.toString Config.slavePort)
 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
 570 fun requestDbTable p =
 571     let
 572         val (user, context) = requestContext (fn () => ())
 573         val bio = OpenSSL.connect true (context,
 574                                         Config.Dbms.dbmsNode ^ ":" ^ Int.toString Config.slavePort)
 575     in
 576         Msg.send (bio, MsgCreateDb p);
 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
 587 fun requestDbDrop p =
 588     let
 589         val (user, context) = requestContext (fn () => ())
 590         val bio = OpenSSL.connect true (context,
 591                                         Config.Dbms.dbmsNode ^ ":" ^ Int.toString Config.slavePort)
 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
 604 fun requestDbGrant p =
 605     let
 606         val (user, context) = requestContext (fn () => ())
 607         val bio = OpenSSL.connect true (context,
 608                                         Config.Dbms.dbmsNode ^ ":" ^ Int.toString Config.slavePort)
 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
 621 fun requestListMailboxes domain =
 622     let
 623         val (_, bio) = requestBio (fn () => ())
 624     in
 625         Msg.send (bio, MsgListMailboxes domain);
 626         (case Msg.recv bio of
 627              NONE => Vmail.Error "Server closed connection unexpectedly."
 628            | SOME m =>
 629              case m of
 630                  MsgMailboxes users => (Msg.send (bio, MsgOk);
 631                                         Vmail.Listing users)
 632                | MsgError s => Vmail.Error ("Listing failed: " ^ s)
 633                | _ => Vmail.Error "Unexpected server reply.")
 634         before OpenSSL.close bio
 635     end
 636
 637 fun 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
 652 fun 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
 667 fun 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
 682 fun 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
 699 fun 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
 715 fun 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
 736 fun requestMysqlFixperms () =
 737     let
 738         val (_, context) = requestContext (fn () => ())
 739         val bio = OpenSSL.connect true (context,
 740                                         Config.Dbms.dbmsNode ^ ":" ^ Int.toString Config.slavePort)
 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
 753 fun requestApt {node, pkg} =
 754     let
 755         val (user, context) = requestContext (fn () => ())
 756         val bio = OpenSSL.connect true (context, if node = Config.dispatcherName then
 757                                                      dispatcher
 758                                                  else
 759                                                      Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
 760
 761         val _ = Msg.send (bio, MsgQuery (QApt pkg))
 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
 782 fun 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
 811 fun requestCron {node, uname} =
 812     let
 813         val (user, context) = requestContext (fn () => ())
 814         val bio = OpenSSL.connect true (context, if node = Config.dispatcherName then
 815                                                      dispatcher
 816                                                  else
 817                                                      Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
 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
 840 fun requestFtp {node, uname} =
 841     let
 842         val (user, context) = requestContext (fn () => ())
 843         val bio = OpenSSL.connect true (context, if node = Config.dispatcherName then
 844                                                      dispatcher
 845                                                  else
 846                                                      Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
 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
 869 fun requestTrustedPath {node, uname} =
 870     let
 871         val (user, context) = requestContext (fn () => ())
 872         val bio = OpenSSL.connect true (context, if node = Config.dispatcherName then
 873                                                      dispatcher
 874                                                  else
 875                                                      Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
 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
 898 fun requestSocketPerm {node, uname} =
 899     let
 900         val (user, context) = requestContext (fn () => ())
 901         val bio = OpenSSL.connect true (context, if node = Config.dispatcherName then
 902                                                      dispatcher
 903                                                  else
 904                                                      Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
 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
 929 fun requestFirewall {node, uname} =
 930     let
 931         val (user, context) = requestContext (fn () => ())
 932         val bio = OpenSSL.connect true (context, if node = Config.dispatcherName then
 933                                                      dispatcher
 934                                                  else
 935                                                      Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
 936
 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
 956 fun 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
 971 fun 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
 986 fun 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
1011 structure SS = StringSet
1012
1013 fun 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
1060 fun regenerateEither tc checker context =
1061     let
1062         val () = print "Starting regeneration....\n"
1063
1064         val domainsBefore =
1065             if tc then
1066                 SS.empty
1067             else
1068                 domainList Config.resultRoot
1069
1070         fun ifReal f =
1071             if tc then
1072                 ()
1073             else
1074                 f ()
1075
1076         val _ = ErrorMsg.reset ()
1077
1078         val b = basis ()
1079         val () = Tycheck.disallowExterns ()
1080
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 ()))
1086
1087         val ok = ref true
1088
1089         fun contactNode (node, ip) =
1090             if node = Config.defaultNode then
1091                 Domain.resetLocal ()
1092             else let
1093                     val bio = OpenSSL.connect true (context,
1094                                                     ip
1095                                                     ^ ":"
1096                                                     ^ Int.toString Config.slavePort)
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
1110                 end
1111                  handle OpenSSL.OpenSSL s => print ("OpenSSL error: " ^ s ^ "\n")
1112
1113         fun doUser user =
1114             let
1115                 val _ = Domain.setUser user
1116                 val _ = ErrorMsg.reset ()
1117
1118                 val dname = Config.domtoolDir user
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
1135
1136                         val files = loop []
1137                         val (_, files) = Order.order (SOME b) files
1138
1139                         fun checker' (file, (G, evs)) =
1140                             checker G evs file
1141                     in
1142                         if !ErrorMsg.anyErrors then
1143                             (ErrorMsg.reset ();
1144                              print ("User " ^ user ^ "'s configuration has errors!\n");
1145                              ok := false)
1146                         else
1147                             ();
1148                         ignore (foldl checker' (basis (), Defaults.eInit ()) files)
1149                     end
1150                 else if String.isSuffix "_admin" user then
1151                     ()
1152                 else
1153                     (print ("Couldn't access " ^ user ^ "'s ~/.domtool directory.\n");
1154                      ok := false)
1155             end
1156             handle IO.Io {name, function, ...} =>
1157                    (print ("IO error processing user " ^ user ^ ": " ^ function ^ ": " ^ name ^ "\n");
1158                     ok := false)
1159                  | exn as OS.SysErr (s, _) => (print ("System error processing user " ^ user ^ ": " ^ s ^ "\n");
1160                                                ok := false)
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)
1166     in
1167         ifReal (fn () => (app contactNode Config.nodeIps;
1168                           Env.pre ()));
1169         app doUser (Acl.users ());
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);
1186         !ok
1187     end
1188
1189 val regenerate = regenerateEither false eval
1190 val regenerateTc = regenerateEither true
1191                                     (fn G => fn evs => fn file =>
1192                                                           (#1 (check G file), evs))
1193
1194 fun usersChanged () =
1195     (Domain.onUsersChange ();
1196      ignore (OS.Process.system Config.publish_reusers))
1197
1198 fun 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;
1207         Domain.rmdom doms;
1208         usersChanged ()
1209     end
1210
1211 fun now () = Date.toString (Date.fromTimeUniv (Time.now ()))
1212
1213 fun answerQuery q =
1214     case q of
1215         QApt pkg => if Apt.installed pkg then MsgYes else MsgNo
1216       | QAptExists pkg => if Apt.exists pkg then MsgYes else MsgNo
1217       | QCron user => if Cron.allowed user then MsgYes else MsgNo
1218       | QFtp user => if Ftp.allowed user then MsgYes else MsgNo
1219       | QTrustedPath user => if TrustedPath.query user then MsgYes else MsgNo
1220       | QSocket user => MsgSocket (SocketPerm.query user)
1221       | QFirewall user => MsgFirewall (Firewall.query user)
1222
1223 fun describeQuery q =
1224     case q of
1225         QApt pkg => "Requested installation status of package " ^ pkg
1226       | QAptExists pkg => "Requested if package " ^ pkg ^ " exists"
1227       | QCron user => "Asked about cron permissions for user " ^ user
1228       | QFtp user => "Asked about FTP permissions for user " ^ user
1229       | QTrustedPath user => "Asked about trusted path settings for user " ^ user
1230       | QSocket user => "Asked about socket permissions for user " ^ user
1231       | QFirewall user => "Asked about firewall rules for user " ^ user
1232
1233 fun 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
1270 fun service () =
1271     let
1272         val host = Slave.hostname ()
1273
1274         val () = Acl.read Config.aclFile
1275
1276         val context = context (Config.certDir ^ "/" ^ host ^ ".pem",
1277                                Config.keyDir ^ "/" ^ host ^ "/key.pem",
1278                                Config.trustStore)
1279         val _ = Domain.set_context context
1280
1281         val sock = OpenSSL.listen (context, Config.dispatcherPort)
1282
1283         fun loop () =
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
1291                      val doIt = doIt' loop bio
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
1301                              fun doOne (code, (G, evs)) =
1302                                  let
1303                                      val outf = TextIO.openOut outname
1304                                  in
1305                                      TextIO.output (outf, code);
1306                                      TextIO.closeOut outf;
1307                                      eval G evs outname
1308                                  end
1309                          in
1310                              doIt (fn () => (Env.pre ();
1311                                              ignore (foldl doOne (basis (), Defaults.eInit ()) codes);
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;
1357                                                if #class acl = "user" then
1358                                                    usersChanged ()
1359                                                else
1360                                                    ();
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"}
1397                                              orelse List.all (fn dom => Domain.validDomain dom
1398                                                                         andalso Acl.queryDomain {user = user, domain = dom}) doms then
1399                                               (Domain.rmdom doms;
1400                                                (*app (fn dom =>
1401                                                        Acl.revokeFromAll {class = "domain", value = dom}) doms;
1402                                                Acl.write Config.aclFile;*)
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
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,
1479                                                SOME ("You're not authorized to use that mailbox location. ("
1480                                                      ^ mailbox ^ ")"))
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 () => ())
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
1580                                | MsgReUsers =>
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."))
1588                                       (fn () => ())
1589
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
1601                          handle OpenSSL.OpenSSL _ => ();
1602                          loop ())
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 ())
1614                       | OS.Path.InvalidArc =>
1615                         (print "Invalid arc\n";
1616                          OpenSSL.close bio
1617                          handle OpenSSL.OpenSSL _ => ();
1618                          loop ())
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 ())
1640     in
1641         print ("Domtool dispatcher starting up at " ^ now () ^ "\n");
1642         print "Listening for connections....\n";
1643         loop ();
1644         OpenSSL.shutdown sock
1645     end
1646
1647 fun slave () =
1648     let
1649         val host = Slave.hostname ()
1650
1651         val context = context (Config.certDir ^ "/" ^ host ^ ".pem",
1652                                Config.keyDir ^ "/" ^ host ^ "/key.pem",
1653                                Config.trustStore)
1654
1655         val sock = OpenSSL.listen (context, Config.slavePort)
1656
1657         val _ = print ("Slave server starting at " ^ now () ^ "\n")
1658
1659         fun loop () =
1660             (case OpenSSL.accept sock of
1661                  NONE => ()
1662                | SOME bio =>
1663                  let
1664                      val peer = OpenSSL.peerCN bio
1665                      val () = print ("\nConnection from " ^ peer ^ " at " ^ now () ^ "\n")
1666                  in
1667                      if peer = Config.dispatcherName then let
1668                              fun loop' files =
1669                                  case Msg.recv bio of
1670                                      NONE => print "Dispatcher closed connection unexpectedly\n"
1671                                    | SOME m =>
1672                                      case m of
1673                                          MsgFile file => loop' (file :: files)
1674                                        | MsgDoFiles => (Slave.handleChanges files;
1675                                                         Msg.send (bio, MsgOk))
1676                                        | MsgRegenerate => (Domain.resetLocal ();
1677                                                            Msg.send (bio, MsgOk))
1678                                        | MsgVmailChanged => (if Vmail.doChanged () then
1679                                                                  Msg.send (bio, MsgOk)
1680                                                              else
1681                                                                  Msg.send (bio, MsgError "userdb update failed"))
1682                                        | _ => (print "Dispatcher sent unexpected command\n";
1683                                                Msg.send (bio, MsgError "Unexpected command"))
1684                          in
1685                              loop' [];
1686                              ignore (OpenSSL.readChar bio);
1687                              OpenSSL.close bio;
1688                              loop ()
1689                          end
1690                      else if peer = "domtool" then
1691                          case Msg.recv bio of
1692                              SOME MsgShutdown => (OpenSSL.close bio;
1693                                                   print ("Shutting down at " ^ now () ^ "\n\n"))
1694                            | _ => (OpenSSL.close bio;
1695                                    loop ())
1696                      else
1697                          let
1698                              val doIt = doIt' loop bio
1699                              val user = peer
1700                          in
1701                              case Msg.recv bio of
1702                                  NONE => (OpenSSL.close bio
1703                                           handle OpenSSL.OpenSSL _ => ();
1704                                           loop ())
1705                                | SOME m =>
1706                                  case m of
1707                                      (MsgQuery q) => (print (describeQuery q ^ "\n");
1708                                                       Msg.send (bio, answerQuery q);
1709                                                       ignore (OpenSSL.readChar bio);
1710                                                       OpenSSL.close bio;
1711                                                       loop ())
1712                                    | MsgCreateDbUser {dbtype, passwd} =>
1713                                      doIt (fn () =>
1714                                               case Dbms.lookup dbtype of
1715                                                   NONE => ("Database user creation request with unknown datatype type " ^ dbtype,
1716                                                            SOME ("Unknown database type " ^ dbtype))
1717                                                 | SOME handler =>
1718                                                   case #adduser handler {user = user, passwd = passwd} of
1719                                                       NONE => ("Added " ^ dbtype ^ " user " ^ user ^ ".",
1720                                                                NONE)
1721                                                     | SOME msg =>
1722                                                       ("Error adding a " ^ dbtype ^ " user " ^ user ^ ": " ^ msg,
1723                                                        SOME ("Error adding user: " ^ msg)))
1724                                           (fn () => ())
1725
1726                                    | MsgDbPasswd {dbtype, passwd} =>
1727                                      doIt (fn () =>
1728                                               case Dbms.lookup dbtype of
1729                                                   NONE => ("Database passwd request with unknown datatype type " ^ dbtype,
1730                                                            SOME ("Unknown database type " ^ dbtype))
1731                                                 | SOME handler =>
1732                                                   case #passwd handler {user = user, passwd = passwd} of
1733                                                       NONE => ("Changed " ^ dbtype ^ " password of user " ^ user ^ ".",
1734                                                                NONE)
1735                                                     | SOME msg =>
1736                                                       ("Error setting " ^ dbtype ^ " password of user " ^ user ^ ": " ^ msg,
1737                                                        SOME ("Error adding user: " ^ msg)))
1738                                           (fn () => ())
1739
1740                                    | MsgCreateDb {dbtype, dbname, encoding} =>
1741                                      doIt (fn () =>
1742                                               if Dbms.validDbname dbname then
1743                                                   case Dbms.lookup dbtype of
1744                                                       NONE => ("Database creation request with unknown datatype type " ^ dbtype,
1745                                                                SOME ("Unknown database type " ^ dbtype))
1746                                                     | SOME handler =>
1747                                                       if not (Dbms.validEncoding encoding) then
1748                                                           ("Invalid encoding " ^ valOf encoding ^ " requested for database creation.",
1749                                                            SOME "Invalid encoding")
1750                                                       else
1751                                                           case #createdb handler {user = user, dbname = dbname, encoding = encoding} of
1752                                                               NONE => ("Created database " ^ user ^ "_" ^ dbname ^ ".",
1753                                                                        NONE)
1754                                                             | SOME msg => ("Error creating database " ^ user ^ "_" ^ dbname ^ ": " ^ msg,
1755                                                                            SOME ("Error creating database: " ^ msg))
1756                                               else
1757                                                   ("Invalid database name " ^ user ^ "_" ^ dbname,
1758                                                    SOME ("Invalid database name " ^ dbname)))
1759                                           (fn () => ())
1760
1761                                    | MsgDropDb {dbtype, dbname} =>
1762                                      doIt (fn () =>
1763                                               if Dbms.validDbname dbname then
1764                                                   case Dbms.lookup dbtype of
1765                                                       NONE => ("Database drop request with unknown datatype type " ^ dbtype,
1766                                                                SOME ("Unknown database type " ^ dbtype))
1767                                                     | SOME handler =>
1768                                                       case #dropdb handler {user = user, dbname = dbname} of
1769                                                           NONE => ("Drop database " ^ user ^ "_" ^ dbname ^ ".",
1770                                                                    NONE)
1771                                                         | SOME msg => ("Error dropping database " ^ user ^ "_" ^ dbname ^ ": " ^ msg,
1772                                                                        SOME ("Error dropping database: " ^ msg))
1773                                               else
1774                                                   ("Invalid database name " ^ user ^ "_" ^ dbname,
1775                                                    SOME ("Invalid database name " ^ dbname)))
1776                                           (fn () => ())
1777
1778                                    | MsgGrantDb {dbtype, dbname} =>
1779                                      doIt (fn () =>
1780                                               if Dbms.validDbname dbname then
1781                                                   case Dbms.lookup dbtype of
1782                                                       NONE => ("Database drop request with unknown datatype type " ^ dbtype,
1783                                                                SOME ("Unknown database type " ^ dbtype))
1784                                                     | SOME handler =>
1785                                                       case #grant handler {user = user, dbname = dbname} of
1786                                                           NONE => ("Grant permissions to database " ^ user ^ "_" ^ dbname ^ ".",
1787                                                                    NONE)
1788                                                         | SOME msg => ("Error granting permissions to database " ^ user ^ "_" ^ dbname ^ ": " ^ msg,
1789                                                                        SOME ("Error granting permissions to database: " ^ msg))
1790                                               else
1791                                                   ("Invalid database name " ^ user ^ "_" ^ dbname,
1792                                                    SOME ("Invalid database name " ^ dbname)))
1793                                           (fn () => ())
1794                                    | MsgMysqlFixperms =>
1795                                      (print "Starting mysql-fixperms\n";
1796                                       doIt (fn () => if OS.Process.isSuccess
1797                                                             (OS.Process.system "/usr/bin/sudo -H /afs/hcoop.net/common/etc/scripts/mysql-grant-table-drop") then
1798                                                          ("Requested mysql-fixperms",
1799                                                           NONE)
1800                                                      else
1801                                                          ("Requested mysql-fixperms, but execution failed!",
1802                                                           SOME "Script execution failed."))
1803                                            (fn () => ()))
1804                                    | MsgFirewallRegen =>
1805                                      doIt (fn () => (Acl.read Config.aclFile;
1806                                                      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))
1814                                                      else
1815                                                          ("Not authorized to regenerate firewall.", SOME ("Unauthorized user " ^ user ^ " attempted to regenerated firewall"))))
1816                                           (fn () => ())
1817
1818                                    | _ => (OpenSSL.close bio;
1819                                            loop ())
1820                          end
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 ())
1850     in
1851         loop ();
1852         OpenSSL.shutdown sock
1853     end
1854
1855 fun listBasis () =
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
1870     in
1871         loop []
1872     end
1873
1874 fun autodocBasis outdir =
1875     Autodoc.autodoc {outdir = outdir, infiles = listBasis ()}
1876
1877 end