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