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                     MsgAptQuery {section,description}  =>  (print "Package exists.\n";
 799                                                             print ("Section: " ^ section ^ "\n");
 800                                                             print ("Description: " ^ description ^ "\n");
 801                                                             OS.Process.success)
 802                   | MsgNo => (print "Package does not exist.\n";
 803                               OS.Process.failure
 804                              (* It might be the Wrong Thing (tm) to use MsgNo like this *))
 805                   | MsgError s => (print ("APT existence query failed: " ^ s ^ "\n");
 806                                    OS.Process.failure)
 807                   | _ => (print "Unexpected server reply.\n";
 808                           OS.Process.failure)
 809     in
 810         loop ()
 811         before OpenSSL.close bio
 812     end
 813
 814 fun requestCron {node, uname} =
 815     let
 816         val (user, context) = requestContext (fn () => ())
 817         val bio = OpenSSL.connect true (context, if node = Config.dispatcherName then
 818                                                      dispatcher
 819                                                  else
 820                                                      Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
 821
 822         val _ = Msg.send (bio, MsgQuery (QCron uname))
 823
 824         fun loop () =
 825             case Msg.recv bio of
 826                 NONE => (print "Server closed connection unexpectedly.\n";
 827                          OS.Process.failure)
 828               | SOME m =>
 829                 case m of
 830                     MsgYes => (print "User has cron permissions.\n";
 831                                OS.Process.success)
 832                   | MsgNo => (print "User does not have cron permissions.\n";
 833                               OS.Process.failure)
 834                   | MsgError s => (print ("Cron query failed: " ^ s ^ "\n");
 835                                    OS.Process.failure)
 836                   | _ => (print "Unexpected server reply.\n";
 837                           OS.Process.failure)
 838     in
 839         loop ()
 840         before OpenSSL.close bio
 841     end
 842
 843 fun requestFtp {node, uname} =
 844     let
 845         val (user, context) = requestContext (fn () => ())
 846         val bio = OpenSSL.connect true (context, if node = Config.dispatcherName then
 847                                                      dispatcher
 848                                                  else
 849                                                      Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
 850
 851         val _ = Msg.send (bio, MsgQuery (QFtp uname))
 852
 853         fun loop () =
 854             case Msg.recv bio of
 855                 NONE => (print "Server closed connection unexpectedly.\n";
 856                          OS.Process.failure)
 857               | SOME m =>
 858                 case m of
 859                     MsgYes => (print "User has FTP permissions.\n";
 860                                OS.Process.success)
 861                   | MsgNo => (print "User does not have FTP permissions.\n";
 862                               OS.Process.failure)
 863                   | MsgError s => (print ("FTP query failed: " ^ s ^ "\n");
 864                                    OS.Process.failure)
 865                   | _ => (print "Unexpected server reply.\n";
 866                           OS.Process.failure)
 867     in
 868         loop ()
 869         before OpenSSL.close bio
 870     end
 871
 872 fun requestTrustedPath {node, uname} =
 873     let
 874         val (user, context) = requestContext (fn () => ())
 875         val bio = OpenSSL.connect true (context, if node = Config.dispatcherName then
 876                                                      dispatcher
 877                                                  else
 878                                                      Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
 879
 880         val _ = Msg.send (bio, MsgQuery (QTrustedPath uname))
 881
 882         fun loop () =
 883             case Msg.recv bio of
 884                 NONE => (print "Server closed connection unexpectedly.\n";
 885                          OS.Process.failure)
 886               | SOME m =>
 887                 case m of
 888                     MsgYes => (print "User has trusted path restriction.\n";
 889                                OS.Process.success)
 890                   | MsgNo => (print "User does not have trusted path restriction.\n";
 891                               OS.Process.failure)
 892                   | MsgError s => (print ("Trusted path query failed: " ^ s ^ "\n");
 893                                    OS.Process.failure)
 894                   | _ => (print "Unexpected server reply.\n";
 895                           OS.Process.failure)
 896     in
 897         loop ()
 898         before OpenSSL.close bio
 899     end
 900
 901 fun requestSocketPerm {node, uname} =
 902     let
 903         val (user, context) = requestContext (fn () => ())
 904         val bio = OpenSSL.connect true (context, if node = Config.dispatcherName then
 905                                                      dispatcher
 906                                                  else
 907                                                      Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
 908
 909         val _ = Msg.send (bio, MsgQuery (QSocket uname))
 910
 911         fun loop () =
 912             case Msg.recv bio of
 913                 NONE => (print "Server closed connection unexpectedly.\n";
 914                          OS.Process.failure)
 915               | SOME m =>
 916                 case m of
 917                     MsgSocket p => (case p of
 918                                         Any => print "Any\n"
 919                                       | Client => print "Client\n"
 920                                       | Server => print "Server\n"
 921                                       | Nada => print "Nada\n";
 922                                     OS.Process.success)
 923                   | MsgError s => (print ("Socket permission query failed: " ^ s ^ "\n");
 924                                    OS.Process.failure)
 925                   | _ => (print "Unexpected server reply.\n";
 926                           OS.Process.failure)
 927     in
 928         loop ()
 929         before OpenSSL.close bio
 930     end
 931
 932 fun requestFirewall {node, uname} =
 933     let
 934         val (user, context) = requestContext (fn () => ())
 935         val bio = OpenSSL.connect true (context, if node = Config.dispatcherName then
 936                                                      dispatcher
 937                                                  else
 938                                                      Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
 939
 940         val _ = Msg.send (bio, MsgQuery (QFirewall uname))
 941
 942         fun loop () =
 943             case Msg.recv bio of
 944                 NONE => (print "Server closed connection unexpectedly.\n";
 945                          OS.Process.failure)
 946               | SOME m =>
 947                 case m of
 948                     MsgFirewall ls => (app (fn s => (print s; print "\n")) ls;
 949                                        OS.Process.success)
 950                   | MsgError s => (print ("Firewall query failed: " ^ s ^ "\n");
 951                                    OS.Process.failure)
 952                   | _ => (print "Unexpected server reply.\n";
 953                           OS.Process.failure)
 954     in
 955         loop ()
 956         before OpenSSL.close bio
 957     end
 958
 959 fun requestDescribe dom =
 960     let
 961         val (_, bio) = requestBio (fn () => ())
 962     in
 963         Msg.send (bio, MsgDescribe dom);
 964         case Msg.recv bio of
 965             NONE => print "Server closed connection unexpectedly.\n"
 966           | SOME m =>
 967             case m of
 968                 MsgDescription s => print s
 969               | MsgError s => print ("Description failed: " ^ s ^ "\n")
 970               | _ => print "Unexpected server reply.\n";
 971         OpenSSL.close bio
 972     end
 973
 974 fun requestReUsers () =
 975     let
 976         val (_, bio) = requestBio (fn () => ())
 977     in
 978         Msg.send (bio, MsgReUsers);
 979         case Msg.recv bio of
 980             NONE => print "Server closed connection unexpectedly.\n"
 981           | SOME m =>
 982             case m of
 983                 MsgOk => print "Callbacks run.\n"
 984               | MsgError s => print ("Failed: " ^ s ^ "\n")
 985               | _ => print "Unexpected server reply.\n";
 986         OpenSSL.close bio
 987     end
 988
 989 fun requestFirewallRegen node =
 990     let
 991         val (user, context) = requestContext (fn () => ())
 992         val bio = OpenSSL.connect true (context, Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
 993         (* Only supporting on slave nodes *)
 994
 995         val _ = Msg.send (bio, MsgFirewallRegen)
 996
 997         fun handleResult () =
 998             case Msg.recv bio of
 999                 NONE => (print "Server closed connection unexpectedly.\n";
1000                          OS.Process.failure)
1001               | SOME m =>
1002                 case m of
1003                     MsgOk => (print "Firewall regenerated.\n";
1004                               OS.Process.success)
1005                   | MsgError s => (print ("Firewall regeneration failed: " ^ s ^ "\n");
1006                                    OS.Process.failure)
1007                   | _ => (print "Unexpected server reply.\n";
1008                           OS.Process.failure)
1009     in
1010         handleResult()
1011         before OpenSSL.close bio
1012     end
1013
1014 structure SS = StringSet
1015
1016 fun domainList dname =
1017     let
1018         val dir = Posix.FileSys.opendir dname
1019
1020         fun visitNode dset =
1021             case Posix.FileSys.readdir dir of
1022                 NONE => dset
1023               | SOME node =>
1024                 let
1025                     val path = OS.Path.joinDirFile {dir = dname,
1026                                                     file = node}
1027
1028                     fun visitDomains (path, bfor, dset) =
1029                         let
1030                             val dir = Posix.FileSys.opendir path
1031
1032                             fun loop dset =
1033                                 case Posix.FileSys.readdir dir of
1034                                     NONE => dset
1035                                   | SOME dname =>
1036                                     let
1037                                         val path = OS.Path.joinDirFile {dir = path,
1038                                                                         file = dname}
1039                                     in
1040                                         if Posix.FileSys.ST.isDir (Posix.FileSys.stat path) then
1041                                             let
1042                                                 val bfor = dname :: bfor
1043                                             in
1044                                                 loop (visitDomains (path, bfor,
1045                                                                     SS.add (dset,
1046                                                                             String.concatWith "." bfor)))
1047                                             end
1048                                         else
1049                                             loop dset
1050                                     end
1051                         in
1052                             loop dset
1053                             before Posix.FileSys.closedir dir
1054                         end
1055                 in
1056                     visitNode (visitDomains (path, [], dset))
1057                 end
1058     in
1059         visitNode SS.empty
1060         before Posix.FileSys.closedir dir
1061     end
1062
1063 fun regenerateEither tc checker context =
1064     let
1065         val () = print "Starting regeneration....\n"
1066
1067         val domainsBefore =
1068             if tc then
1069                 SS.empty
1070             else
1071                 domainList Config.resultRoot
1072
1073         fun ifReal f =
1074             if tc then
1075                 ()
1076             else
1077                 f ()
1078
1079         val _ = ErrorMsg.reset ()
1080
1081         val b = basis ()
1082         val () = Tycheck.disallowExterns ()
1083
1084         val () = ifReal (fn () =>
1085                             (ignore (OS.Process.system ("rm -rf " ^ Config.oldResultRoot ^ "/*"));
1086                              ignore (OS.Process.system ("cp -r " ^ Config.resultRoot
1087                                                         ^ "/* " ^ Config.oldResultRoot ^ "/"));
1088                              Domain.resetGlobal ()))
1089
1090         val ok = ref true
1091
1092         fun contactNode (node, ip) =
1093             if node = Config.defaultNode then
1094                 Domain.resetLocal ()
1095             else let
1096                     val bio = OpenSSL.connect true (context,
1097                                                     ip
1098                                                     ^ ":"
1099                                                     ^ Int.toString Config.slavePort)
1100                 in
1101                     Msg.send (bio, MsgRegenerate);
1102                     case Msg.recv bio of
1103                         NONE => print "Slave closed connection unexpectedly\n"
1104                       | SOME m =>
1105                         case m of
1106                             MsgOk => print ("Slave " ^ node ^ " pre-regeneration finished\n")
1107                           | MsgError s => print ("Slave " ^ node
1108                                                  ^ " returned error: " ^
1109                                                  s ^ "\n")
1110                           | _ => print ("Slave " ^ node
1111                                         ^ " returned unexpected command\n");
1112                     OpenSSL.close bio
1113                 end
1114                  handle OpenSSL.OpenSSL s => print ("OpenSSL error: " ^ s ^ "\n")
1115
1116         fun doUser user =
1117             let
1118                 val _ = Domain.setUser user
1119                 val _ = ErrorMsg.reset ()
1120
1121                 val dname = Config.domtoolDir user
1122             in
1123                 if Posix.FileSys.access (dname, []) then
1124                     let
1125                         val dir = Posix.FileSys.opendir dname
1126
1127                         fun loop files =
1128                             case Posix.FileSys.readdir dir of
1129                                 NONE => (Posix.FileSys.closedir dir;
1130                                          files)
1131                               | SOME fname =>
1132                                 if notTmp fname then
1133                                     loop (OS.Path.joinDirFile {dir = dname,
1134                                                                file = fname}
1135                                           :: files)
1136                                 else
1137                                     loop files
1138
1139                         val files = loop []
1140                         val (_, files) = Order.order (SOME b) files
1141
1142                         fun checker' (file, (G, evs)) =
1143                             checker G evs file
1144                     in
1145                         if !ErrorMsg.anyErrors then
1146                             (ErrorMsg.reset ();
1147                              print ("User " ^ user ^ "'s configuration has errors!\n");
1148                              ok := false)
1149                         else
1150                             ();
1151                         ignore (foldl checker' (basis (), Defaults.eInit ()) files)
1152                     end
1153                 else if String.isSuffix "_admin" user then
1154                     ()
1155                 else
1156                     (print ("Couldn't access " ^ user ^ "'s ~/.domtool directory.\n");
1157                      ok := false)
1158             end
1159             handle IO.Io {name, function, ...} =>
1160                    (print ("IO error processing user " ^ user ^ ": " ^ function ^ ": " ^ name ^ "\n");
1161                     ok := false)
1162                  | exn as OS.SysErr (s, _) => (print ("System error processing user " ^ user ^ ": " ^ s ^ "\n");
1163                                                ok := false)
1164                  | ErrorMsg.Error => (ErrorMsg.reset ();
1165                                       print ("User " ^ user ^ " had a compilation error.\n");
1166                                       ok := false)
1167                  | _ => (print "Unknown exception during regeneration!\n";
1168                          ok := false)
1169     in
1170         ifReal (fn () => (app contactNode Config.nodeIps;
1171                           Env.pre ()));
1172         app doUser (Acl.users ());
1173         ifReal (fn () =>
1174                    let
1175                        val domainsAfter = domainList Config.resultRoot
1176                        val domainsGone = SS.difference (domainsBefore, domainsAfter)
1177                    in
1178                        if SS.isEmpty domainsGone then
1179                            ()
1180                        else
1181                            (print "Domains to kill:";
1182                             SS.app (fn s => (print " "; print s)) domainsGone;
1183                             print "\n";
1184
1185                             Domain.rmdom' Config.oldResultRoot (SS.listItems domainsGone));
1186
1187                        Env.post ()
1188                    end);
1189         !ok
1190     end
1191
1192 val regenerate = regenerateEither false eval
1193 val regenerateTc = regenerateEither true
1194                                     (fn G => fn evs => fn file =>
1195                                                           (#1 (check G file), evs))
1196
1197 fun usersChanged () =
1198     (Domain.onUsersChange ();
1199      ignore (OS.Process.system Config.publish_reusers))
1200
1201 fun rmuser user =
1202     let
1203         val doms = Acl.class {user = user, class = "domain"}
1204         val doms = List.filter (fn dom =>
1205                                    case Acl.whoHas {class = "domain", value = dom} of
1206                                        [_] => true
1207                                      | _ => false) (StringSet.listItems doms)
1208     in
1209         Acl.rmuser user;
1210         Domain.rmdom doms;
1211         usersChanged ()
1212     end
1213
1214 fun now () = Date.toString (Date.fromTimeUniv (Time.now ()))
1215
1216 fun answerQuery q =
1217     case q of
1218         QApt pkg => if Apt.installed pkg then MsgYes else MsgNo
1219       | QAptExists pkg => (case Apt.info pkg of
1220                               SOME {section, description} => MsgAptQuery {section = section, description = description}
1221                             | NONE => MsgNo)
1222       | QCron user => if Cron.allowed user then MsgYes else MsgNo
1223       | QFtp user => if Ftp.allowed user then MsgYes else MsgNo
1224       | QTrustedPath user => if TrustedPath.query user then MsgYes else MsgNo
1225       | QSocket user => MsgSocket (SocketPerm.query user)
1226       | QFirewall user => MsgFirewall (Firewall.query user)
1227
1228 fun describeQuery q =
1229     case q of
1230         QApt pkg => "Requested installation status of package " ^ pkg
1231       | QAptExists pkg => "Requested if package " ^ pkg ^ " exists"
1232       | QCron user => "Asked about cron permissions for user " ^ user
1233       | QFtp user => "Asked about FTP permissions for user " ^ user
1234       | QTrustedPath user => "Asked about trusted path settings for user " ^ user
1235       | QSocket user => "Asked about socket permissions for user " ^ user
1236       | QFirewall user => "Asked about firewall rules for user " ^ user
1237
1238 fun doIt' loop bio f cleanup =
1239                ((case f () of
1240                      (msgLocal, SOME msgRemote) =>
1241                      (print msgLocal;
1242                       print "\n";
1243                       Msg.send (bio, MsgError msgRemote))
1244                    | (msgLocal, NONE) =>
1245                      (print msgLocal;
1246                       print "\n";
1247                       Msg.send (bio, MsgOk)))
1248                 handle e as (OpenSSL.OpenSSL s) =>
1249                        (print ("OpenSSL error: " ^ s ^ "\n");
1250                         app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);
1251                         Msg.send (bio, MsgError ("OpenSSL error: " ^ s))
1252                         handle OpenSSL.OpenSSL _ => ())
1253                      | OS.SysErr (s, _) =>
1254                        (print "System error: ";
1255                         print s;
1256                         print "\n";
1257                         Msg.send (bio, MsgError ("System error: " ^ s))
1258                         handle OpenSSL.OpenSSL _ => ())
1259                      | Fail s =>
1260                        (print "Failure: ";
1261                         print s;
1262                         print "\n";
1263                         Msg.send (bio, MsgError ("Failure: " ^ s))
1264                         handle OpenSSL.OpenSSL _ => ())
1265                      | ErrorMsg.Error =>
1266                        (print "Compilation error\n";
1267                         Msg.send (bio, MsgError "Error during configuration evaluation")
1268                         handle OpenSSL.OpenSSL _ => ());
1269                 (cleanup ();
1270                  ignore (OpenSSL.readChar bio);
1271                  OpenSSL.close bio)
1272                 handle OpenSSL.OpenSSL _ => ();
1273                 loop ())
1274
1275 fun service () =
1276     let
1277         val host = Slave.hostname ()
1278
1279         val () = Acl.read Config.aclFile
1280
1281         val context = context (Config.certDir ^ "/" ^ host ^ ".pem",
1282                                Config.keyDir ^ "/" ^ host ^ "/key.pem",
1283                                Config.trustStore)
1284         val _ = Domain.set_context context
1285
1286         val sock = OpenSSL.listen (context, Config.dispatcherPort)
1287
1288         fun loop () =
1289             (case OpenSSL.accept sock of
1290                  NONE => ()
1291                | SOME bio =>
1292                  let
1293                      val user = OpenSSL.peerCN bio
1294                      val () = print ("\nConnection from " ^ user ^ " at " ^ now () ^ "\n")
1295                      val () = Domain.setUser user
1296                      val doIt = doIt' loop bio
1297
1298                      fun doConfig codes =
1299                          let
1300                              val _ = print "Configuration:\n"
1301                              val _ = app (fn s => (print s; print "\n")) codes
1302                              val _ = print "\n"
1303
1304                              val outname = OS.FileSys.tmpName ()
1305
1306                              fun doOne (code, (G, evs)) =
1307                                  let
1308                                      val outf = TextIO.openOut outname
1309                                  in
1310                                      TextIO.output (outf, code);
1311                                      TextIO.closeOut outf;
1312                                      eval G evs outname
1313                                  end
1314                          in
1315                              doIt (fn () => (Env.pre ();
1316                                              ignore (foldl doOne (basis (), Defaults.eInit ()) codes);
1317                                              Env.post ();
1318                                              Msg.send (bio, MsgOk);
1319                                              ("Configuration complete.", NONE)))
1320                                   (fn () => OS.FileSys.remove outname)
1321                          end
1322
1323                      fun checkAddr s =
1324                          case String.fields (fn ch => ch = #"@") s of
1325                              [user'] =>
1326                              if user = user' then
1327                                  SOME (SetSA.User s)
1328                              else
1329                                  NONE
1330                            | [user', domain] =>
1331                              if Domain.validEmailUser user' andalso Domain.yourDomain domain then
1332                                  SOME (SetSA.Email s)
1333                              else
1334                                  NONE
1335                            | _ => NONE
1336
1337                      fun cmdLoop () =
1338                          case Msg.recv bio of
1339                              NONE => (OpenSSL.close bio
1340                                       handle OpenSSL.OpenSSL _ => ();
1341                                       loop ())
1342                            | SOME m =>
1343                              case m of
1344                                  MsgConfig code => doConfig [code]
1345                                | MsgMultiConfig codes => doConfig codes
1346
1347                                | MsgShutdown =>
1348                                  if Acl.query {user = user, class = "priv", value = "all"}
1349                                     orelse Acl.query {user = user, class = "priv", value = "shutdown"} then
1350                                      print ("Domtool dispatcher shutting down at " ^ now () ^ "\n\n")
1351                                  else
1352                                      (print "Unauthorized shutdown command!\n";
1353                                       OpenSSL.close bio
1354                                       handle OpenSSL.OpenSSL _ => ();
1355                                       loop ())
1356
1357                                | MsgGrant acl =>
1358                                  doIt (fn () =>
1359                                           if Acl.query {user = user, class = "priv", value = "all"} then
1360                                               (Acl.grant acl;
1361                                                Acl.write Config.aclFile;
1362                                                if #class acl = "user" then
1363                                                    usersChanged ()
1364                                                else
1365                                                    ();
1366                                                ("Granted permission " ^ #value acl ^ " to " ^ #user acl ^ " in " ^ #class acl ^ ".",
1367                                                 NONE))
1368                                           else
1369                                               ("Unauthorized user asked to grant a permission!",
1370                                                SOME "Not authorized to grant privileges"))
1371                                       (fn () => ())
1372
1373                                | MsgRevoke acl =>
1374                                  doIt (fn () =>
1375                                           if Acl.query {user = user, class = "priv", value = "all"} then
1376                                               (Acl.revoke acl;
1377                                                Acl.write Config.aclFile;
1378                                                ("Revoked permission " ^ #value acl ^ " from " ^ #user acl ^ " in " ^ #class acl ^ ".",
1379                                                 NONE))
1380                                           else
1381                                               ("Unauthorized user asked to revoke a permission!",
1382                                                SOME "Not authorized to revoke privileges"))
1383                                       (fn () => ())
1384
1385                                | MsgListPerms user =>
1386                                  doIt (fn () =>
1387                                           (Msg.send (bio, MsgPerms (Acl.queryAll user));
1388                                            ("Sent permission list for user " ^ user ^ ".",
1389                                             NONE)))
1390                                       (fn () => ())
1391
1392                                | MsgWhoHas perm =>
1393                                  doIt (fn () =>
1394                                           (Msg.send (bio, MsgWhoHasResponse (Acl.whoHas perm));
1395                                            ("Sent whohas response for " ^ #class perm ^ " / " ^ #value perm ^ ".",
1396                                             NONE)))
1397                                       (fn () => ())
1398
1399                                | MsgRmdom doms =>
1400                                  doIt (fn () =>
1401                                           if Acl.query {user = user, class = "priv", value = "all"}
1402                                              orelse List.all (fn dom => Domain.validDomain dom
1403                                                                         andalso Acl.queryDomain {user = user, domain = dom}) doms then
1404                                               (Domain.rmdom doms;
1405                                                (*app (fn dom =>
1406                                                        Acl.revokeFromAll {class = "domain", value = dom}) doms;
1407                                                Acl.write Config.aclFile;*)
1408                                                ("Removed domains" ^ foldl (fn (d, s) => s ^ " " ^ d) "" doms ^ ".",
1409                                                 NONE))
1410                                           else
1411                                               ("Unauthorized user asked to remove a domain!",
1412                                                SOME "Not authorized to remove that domain"))
1413                                       (fn () => ())
1414
1415                                | MsgRegenerate =>
1416                                  doIt (fn () =>
1417                                           if Acl.query {user = user, class = "priv", value = "regen"}
1418                                              orelse Acl.query {user = user, class = "priv", value = "all"} then
1419                                               (if regenerate context then
1420                                                    ("Regenerated all configuration.",
1421                                                     NONE)
1422                                                else
1423                                                    ("Error regenerating configuration!",
1424                                                     SOME "Error regenerating configuration!  Consult /var/log/domtool.log."))
1425                                           else
1426                                               ("Unauthorized user asked to regenerate!",
1427                                                SOME "Not authorized to regenerate"))
1428                                       (fn () => ())
1429
1430                                | MsgRegenerateTc =>
1431                                  doIt (fn () =>
1432                                           if Acl.query {user = user, class = "priv", value = "regen"}
1433                                              orelse Acl.query {user = user, class = "priv", value = "all"} then
1434                                               (if regenerateTc context then
1435                                                    ("Checked all configuration.",
1436                                                     NONE)
1437                                                else
1438                                                    ("Found a compilation error!",
1439                                                     SOME "Found a compilation error!  Consult /var/log/domtool.log."))
1440                                           else
1441                                               ("Unauthorized user asked to regenerate -tc!",
1442                                                SOME "Not authorized to regenerate -tc"))
1443                                       (fn () => ())
1444
1445                                | MsgRmuser user' =>
1446                                  doIt (fn () =>
1447                                           if Acl.query {user = user, class = "priv", value = "all"} then
1448                                               (rmuser user';
1449                                                Acl.write Config.aclFile;
1450                                                ("Removed user " ^ user' ^ ".",
1451                                                 NONE))
1452                                           else
1453                                               ("Unauthorized user asked to remove a user!",
1454                                                SOME "Not authorized to remove users"))
1455                                       (fn () => ())
1456
1457                                | MsgListMailboxes domain =>
1458                                  doIt (fn () =>
1459                                           if not (Domain.yourDomain domain) then
1460                                               ("User wasn't authorized to list mailboxes for " ^ domain,
1461                                                SOME "You're not authorized to configure that domain.")
1462                                           else
1463                                               case Vmail.list domain of
1464                                                   Vmail.Listing users => (Msg.send (bio, MsgMailboxes users);
1465                                                                           ("Sent mailbox list for " ^ domain,
1466                                                                            NONE))
1467                                                 | Vmail.Error msg => ("Error listing mailboxes for " ^ domain ^ ": " ^ msg,
1468                                                                       SOME msg))
1469                                       (fn () => ())
1470
1471                                | MsgNewMailbox {domain, user = emailUser, passwd, mailbox} =>
1472                                  doIt (fn () =>
1473                                           if not (Domain.yourDomain domain) then
1474                                               ("User wasn't authorized to add a mailbox to " ^ domain,
1475                                                SOME "You're not authorized to configure that domain.")
1476                                           else if not (Domain.validEmailUser emailUser) then
1477                                               ("Invalid e-mail username " ^ emailUser,
1478                                                SOME "Invalid e-mail username")
1479                                           else if not (CharVector.all Char.isGraph passwd) then
1480                                               ("Invalid password",
1481                                                SOME "Invalid password; may only contain printable, non-space characters")
1482                                           else if not (Domain.yourPath mailbox) then
1483                                               ("User wasn't authorized to add a mailbox at " ^ mailbox,
1484                                                SOME ("You're not authorized to use that mailbox location. ("
1485                                                      ^ mailbox ^ ")"))
1486                                           else
1487                                               case Vmail.add {requester = user,
1488                                                               domain = domain, user = emailUser,
1489                                                               passwd = passwd, mailbox = mailbox} of
1490                                                   NONE => ("Added mailbox " ^ emailUser ^ "@" ^ domain ^ " at " ^ mailbox,
1491                                                            NONE)
1492                                                 | SOME msg => ("Error adding mailbox " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
1493                                                                SOME msg))
1494                                       (fn () => ())
1495
1496                                | MsgPasswdMailbox {domain, user = emailUser, passwd} =>
1497                                  doIt (fn () =>
1498                                           if not (Domain.yourDomain domain) then
1499                                               ("User wasn't authorized to change password of a mailbox for " ^ domain,
1500                                                SOME "You're not authorized to configure that domain.")
1501                                           else if not (Domain.validEmailUser emailUser) then
1502                                               ("Invalid e-mail username " ^ emailUser,
1503                                                SOME "Invalid e-mail username")
1504                                           else if not (CharVector.all Char.isGraph passwd) then
1505                                               ("Invalid password",
1506                                                SOME "Invalid password; may only contain printable, non-space characters")
1507                                           else
1508                                               case Vmail.passwd {domain = domain, user = emailUser,
1509                                                                  passwd = passwd} of
1510                                                   NONE => ("Changed password of mailbox " ^ emailUser ^ "@" ^ domain,
1511                                                            NONE)
1512                                                 | SOME msg => ("Error changing mailbox password for " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
1513                                                                SOME msg))
1514                                       (fn () => ())
1515
1516                                | MsgRmMailbox {domain, user = emailUser} =>
1517                                  doIt (fn () =>
1518                                           if not (Domain.yourDomain domain) then
1519                                               ("User wasn't authorized to change password of a mailbox for " ^ domain,
1520                                                SOME "You're not authorized to configure that domain.")
1521                                           else if not (Domain.validEmailUser emailUser) then
1522                                               ("Invalid e-mail username " ^ emailUser,
1523                                                SOME "Invalid e-mail username")
1524                                           else
1525                                               case Vmail.rm {domain = domain, user = emailUser} of
1526                                                   NONE => ("Deleted mailbox " ^ emailUser ^ "@" ^ domain,
1527                                                            NONE)
1528                                                 | SOME msg => ("Error deleting mailbox " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
1529                                                                SOME msg))
1530                                       (fn () => ())
1531
1532                                | MsgSaQuery addr =>
1533                                  doIt (fn () =>
1534                                           case checkAddr addr of
1535                                               NONE => ("User tried to query SA filtering for " ^ addr,
1536                                                        SOME "You aren't allowed to configure SA filtering for that recipient.")
1537                                             | SOME addr' => (Msg.send (bio, MsgSaStatus (SetSA.query addr'));
1538                                                              ("Queried SA filtering status for " ^ addr,
1539                                                               NONE)))
1540                                       (fn () => ())
1541
1542                                | MsgSaSet (addr, b) =>
1543                                  doIt (fn () =>
1544                                           case checkAddr addr of
1545                                               NONE => ("User tried to set SA filtering for " ^ addr,
1546                                                        SOME "You aren't allowed to configure SA filtering for that recipient.")
1547                                             | SOME addr' => (SetSA.set (addr', b);
1548                                                              Msg.send (bio, MsgOk);
1549                                                              ("Set SA filtering status for " ^ addr ^ " to "
1550                                                               ^ (if b then "ON" else "OFF"),
1551                                                               NONE)))
1552                                       (fn () => ())
1553
1554                                | MsgSmtpLogReq domain =>
1555                                  doIt (fn () =>
1556                                           if not (Domain.yourDomain domain) then
1557                                               ("Unauthorized user tried to request SMTP logs for " ^ domain,
1558                                                SOME "You aren't authorized to configure that domain.")
1559                                           else
1560                                               (SmtpLog.search (fn line => Msg.send (bio, MsgSmtpLogRes line))
1561                                                               domain;
1562                                                ("Requested SMTP logs for " ^ domain,
1563                                                 NONE)))
1564                                       (fn () => ())
1565
1566                                | MsgQuery q =>
1567                                  doIt (fn () => (Msg.send (bio, answerQuery q);
1568                                                  (describeQuery q,
1569                                                   NONE)))
1570                                       (fn () => ())
1571                                | MsgDescribe dom =>
1572                                  doIt (fn () => if not (Domain.validDomain dom) then
1573                                                     ("Requested description of invalid domain " ^ dom,
1574                                                      SOME "Invalid domain name")
1575                                                 else if not (Domain.yourDomain dom
1576                                                              orelse Acl.query {user = user, class = "priv", value = "all"}) then
1577                                                     ("Requested description of " ^ dom ^ ", but not allowed access",
1578                                                      SOME "Access denied")
1579                                                 else
1580                                                     (Msg.send (bio, MsgDescription (Domain.describe dom));
1581                                                      ("Sent description of domain " ^ dom,
1582                                                       NONE)))
1583                                       (fn () => ())
1584
1585                                | MsgReUsers =>
1586                                  doIt (fn () => if Acl.query {user = user, class = "priv", value = "regen"}
1587                                                    orelse Acl.query {user = user, class = "priv", value = "all"} then
1588                                                     (usersChanged ();
1589                                                      ("Users change callbacks run", NONE))
1590                                                 else
1591                                                     ("Unauthorized user asked to reusers!",
1592                                                      SOME "You aren't authorized to regenerate files."))
1593                                       (fn () => ())
1594
1595                                | _ =>
1596                                  doIt (fn () => ("Unexpected command",
1597                                                  SOME "Unexpected command"))
1598                                       (fn () => ())
1599                  in
1600                      cmdLoop ()
1601                  end
1602                  handle e as (OpenSSL.OpenSSL s) =>
1603                         (print ("OpenSSL error: " ^ s ^ "\n");
1604                          app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);
1605                          OpenSSL.close bio
1606                          handle OpenSSL.OpenSSL _ => ();
1607                          loop ())
1608                       | OS.SysErr (s, _) =>
1609                         (print ("System error: " ^ s ^ "\n");
1610                          OpenSSL.close bio
1611                          handle OpenSSL.OpenSSL _ => ();
1612                          loop ())
1613                       | IO.Io {name, function, cause} =>
1614                         (print ("IO error: " ^ function ^ " for " ^ name ^ "\n");
1615                          app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory cause);
1616                          OpenSSL.close bio
1617                          handle OpenSSL.OpenSSL _ => ();
1618                          loop ())
1619                       | OS.Path.InvalidArc =>
1620                         (print "Invalid arc\n";
1621                          OpenSSL.close bio
1622                          handle OpenSSL.OpenSSL _ => ();
1623                          loop ())
1624                       | e =>
1625                         (print "Unknown exception in main loop!\n";
1626                          app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);
1627                          OpenSSL.close bio
1628                          handle OpenSSL.OpenSSL _ => ();
1629                          loop ()))
1630             handle e as (OpenSSL.OpenSSL s) =>
1631                    (print ("OpenSSL error: " ^ s ^ "\n");
1632                     app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);
1633                     loop ())
1634                  | OS.SysErr (s, _) =>
1635                    (print ("System error: " ^ s ^ "\n");
1636                     loop ())
1637                  | IO.Io {name, function, cause} =>
1638                    (print ("IO error: " ^ function ^ " for " ^ name ^ "\n");
1639                     app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory cause);
1640                     loop ())
1641                  | e =>
1642                    (print "Unknown exception in main loop!\n";
1643                     app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);
1644                     loop ())
1645     in
1646         print ("Domtool dispatcher starting up at " ^ now () ^ "\n");
1647         print "Listening for connections....\n";
1648         loop ();
1649         OpenSSL.shutdown sock
1650     end
1651
1652 fun slave () =
1653     let
1654         val host = Slave.hostname ()
1655
1656         val context = context (Config.certDir ^ "/" ^ host ^ ".pem",
1657                                Config.keyDir ^ "/" ^ host ^ "/key.pem",
1658                                Config.trustStore)
1659
1660         val sock = OpenSSL.listen (context, Config.slavePort)
1661
1662         val _ = print ("Slave server starting at " ^ now () ^ "\n")
1663
1664         fun loop () =
1665             (case OpenSSL.accept sock of
1666                  NONE => ()
1667                | SOME bio =>
1668                  let
1669                      val peer = OpenSSL.peerCN bio
1670                      val () = print ("\nConnection from " ^ peer ^ " at " ^ now () ^ "\n")
1671                  in
1672                      if peer = Config.dispatcherName then let
1673                              fun loop' files =
1674                                  case Msg.recv bio of
1675                                      NONE => print "Dispatcher closed connection unexpectedly\n"
1676                                    | SOME m =>
1677                                      case m of
1678                                          MsgFile file => loop' (file :: files)
1679                                        | MsgDoFiles => (Slave.handleChanges files;
1680                                                         Msg.send (bio, MsgOk))
1681                                        | MsgRegenerate => (Domain.resetLocal ();
1682                                                            Msg.send (bio, MsgOk))
1683                                        | MsgVmailChanged => (if Vmail.doChanged () then
1684                                                                  Msg.send (bio, MsgOk)
1685                                                              else
1686                                                                  Msg.send (bio, MsgError "userdb update failed"))
1687                                        | _ => (print "Dispatcher sent unexpected command\n";
1688                                                Msg.send (bio, MsgError "Unexpected command"))
1689                          in
1690                              loop' [];
1691                              ignore (OpenSSL.readChar bio);
1692                              OpenSSL.close bio;
1693                              loop ()
1694                          end
1695                      else if peer = "domtool" then
1696                          case Msg.recv bio of
1697                              SOME MsgShutdown => (OpenSSL.close bio;
1698                                                   print ("Shutting down at " ^ now () ^ "\n\n"))
1699                            | _ => (OpenSSL.close bio;
1700                                    loop ())
1701                      else
1702                          let
1703                              val doIt = doIt' loop bio
1704                              val user = peer
1705                          in
1706                              case Msg.recv bio of
1707                                  NONE => (OpenSSL.close bio
1708                                           handle OpenSSL.OpenSSL _ => ();
1709                                           loop ())
1710                                | SOME m =>
1711                                  case m of
1712                                      (MsgQuery q) => (print (describeQuery q ^ "\n");
1713                                                       Msg.send (bio, answerQuery q);
1714                                                       ignore (OpenSSL.readChar bio);
1715                                                       OpenSSL.close bio;
1716                                                       loop ())
1717                                    | MsgCreateDbUser {dbtype, passwd} =>
1718                                      doIt (fn () =>
1719                                               case Dbms.lookup dbtype of
1720                                                   NONE => ("Database user creation request with unknown datatype type " ^ dbtype,
1721                                                            SOME ("Unknown database type " ^ dbtype))
1722                                                 | SOME handler =>
1723                                                   case #adduser handler {user = user, passwd = passwd} of
1724                                                       NONE => ("Added " ^ dbtype ^ " user " ^ user ^ ".",
1725                                                                NONE)
1726                                                     | SOME msg =>
1727                                                       ("Error adding a " ^ dbtype ^ " user " ^ user ^ ": " ^ msg,
1728                                                        SOME ("Error adding user: " ^ msg)))
1729                                           (fn () => ())
1730
1731                                    | MsgDbPasswd {dbtype, passwd} =>
1732                                      doIt (fn () =>
1733                                               case Dbms.lookup dbtype of
1734                                                   NONE => ("Database passwd request with unknown datatype type " ^ dbtype,
1735                                                            SOME ("Unknown database type " ^ dbtype))
1736                                                 | SOME handler =>
1737                                                   case #passwd handler {user = user, passwd = passwd} of
1738                                                       NONE => ("Changed " ^ dbtype ^ " password of user " ^ user ^ ".",
1739                                                                NONE)
1740                                                     | SOME msg =>
1741                                                       ("Error setting " ^ dbtype ^ " password of user " ^ user ^ ": " ^ msg,
1742                                                        SOME ("Error adding user: " ^ msg)))
1743                                           (fn () => ())
1744
1745                                    | MsgCreateDb {dbtype, dbname, encoding} =>
1746                                      doIt (fn () =>
1747                                               if Dbms.validDbname dbname then
1748                                                   case Dbms.lookup dbtype of
1749                                                       NONE => ("Database creation request with unknown datatype type " ^ dbtype,
1750                                                                SOME ("Unknown database type " ^ dbtype))
1751                                                     | SOME handler =>
1752                                                       if not (Dbms.validEncoding encoding) then
1753                                                           ("Invalid encoding " ^ valOf encoding ^ " requested for database creation.",
1754                                                            SOME "Invalid encoding")
1755                                                       else
1756                                                           case #createdb handler {user = user, dbname = dbname, encoding = encoding} of
1757                                                               NONE => ("Created database " ^ user ^ "_" ^ dbname ^ ".",
1758                                                                        NONE)
1759                                                             | SOME msg => ("Error creating database " ^ user ^ "_" ^ dbname ^ ": " ^ msg,
1760                                                                            SOME ("Error creating database: " ^ msg))
1761                                               else
1762                                                   ("Invalid database name " ^ user ^ "_" ^ dbname,
1763                                                    SOME ("Invalid database name " ^ dbname)))
1764                                           (fn () => ())
1765
1766                                    | MsgDropDb {dbtype, dbname} =>
1767                                      doIt (fn () =>
1768                                               if Dbms.validDbname dbname then
1769                                                   case Dbms.lookup dbtype of
1770                                                       NONE => ("Database drop request with unknown datatype type " ^ dbtype,
1771                                                                SOME ("Unknown database type " ^ dbtype))
1772                                                     | SOME handler =>
1773                                                       case #dropdb handler {user = user, dbname = dbname} of
1774                                                           NONE => ("Drop database " ^ user ^ "_" ^ dbname ^ ".",
1775                                                                    NONE)
1776                                                         | SOME msg => ("Error dropping database " ^ user ^ "_" ^ dbname ^ ": " ^ msg,
1777                                                                        SOME ("Error dropping database: " ^ msg))
1778                                               else
1779                                                   ("Invalid database name " ^ user ^ "_" ^ dbname,
1780                                                    SOME ("Invalid database name " ^ dbname)))
1781                                           (fn () => ())
1782
1783                                    | MsgGrantDb {dbtype, dbname} =>
1784                                      doIt (fn () =>
1785                                               if Dbms.validDbname dbname then
1786                                                   case Dbms.lookup dbtype of
1787                                                       NONE => ("Database drop request with unknown datatype type " ^ dbtype,
1788                                                                SOME ("Unknown database type " ^ dbtype))
1789                                                     | SOME handler =>
1790                                                       case #grant handler {user = user, dbname = dbname} of
1791                                                           NONE => ("Grant permissions to database " ^ user ^ "_" ^ dbname ^ ".",
1792                                                                    NONE)
1793                                                         | SOME msg => ("Error granting permissions to database " ^ user ^ "_" ^ dbname ^ ": " ^ msg,
1794                                                                        SOME ("Error granting permissions to database: " ^ msg))
1795                                               else
1796                                                   ("Invalid database name " ^ user ^ "_" ^ dbname,
1797                                                    SOME ("Invalid database name " ^ dbname)))
1798                                           (fn () => ())
1799                                    | MsgMysqlFixperms =>
1800                                      (print "Starting mysql-fixperms\n";
1801                                       doIt (fn () => if OS.Process.isSuccess
1802                                                             (OS.Process.system "/usr/bin/sudo -H /afs/hcoop.net/common/etc/scripts/mysql-grant-table-drop") then
1803                                                          ("Requested mysql-fixperms",
1804                                                           NONE)
1805                                                      else
1806                                                          ("Requested mysql-fixperms, but execution failed!",
1807                                                           SOME "Script execution failed."))
1808                                            (fn () => ()))
1809                                    | MsgFirewallRegen =>
1810                                      doIt (fn () => (Acl.read Config.aclFile;
1811                                                      if Acl.query {user = user, class = "priv", value = "all"} then
1812                                                          if List.exists (fn x => x = host) Config.Firewall.firewallNodes then
1813                                                              if (Firewall.generateFirewallConfig (Firewall.parseRules ()) andalso Firewall.publishConfig ())
1814                                                              then
1815                                                                  ("Firewall rules regenerated.", NONE)
1816                                                              else
1817                                                                 ("Rules regeneration failed!", SOME "Script execution failed.")
1818                                                         else ("Node not controlled by domtool firewall.", SOME (host))
1819                                                      else
1820                                                          ("Not authorized to regenerate firewall.", SOME ("Unauthorized user " ^ user ^ " attempted to regenerated firewall"))))
1821                                           (fn () => ())
1822
1823                                    | _ => (OpenSSL.close bio;
1824                                            loop ())
1825                          end
1826                  end handle OpenSSL.OpenSSL s =>
1827                             (print ("OpenSSL error: " ^ s ^ "\n");
1828                              OpenSSL.close bio
1829                              handle OpenSSL.OpenSSL _ => ();
1830                              loop ())
1831                           | e as OS.SysErr (s, _) =>
1832                             (app (fn s => print (s ^ "\n")) (SMLofNJ.exnHistory e);
1833                              print ("System error: "^ s ^ "\n");
1834                              OpenSSL.close bio
1835                              handle OpenSSL.OpenSSL _ => ();
1836                              loop ())
1837                           | IO.Io {function, name, ...} =>
1838                             (print ("IO error: " ^ function ^ ": " ^ name ^ "\n");
1839                              OpenSSL.close bio
1840                              handle OpenSSL.OpenSSL _ => ();
1841                              loop ())
1842                           | e =>
1843                             (app (fn s => print (s ^ "\n")) (SMLofNJ.exnHistory e);
1844                              print "Uncaught exception!\n";
1845                              OpenSSL.close bio
1846                              handle OpenSSL.OpenSSL _ => ();
1847                              loop ()))
1848             handle OpenSSL.OpenSSL s =>
1849                    (print ("OpenSSL error: " ^ s ^ "\n");
1850                     loop ())
1851                  | e =>
1852                    (app (fn s => print (s ^ "\n")) (SMLofNJ.exnHistory e);
1853                     print "Uncaught exception!\n";
1854                     loop ())
1855     in
1856         loop ();
1857         OpenSSL.shutdown sock
1858     end
1859
1860 fun listBasis () =
1861     let
1862         val dir = Posix.FileSys.opendir Config.libRoot
1863
1864         fun loop files =
1865             case Posix.FileSys.readdir dir of
1866                 NONE => (Posix.FileSys.closedir dir;
1867                          files)
1868               | SOME fname =>
1869                 if String.isSuffix ".dtl" fname then
1870                     loop (OS.Path.joinDirFile {dir = Config.libRoot,
1871                                                file = fname}
1872                           :: files)
1873                 else
1874                     loop files
1875     in
1876         loop []
1877     end
1878
1879 fun autodocBasis outdir =
1880     Autodoc.autodoc {outdir = outdir, infiles = listBasis ()}
1881
1882 end