src/main.sml

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