src/main.sml

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