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