src/main.sml

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