src/main.sml

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