src/main.sml

   1 (* HCoop Domtool (http://hcoop.sourceforge.net/)
   2  * Copyright (c) 2006, 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 val notTmp = CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"." orelse ch = #"_" orelse ch = #"-")
  96
  97 fun checkDir dname =
  98     let
  99         val b = basis ()
 100
 101         val dir = Posix.FileSys.opendir dname
 102
 103         fun loop files =
 104             case Posix.FileSys.readdir dir of
 105                 NONE => (Posix.FileSys.closedir dir;
 106                          files)
 107               | SOME fname =>
 108                 if notTmp fname then
 109                     loop (OS.Path.joinDirFile {dir = dname,
 110                                                file = fname}
 111                           :: files)
 112                 else
 113                     loop files
 114
 115         val files = loop []
 116         val (_, files) = Order.order (SOME b) files
 117     in
 118         if !ErrorMsg.anyErrors then
 119             raise ErrorMsg.Error
 120         else
 121             (foldl (fn (fname, G) => check' G fname) b files;
 122              if !ErrorMsg.anyErrors then
 123                  raise ErrorMsg.Error
 124              else
 125                  ())
 126     end
 127
 128 fun reduce fname =
 129     let
 130         val (G, body) = check fname
 131     in
 132         if !ErrorMsg.anyErrors then
 133             NONE
 134         else
 135             case body of
 136                 SOME body =>
 137                 let
 138                     val body' = Reduce.reduceExp G body
 139                 in
 140                     (*printd (PD.hovBox (PD.PPS.Rel 0,
 141                                          [PD.string "Result:",
 142                                           PD.space 1,
 143                                           p_exp body']))*)
 144                     SOME body'
 145                 end
 146               | _ => NONE
 147     end
 148
 149 fun eval fname =
 150     case reduce fname of
 151         (SOME body') =>
 152         if !ErrorMsg.anyErrors then
 153             raise ErrorMsg.Error
 154         else
 155             Eval.exec (Defaults.eInit ()) body'
 156       | NONE => raise ErrorMsg.Error
 157
 158 fun eval' fname =
 159     case reduce fname of
 160         (SOME body') =>
 161         if !ErrorMsg.anyErrors then
 162             raise ErrorMsg.Error
 163         else
 164             ignore (Eval.exec' (Defaults.eInit ()) body')
 165       | NONE => raise ErrorMsg.Error
 166
 167 val dispatcher =
 168     Config.dispatcher ^ ":" ^ Int.toString Config.dispatcherPort
 169
 170 fun requestContext f =
 171     let
 172         val uid = Posix.ProcEnv.getuid ()
 173         val user = Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid uid)
 174
 175         val () = Acl.read Config.aclFile
 176         val () = Domain.setUser user
 177
 178         val () = f ()
 179
 180         val context = OpenSSL.context (Config.certDir ^ "/" ^ user ^ ".pem",
 181                                        Config.keyDir ^ "/" ^ user ^ "/key.pem",
 182                                        Config.trustStore)
 183     in
 184         (user, context)
 185     end
 186
 187 fun requestBio f =
 188     let
 189         val (user, context) = requestContext f
 190     in
 191         (user, OpenSSL.connect (context, dispatcher))
 192     end
 193
 194 fun request fname =
 195     let
 196         val (user, bio) = requestBio (fn () => ignore (check fname))
 197
 198         val inf = TextIO.openIn fname
 199
 200         fun loop lines =
 201             case TextIO.inputLine inf of
 202                 NONE => String.concat (List.rev lines)
 203               | SOME line => loop (line :: lines)
 204
 205         val code = loop []
 206     in
 207         TextIO.closeIn inf;
 208         Msg.send (bio, MsgConfig code);
 209         case Msg.recv bio of
 210             NONE => print "Server closed connection unexpectedly.\n"
 211           | SOME m =>
 212             case m of
 213                 MsgOk => print "Configuration succeeded.\n"
 214               | MsgError s => print ("Configuration failed: " ^ s ^ "\n")
 215               | _ => print "Unexpected server reply.\n";
 216         OpenSSL.close bio
 217     end
 218     handle ErrorMsg.Error => ()
 219
 220 fun requestDir dname =
 221     let
 222         val _ = ErrorMsg.reset ()
 223
 224         val (user, bio) = requestBio (fn () => checkDir dname)
 225
 226         val b = basis ()
 227
 228         val dir = Posix.FileSys.opendir dname
 229
 230         fun loop files =
 231             case Posix.FileSys.readdir dir of
 232                 NONE => (Posix.FileSys.closedir dir;
 233                          files)
 234               | SOME fname =>
 235                 if notTmp fname then
 236                     loop (OS.Path.joinDirFile {dir = dname,
 237                                                file = fname}
 238                           :: files)
 239                 else
 240                     loop files
 241
 242         val files = loop []
 243         val (_, files) = Order.order (SOME b) files
 244
 245         val _ = if !ErrorMsg.anyErrors then
 246                     raise ErrorMsg.Error
 247                 else
 248                     ()
 249
 250         val codes = map (fn fname =>
 251                             let
 252                                 val inf = TextIO.openIn fname
 253
 254                                 fun loop lines =
 255                                     case TextIO.inputLine inf of
 256                                         NONE => String.concat (rev lines)
 257                                       | SOME line => loop (line :: lines)
 258                             in
 259                                 loop []
 260                                 before TextIO.closeIn inf
 261                             end) files
 262     in
 263         if !ErrorMsg.anyErrors then
 264             ()
 265         else
 266             (Msg.send (bio, MsgMultiConfig codes);
 267              case Msg.recv bio of
 268                  NONE => print "Server closed connection unexpectedly.\n"
 269                | SOME m =>
 270                  case m of
 271                      MsgOk => print "Configuration succeeded.\n"
 272                    | MsgError s => print ("Configuration failed: " ^ s ^ "\n")
 273                    | _ => print "Unexpected server reply.\n";
 274              OpenSSL.close bio)
 275     end
 276     handle ErrorMsg.Error => ()
 277
 278 fun requestGrant acl =
 279     let
 280         val (user, bio) = requestBio (fn () => ())
 281     in
 282         Msg.send (bio, MsgGrant acl);
 283         case Msg.recv bio of
 284             NONE => print "Server closed connection unexpectedly.\n"
 285           | SOME m =>
 286             case m of
 287                 MsgOk => print "Grant succeeded.\n"
 288               | MsgError s => print ("Grant failed: " ^ s ^ "\n")
 289               | _ => print "Unexpected server reply.\n";
 290         OpenSSL.close bio
 291     end
 292
 293 fun requestRevoke acl =
 294     let
 295         val (user, bio) = requestBio (fn () => ())
 296     in
 297         Msg.send (bio, MsgRevoke acl);
 298         case Msg.recv bio of
 299             NONE => print "Server closed connection unexpectedly.\n"
 300           | SOME m =>
 301             case m of
 302                 MsgOk => print "Revoke succeeded.\n"
 303               | MsgError s => print ("Revoke failed: " ^ s ^ "\n")
 304               | _ => print "Unexpected server reply.\n";
 305         OpenSSL.close bio
 306     end
 307
 308 fun requestListPerms user =
 309     let
 310         val (_, bio) = requestBio (fn () => ())
 311     in
 312         Msg.send (bio, MsgListPerms user);
 313         (case Msg.recv bio of
 314              NONE => (print "Server closed connection unexpectedly.\n";
 315                       NONE)
 316            | SOME m =>
 317              case m of
 318                  MsgPerms perms => SOME perms
 319                | MsgError s => (print ("Listing failed: " ^ s ^ "\n");
 320                                 NONE)
 321                | _ => (print "Unexpected server reply.\n";
 322                        NONE))
 323         before OpenSSL.close bio
 324     end
 325
 326 fun requestWhoHas perm =
 327     let
 328         val (_, bio) = requestBio (fn () => ())
 329     in
 330         Msg.send (bio, MsgWhoHas perm);
 331         (case Msg.recv bio of
 332              NONE => (print "Server closed connection unexpectedly.\n";
 333                       NONE)
 334            | SOME m =>
 335              case m of
 336                  MsgWhoHasResponse users => SOME users
 337                | MsgError s => (print ("whohas failed: " ^ s ^ "\n");
 338                                 NONE)
 339                | _ => (print "Unexpected server reply.\n";
 340                        NONE))
 341         before OpenSSL.close bio
 342     end
 343
 344 fun requestRegen () =
 345     let
 346         val (_, bio) = requestBio (fn () => ())
 347     in
 348         Msg.send (bio, MsgRegenerate);
 349         case Msg.recv bio of
 350             NONE => print "Server closed connection unexpectedly.\n"
 351           | SOME m =>
 352             case m of
 353                 MsgOk => print "Regeneration succeeded.\n"
 354               | MsgError s => print ("Regeneration failed: " ^ s ^ "\n")
 355               | _ => print "Unexpected server reply.\n";
 356         OpenSSL.close bio
 357     end
 358
 359 fun requestRmdom dom =
 360     let
 361         val (_, bio) = requestBio (fn () => ())
 362     in
 363         Msg.send (bio, MsgRmdom dom);
 364         case Msg.recv bio of
 365             NONE => print "Server closed connection unexpectedly.\n"
 366           | SOME m =>
 367             case m of
 368                 MsgOk => print "Removal succeeded.\n"
 369               | MsgError s => print ("Removal failed: " ^ s ^ "\n")
 370               | _ => print "Unexpected server reply.\n";
 371         OpenSSL.close bio
 372     end
 373
 374 fun requestRmuser user =
 375     let
 376         val (_, bio) = requestBio (fn () => ())
 377     in
 378         Msg.send (bio, MsgRmuser user);
 379         case Msg.recv bio of
 380             NONE => print "Server closed connection unexpectedly.\n"
 381           | SOME m =>
 382             case m of
 383                 MsgOk => print "Removal succeeded.\n"
 384               | MsgError s => print ("Removal failed: " ^ s ^ "\n")
 385               | _ => print "Unexpected server reply.\n";
 386         OpenSSL.close bio
 387     end
 388
 389 fun requestDbUser dbtype =
 390     let
 391         val (_, bio) = requestBio (fn () => ())
 392     in
 393         Msg.send (bio, MsgCreateDbUser dbtype);
 394         case Msg.recv bio of
 395             NONE => print "Server closed connection unexpectedly.\n"
 396           | SOME m =>
 397             case m of
 398                 MsgOk => print "Your user has been created.\n"
 399               | MsgError s => print ("Creation failed: " ^ s ^ "\n")
 400               | _ => print "Unexpected server reply.\n";
 401         OpenSSL.close bio
 402     end
 403
 404 fun requestDbTable p =
 405     let
 406         val (user, bio) = requestBio (fn () => ())
 407     in
 408         Msg.send (bio, MsgCreateDbTable p);
 409         case Msg.recv bio of
 410             NONE => print "Server closed connection unexpectedly.\n"
 411           | SOME m =>
 412             case m of
 413                 MsgOk => print ("Your database " ^ user ^ "_" ^ #dbname p ^ " has been created.\n")
 414               | MsgError s => print ("Creation failed: " ^ s ^ "\n")
 415               | _ => print "Unexpected server reply.\n";
 416         OpenSSL.close bio
 417     end
 418
 419 fun requestListMailboxes domain =
 420     let
 421         val (_, bio) = requestBio (fn () => ())
 422     in
 423         Msg.send (bio, MsgListMailboxes domain);
 424         (case Msg.recv bio of
 425              NONE => Vmail.Error "Server closed connection unexpectedly."
 426            | SOME m =>
 427              case m of
 428                  MsgMailboxes users => (Msg.send (bio, MsgOk);
 429                                         Vmail.Listing users)
 430                | MsgError s => Vmail.Error ("Creation failed: " ^ s)
 431                | _ => Vmail.Error "Unexpected server reply.")
 432         before OpenSSL.close bio
 433     end
 434
 435 fun requestNewMailbox p =
 436     let
 437         val (_, bio) = requestBio (fn () => ())
 438     in
 439         Msg.send (bio, MsgNewMailbox p);
 440         case Msg.recv bio of
 441             NONE => print "Server closed connection unexpectedly.\n"
 442           | SOME m =>
 443             case m of
 444                 MsgOk => print ("A mapping for " ^ #user p ^ "@" ^ #domain p ^ " has been created.\n")
 445               | MsgError s => print ("Creation failed: " ^ s ^ "\n")
 446               | _ => print "Unexpected server reply.\n";
 447         OpenSSL.close bio
 448     end
 449
 450 fun requestPasswdMailbox p =
 451     let
 452         val (_, bio) = requestBio (fn () => ())
 453     in
 454         Msg.send (bio, MsgPasswdMailbox p);
 455         case Msg.recv bio of
 456             NONE => print "Server closed connection unexpectedly.\n"
 457           | SOME m =>
 458             case m of
 459                 MsgOk => print ("The password for " ^ #user p ^ "@" ^ #domain p ^ " has been changed.\n")
 460               | MsgError s => print ("Set failed: " ^ s ^ "\n")
 461               | _ => print "Unexpected server reply.\n";
 462         OpenSSL.close bio
 463     end
 464
 465 fun requestRmMailbox p =
 466     let
 467         val (_, bio) = requestBio (fn () => ())
 468     in
 469         Msg.send (bio, MsgRmMailbox p);
 470         case Msg.recv bio of
 471             NONE => print "Server closed connection unexpectedly.\n"
 472           | SOME m =>
 473             case m of
 474                 MsgOk => print ("The mapping for mailbox " ^ #user p ^ "@" ^ #domain p ^ " has been deleted.\n")
 475               | MsgError s => print ("Remove failed: " ^ s ^ "\n")
 476               | _ => print "Unexpected server reply.\n";
 477         OpenSSL.close bio
 478     end
 479
 480 fun requestSaQuery addr =
 481     let
 482         val (_, bio) = requestBio (fn () => ())
 483     in
 484         Msg.send (bio, MsgSaQuery addr);
 485         (case Msg.recv bio of
 486              NONE => print "Server closed connection unexpectedly.\n"
 487            | SOME m =>
 488              case m of
 489                  MsgSaStatus b => (print ("SpamAssassin filtering for " ^ addr ^ " is "
 490                                           ^ (if b then "ON" else "OFF") ^ ".\n");
 491                                    Msg.send (bio, MsgOk))
 492                | MsgError s => print ("Query failed: " ^ s ^ "\n")
 493                | _ => print "Unexpected server reply.\n")
 494         before OpenSSL.close bio
 495     end
 496
 497 fun requestSaSet p =
 498     let
 499         val (_, bio) = requestBio (fn () => ())
 500     in
 501         Msg.send (bio, MsgSaSet p);
 502         case Msg.recv bio of
 503             NONE => print "Server closed connection unexpectedly.\n"
 504           | SOME m =>
 505             case m of
 506                 MsgOk => print ("SpamAssassin filtering for " ^ #1 p ^ " is now "
 507                                 ^ (if #2 p then "ON" else "OFF") ^ ".\n")
 508               | MsgError s => print ("Set failed: " ^ s ^ "\n")
 509               | _ => print "Unexpected server reply.\n";
 510         OpenSSL.close bio
 511     end
 512
 513 fun regenerate context =
 514     let
 515         val b = basis ()
 516         val () = Tycheck.disallowExterns ()
 517
 518         val () = Domain.resetGlobal ()
 519
 520         fun contactNode (node, ip) =
 521             if node = Config.defaultNode then
 522                 Domain.resetLocal ()
 523             else let
 524                     val bio = OpenSSL.connect (context,
 525                                                ip
 526                                                ^ ":"
 527                                                ^ Int.toString Config.slavePort)
 528                 in
 529                     Msg.send (bio, MsgRegenerate);
 530                     case Msg.recv bio of
 531                         NONE => print "Slave closed connection unexpectedly\n"
 532                       | SOME m =>
 533                         case m of
 534                             MsgOk => print ("Slave " ^ node ^ " pre-regeneration finished\n")
 535                           | MsgError s => print ("Slave " ^ node
 536                                                  ^ " returned error: " ^
 537                                                  s ^ "\n")
 538                           | _ => print ("Slave " ^ node
 539                                         ^ " returned unexpected command\n");
 540                     OpenSSL.close bio
 541                 end
 542
 543         fun doUser user =
 544             let
 545                 val _ = Domain.setUser user
 546                 val _ = ErrorMsg.reset ()
 547
 548                 val dname = Config.domtoolDir user
 549
 550                 val dir = Posix.FileSys.opendir dname
 551
 552                 fun loop files =
 553                     case Posix.FileSys.readdir dir of
 554                         NONE => (Posix.FileSys.closedir dir;
 555                                  files)
 556                       | SOME fname =>
 557                         if notTmp fname then
 558                             loop (OS.Path.joinDirFile {dir = dname,
 559                                                        file = fname}
 560                                   :: files)
 561                         else
 562                             loop files
 563
 564                 val files = loop []
 565                 val (_, files) = Order.order (SOME b) files
 566             in
 567                 if !ErrorMsg.anyErrors then
 568                     print ("User " ^ user ^ "'s configuration has errors!\n")
 569                 else
 570                     app eval' files
 571             end
 572                 handle IO.Io _ => ()
 573                      | OS.SysErr (s, _) => print ("System error processing user " ^ user ^ ": " ^ s ^ "\n")
 574     in
 575         app contactNode Config.nodeIps;
 576         Env.pre ();
 577         app doUser (Acl.users ());
 578         Env.post ()
 579     end
 580
 581 fun rmuser user =
 582     let
 583         val doms = Acl.class {user = user, class = "domain"}
 584         val doms = List.filter (fn dom =>
 585                                    case Acl.whoHas {class = "domain", value = dom} of
 586                                        [_] => true
 587                                      | _ => false) (StringSet.listItems doms)
 588     in
 589         Acl.rmuser user;
 590         Domain.rmdom doms
 591     end
 592
 593 fun service () =
 594     let
 595         val () = Acl.read Config.aclFile
 596
 597         val context = OpenSSL.context (Config.serverCert,
 598                                        Config.serverKey,
 599                                        Config.trustStore)
 600         val _ = Domain.set_context context
 601
 602         val sock = OpenSSL.listen (context, Config.dispatcherPort)
 603
 604         fun loop () =
 605             case OpenSSL.accept sock of
 606                 NONE => ()
 607               | SOME bio =>
 608                 let
 609                     val user = OpenSSL.peerCN bio
 610                     val () = print ("\nConnection from " ^ user ^ "\n")
 611                     val () = Domain.setUser user
 612
 613                     fun doIt f cleanup =
 614                         ((case f () of
 615                              (msgLocal, SOME msgRemote) =>
 616                              (print msgLocal;
 617                               print "\n";
 618                               Msg.send (bio, MsgError msgRemote))
 619                            | (msgLocal, NONE) =>
 620                              (print msgLocal;
 621                               print "\n";
 622                               Msg.send (bio, MsgOk)))
 623                          handle OpenSSL.OpenSSL _ =>
 624                                 print "OpenSSL error\n"
 625                               | OS.SysErr (s, _) =>
 626                                 (print "System error: ";
 627                                  print s;
 628                                  print "\n";
 629                                  Msg.send (bio, MsgError ("System error: " ^ s))
 630                                  handle OpenSSL.OpenSSL _ => ())
 631                               | Fail s =>
 632                                 (print "Failure: ";
 633                                  print s;
 634                                  print "\n";
 635                                  Msg.send (bio, MsgError ("Failure: " ^ s))
 636                                  handle OpenSSL.OpenSSL _ => ())
 637                               | ErrorMsg.Error =>
 638                                 (print "Compilation error\n";
 639                                  Msg.send (bio, MsgError "Error during configuration evaluation")
 640                                  handle OpenSSL.OpenSSL _ => ());
 641                          (cleanup ();
 642                           ignore (OpenSSL.readChar bio);
 643                           OpenSSL.close bio)
 644                          handle OpenSSL.OpenSSL _ => ();
 645                          loop ())
 646
 647                     fun doConfig codes =
 648                         let
 649                             val _ = print "Configuration:\n"
 650                             val _ = app (fn s => (print s; print "\n")) codes
 651                             val _ = print "\n"
 652
 653                             val outname = OS.FileSys.tmpName ()
 654
 655                             fun doOne code =
 656                                 let
 657                                     val outf = TextIO.openOut outname
 658                                 in
 659                                     TextIO.output (outf, code);
 660                                     TextIO.closeOut outf;
 661                                     eval' outname
 662                                 end
 663                         in
 664                             doIt (fn () => (Env.pre ();
 665                                             app doOne codes;
 666                                             Env.post ();
 667                                             Msg.send (bio, MsgOk);
 668                                             ("Configuration complete.", NONE)))
 669                                  (fn () => OS.FileSys.remove outname)
 670                         end
 671
 672                     fun checkAddr s =
 673                         case String.fields (fn ch => ch = #"@") s of
 674                             [user'] =>
 675                             if user = user' then
 676                                 SOME (SetSA.User s)
 677                             else
 678                                 NONE
 679                           | [user', domain] =>
 680                             if Domain.validEmailUser user' andalso Domain.yourDomain domain then
 681                                 SOME (SetSA.Email s)
 682                             else
 683                                 NONE
 684                           | _ => NONE
 685
 686                     fun cmdLoop () =
 687                         case Msg.recv bio of
 688                             NONE => (OpenSSL.close bio
 689                                      handle OpenSSL.OpenSSL _ => ();
 690                                      loop ())
 691                           | SOME m =>
 692                             case m of
 693                                 MsgConfig code => doConfig [code]
 694                               | MsgMultiConfig codes => doConfig codes
 695
 696                               | MsgGrant acl =>
 697                                 doIt (fn () =>
 698                                          if Acl.query {user = user, class = "priv", value = "all"} then
 699                                              (Acl.grant acl;
 700                                               Acl.write Config.aclFile;
 701                                               ("Granted permission " ^ #value acl ^ " to " ^ #user acl ^ " in " ^ #class acl ^ ".",
 702                                                NONE))
 703                                          else
 704                                              ("Unauthorized user asked to grant a permission!",
 705                                               SOME "Not authorized to grant privileges"))
 706                                      (fn () => ())
 707
 708                               | MsgRevoke acl =>
 709                                 doIt (fn () =>
 710                                          if Acl.query {user = user, class = "priv", value = "all"} then
 711                                              (Acl.revoke acl;
 712                                               Acl.write Config.aclFile;
 713                                               ("Revoked permission " ^ #value acl ^ " from " ^ #user acl ^ " in " ^ #class acl ^ ".",
 714                                                NONE))
 715                                          else
 716                                              ("Unauthorized user asked to revoke a permission!",
 717                                               SOME "Not authorized to revoke privileges"))
 718                                      (fn () => ())
 719
 720                               | MsgListPerms user =>
 721                                 doIt (fn () =>
 722                                          (Msg.send (bio, MsgPerms (Acl.queryAll user));
 723                                           ("Sent permission list for user " ^ user ^ ".",
 724                                            NONE)))
 725                                      (fn () => ())
 726
 727                               | MsgWhoHas perm =>
 728                                 doIt (fn () =>
 729                                          (Msg.send (bio, MsgWhoHasResponse (Acl.whoHas perm));
 730                                           ("Sent whohas response for " ^ #class perm ^ " / " ^ #value perm ^ ".",
 731                                            NONE)))
 732                                      (fn () => ())
 733
 734                               | MsgRmdom doms =>
 735                                 doIt (fn () =>
 736                                          if Acl.query {user = user, class = "priv", value = "all"}
 737                                             orelse List.all (fn dom => Acl.query {user = user, class = "domain", value = dom}) doms then
 738                                              (Domain.rmdom doms;
 739                                               app (fn dom =>
 740                                                       Acl.revokeFromAll {class = "domain", value = dom}) doms;
 741                                               Acl.write Config.aclFile;
 742                                               ("Removed domains" ^ foldl (fn (d, s) => s ^ " " ^ d) "" doms ^ ".",
 743                                                NONE))
 744                                          else
 745                                              ("Unauthorized user asked to remove a domain!",
 746                                               SOME "Not authorized to remove that domain"))
 747                                      (fn () => ())
 748
 749                               | MsgRegenerate =>
 750                                 doIt (fn () =>
 751                                          if Acl.query {user = user, class = "priv", value = "regen"}
 752                                             orelse Acl.query {user = user, class = "priv", value = "all"} then
 753                                              (regenerate context;
 754                                               ("Regenerated all configuration.",
 755                                                NONE))
 756                                          else
 757                                              ("Unauthorized user asked to regenerate!",
 758                                               SOME "Not authorized to regenerate"))
 759                                      (fn () => ())
 760
 761                               | MsgRmuser user' =>
 762                                 doIt (fn () =>
 763                                          if Acl.query {user = user, class = "priv", value = "all"} then
 764                                              (rmuser user';
 765                                               Acl.write Config.aclFile;
 766                                               ("Removed user " ^ user' ^ ".",
 767                                                NONE))
 768                                          else
 769                                              ("Unauthorized user asked to remove a user!",
 770                                               SOME "Not authorized to remove users"))
 771                                      (fn () => ())
 772
 773                               | MsgCreateDbUser {dbtype, passwd} =>
 774                                 doIt (fn () =>
 775                                          case Dbms.lookup dbtype of
 776                                              NONE => ("Database user creation request with unknown datatype type " ^ dbtype,
 777                                                       SOME ("Unknown database type " ^ dbtype))
 778                                            | SOME handler =>
 779                                              case #adduser handler {user = user, passwd = passwd} of
 780                                                  NONE => ("Added " ^ dbtype ^ " user " ^ user ^ ".",
 781                                                           NONE)
 782                                                | SOME msg =>
 783                                                  ("Error adding a " ^ dbtype ^ " user " ^ user ^ ": " ^ msg,
 784                                                   SOME ("Error adding user: " ^ msg)))
 785                                      (fn () => ())
 786
 787                               | MsgCreateDbTable {dbtype, dbname} =>
 788                                 doIt (fn () =>
 789                                          if Dbms.validDbname dbname then
 790                                              case Dbms.lookup dbtype of
 791                                                  NONE => ("Database creation request with unknown datatype type " ^ dbtype,
 792                                                           SOME ("Unknown database type " ^ dbtype))
 793                                                | SOME handler =>
 794                                                  case #createdb handler {user = user, dbname = dbname} of
 795                                                      NONE => ("Created database " ^ user ^ "_" ^ dbname ^ ".",
 796                                                               NONE)
 797                                                    | SOME msg => ("Error creating database " ^ user ^ "_" ^ dbname ^ ": " ^ msg,
 798                                                                   SOME ("Error creating database: " ^ msg))
 799                                          else
 800                                              ("Invalid database name " ^ user ^ "_" ^ dbname,
 801                                               SOME ("Invalid database name " ^ dbname)))
 802                                      (fn () => ())
 803
 804                               | MsgListMailboxes domain =>
 805                                 doIt (fn () =>
 806                                          if not (Domain.yourDomain domain) then
 807                                              ("User wasn't authorized to list mailboxes for " ^ domain,
 808                                               SOME "You're not authorized to configure that domain.")
 809                                          else
 810                                              case Vmail.list domain of
 811                                                  Vmail.Listing users => (Msg.send (bio, MsgMailboxes users);
 812                                                                          ("Sent mailbox list for " ^ domain,
 813                                                                           NONE))
 814                                                | Vmail.Error msg => ("Error listing mailboxes for " ^ domain ^ ": " ^ msg,
 815                                                                      SOME msg))
 816                                      (fn () => ())
 817
 818                               | MsgNewMailbox {domain, user = emailUser, passwd, mailbox} =>
 819                                 doIt (fn () =>
 820                                          if not (Domain.yourDomain domain) then
 821                                              ("User wasn't authorized to add a mailbox to " ^ domain,
 822                                               SOME "You're not authorized to configure that domain.")
 823                                          else if not (Domain.validEmailUser emailUser) then
 824                                              ("Invalid e-mail username " ^ emailUser,
 825                                               SOME "Invalid e-mail username")
 826                                          else if not (CharVector.all Char.isGraph passwd) then
 827                                              ("Invalid password",
 828                                               SOME "Invalid password; may only contain printable, non-space characters")
 829                                          else if not (Domain.yourPath mailbox) then
 830                                              ("User wasn't authorized to add a mailbox at " ^ mailbox,
 831                                               SOME "You're not authorized to use that mailbox location.")
 832                                          else
 833                                              case Vmail.add {requester = user,
 834                                                              domain = domain, user = emailUser,
 835                                                              passwd = passwd, mailbox = mailbox} of
 836                                                  NONE => ("Added mailbox " ^ emailUser ^ "@" ^ domain ^ " at " ^ mailbox,
 837                                                           NONE)
 838                                                | SOME msg => ("Error adding mailbox " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
 839                                                               SOME msg))
 840                                      (fn () => ())
 841
 842                               | MsgPasswdMailbox {domain, user = emailUser, passwd} =>
 843                                 doIt (fn () =>
 844                                          if not (Domain.yourDomain domain) then
 845                                              ("User wasn't authorized to change password of a mailbox for " ^ domain,
 846                                               SOME "You're not authorized to configure that domain.")
 847                                          else if not (Domain.validEmailUser emailUser) then
 848                                              ("Invalid e-mail username " ^ emailUser,
 849                                               SOME "Invalid e-mail username")
 850                                          else if not (CharVector.all Char.isGraph passwd) then
 851                                              ("Invalid password",
 852                                               SOME "Invalid password; may only contain printable, non-space characters")
 853                                          else
 854                                              case Vmail.passwd {domain = domain, user = emailUser,
 855                                                                 passwd = passwd} of
 856                                                  NONE => ("Changed password of mailbox " ^ emailUser ^ "@" ^ domain,
 857                                                           NONE)
 858                                                | SOME msg => ("Error changing mailbox password for " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
 859                                                               SOME msg))
 860                                      (fn () => ())
 861
 862                               | MsgRmMailbox {domain, user = emailUser} =>
 863                                 doIt (fn () =>
 864                                          if not (Domain.yourDomain domain) then
 865                                              ("User wasn't authorized to change password of a mailbox for " ^ domain,
 866                                               SOME "You're not authorized to configure that domain.")
 867                                          else if not (Domain.validEmailUser emailUser) then
 868                                              ("Invalid e-mail username " ^ emailUser,
 869                                               SOME "Invalid e-mail username")
 870                                          else
 871                                              case Vmail.rm {domain = domain, user = emailUser} of
 872                                                  NONE => ("Deleted mailbox " ^ emailUser ^ "@" ^ domain,
 873                                                           NONE)
 874                                                | SOME msg => ("Error deleting mailbox " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
 875                                                               SOME msg))
 876                                      (fn () => ())
 877
 878                               | MsgSaQuery addr =>
 879                                 doIt (fn () =>
 880                                          case checkAddr addr of
 881                                              NONE => ("User tried to query SA filtering for " ^ addr,
 882                                                       SOME "You aren't allowed to configure SA filtering for that recipient.")
 883                                            | SOME addr' => (Msg.send (bio, MsgSaStatus (SetSA.query addr'));
 884                                                             ("Queried SA filtering status for " ^ addr,
 885                                                              NONE)))
 886                                      (fn () => ())
 887
 888                               | MsgSaSet (addr, b) =>
 889                                 doIt (fn () =>
 890                                          case checkAddr addr of
 891                                              NONE => ("User tried to set SA filtering for " ^ addr,
 892                                                       SOME "You aren't allowed to configure SA filtering for that recipient.")
 893                                            | SOME addr' => (SetSA.set (addr', b);
 894                                                             Msg.send (bio, MsgOk);
 895                                                             ("Set SA filtering status for " ^ addr ^ " to "
 896                                                              ^ (if b then "ON" else "OFF"),
 897                                                              NONE)))
 898                                      (fn () => ())
 899
 900                               | _ =>
 901                                 doIt (fn () => ("Unexpected command",
 902                                                 SOME "Unexpected command"))
 903                                      (fn () => ())
 904                 in
 905                     cmdLoop ()
 906                 end
 907                     handle OpenSSL.OpenSSL s =>
 908                            (print ("OpenSSL error: " ^ s ^ "\n");
 909                             OpenSSL.close bio
 910                             handle OpenSSL.OpenSSL _ => ();
 911                             loop ())
 912                          | OS.SysErr (s, _) =>
 913                            (print ("System error: " ^ s ^ "\n");
 914                             OpenSSL.close bio
 915                             handle OpenSSL.OpenSSL _ => ();
 916                             loop ())
 917     in
 918         print "Listening for connections....\n";
 919         loop ();
 920         OpenSSL.shutdown sock
 921     end
 922
 923 fun slave () =
 924     let
 925         val host = Slave.hostname ()
 926
 927         val context = OpenSSL.context (Config.certDir ^ "/" ^ host ^ ".pem",
 928                                        Config.keyDir ^ "/" ^ host ^ "/key.pem",
 929                                        Config.trustStore)
 930
 931         val sock = OpenSSL.listen (context, Config.slavePort)
 932
 933         fun loop () =
 934             case OpenSSL.accept sock of
 935                 NONE => ()
 936               | SOME bio =>
 937                 let
 938                     val peer = OpenSSL.peerCN bio
 939                     val () = print ("\nConnection from " ^ peer ^ "\n")
 940                 in
 941                     if peer <> Config.dispatcherName then
 942                         (print "Not authorized!\n";
 943                          OpenSSL.close bio;
 944                          loop ())
 945                     else let
 946                             fun loop' files =
 947                                 case Msg.recv bio of
 948                                     NONE => print "Dispatcher closed connection unexpectedly\n"
 949                                   | SOME m =>
 950                                     case m of
 951                                         MsgFile file => loop' (file :: files)
 952                                       | MsgDoFiles => (Slave.handleChanges files;
 953                                                        Msg.send (bio, MsgOk))
 954                                       | MsgRegenerate => (Domain.resetLocal ();
 955                                                           Msg.send (bio, MsgOk))
 956                                       | _ => (print "Dispatcher sent unexpected command\n";
 957                                               Msg.send (bio, MsgError "Unexpected command"))
 958                         in
 959                             loop' [];
 960                             ignore (OpenSSL.readChar bio);
 961                             OpenSSL.close bio;
 962                             loop ()
 963                         end
 964                 end handle OpenSSL.OpenSSL s =>
 965                            (print ("OpenSSL error: "^ s ^ "\n");
 966                             OpenSSL.close bio
 967                                           handle OpenSSL.OpenSSL _ => ();
 968                             loop ())
 969                          | OS.SysErr (s, _) =>
 970                            (print ("System error: "^ s ^ "\n");
 971                             OpenSSL.close bio
 972                             handle OpenSSL.OpenSSL _ => ();
 973                             loop ())
 974     in
 975         loop ();
 976         OpenSSL.shutdown sock
 977     end
 978
 979 fun listBasis () =
 980     let
 981         val dir = Posix.FileSys.opendir Config.libRoot
 982
 983         fun loop files =
 984             case Posix.FileSys.readdir dir of
 985                 NONE => (Posix.FileSys.closedir dir;
 986                          files)
 987               | SOME fname =>
 988                 if String.isSuffix ".dtl" fname then
 989                     loop (OS.Path.joinDirFile {dir = Config.libRoot,
 990                                                file = fname}
 991                           :: files)
 992                 else
 993                     loop files
 994     in
 995         loop []
 996     end
 997
 998 fun autodocBasis outdir =
 999     Autodoc.autodoc {outdir = outdir, infiles = listBasis ()}
1000
1001 end