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 requestPing () =
 279     let
 280         val (_, bio) = requestBio (fn () => ())
 281     in
 282         OpenSSL.close bio;
 283         OS.Process.success
 284     end
 285     handle _ => OS.Process.failure
 286
 287 fun requestShutdown () =
 288     let
 289         val (_, bio) = requestBio (fn () => ())
 290     in
 291         Msg.send (bio, MsgShutdown);
 292         case Msg.recv bio of
 293             NONE => print "Server closed connection unexpectedly.\n"
 294           | SOME m =>
 295             case m of
 296                 MsgOk => print "Shutdown begun.\n"
 297               | MsgError s => print ("Shutdown failed: " ^ s ^ "\n")
 298               | _ => print "Unexpected server reply.\n";
 299         OpenSSL.close bio
 300     end
 301
 302 fun requestGrant acl =
 303     let
 304         val (user, bio) = requestBio (fn () => ())
 305     in
 306         Msg.send (bio, MsgGrant acl);
 307         case Msg.recv bio of
 308             NONE => print "Server closed connection unexpectedly.\n"
 309           | SOME m =>
 310             case m of
 311                 MsgOk => print "Grant succeeded.\n"
 312               | MsgError s => print ("Grant failed: " ^ s ^ "\n")
 313               | _ => print "Unexpected server reply.\n";
 314         OpenSSL.close bio
 315     end
 316
 317 fun requestRevoke acl =
 318     let
 319         val (user, bio) = requestBio (fn () => ())
 320     in
 321         Msg.send (bio, MsgRevoke acl);
 322         case Msg.recv bio of
 323             NONE => print "Server closed connection unexpectedly.\n"
 324           | SOME m =>
 325             case m of
 326                 MsgOk => print "Revoke succeeded.\n"
 327               | MsgError s => print ("Revoke failed: " ^ s ^ "\n")
 328               | _ => print "Unexpected server reply.\n";
 329         OpenSSL.close bio
 330     end
 331
 332 fun requestListPerms user =
 333     let
 334         val (_, bio) = requestBio (fn () => ())
 335     in
 336         Msg.send (bio, MsgListPerms user);
 337         (case Msg.recv bio of
 338              NONE => (print "Server closed connection unexpectedly.\n";
 339                       NONE)
 340            | SOME m =>
 341              case m of
 342                  MsgPerms perms => SOME perms
 343                | MsgError s => (print ("Listing failed: " ^ s ^ "\n");
 344                                 NONE)
 345                | _ => (print "Unexpected server reply.\n";
 346                        NONE))
 347         before OpenSSL.close bio
 348     end
 349
 350 fun requestWhoHas perm =
 351     let
 352         val (_, bio) = requestBio (fn () => ())
 353     in
 354         Msg.send (bio, MsgWhoHas perm);
 355         (case Msg.recv bio of
 356              NONE => (print "Server closed connection unexpectedly.\n";
 357                       NONE)
 358            | SOME m =>
 359              case m of
 360                  MsgWhoHasResponse users => SOME users
 361                | MsgError s => (print ("whohas failed: " ^ s ^ "\n");
 362                                 NONE)
 363                | _ => (print "Unexpected server reply.\n";
 364                        NONE))
 365         before OpenSSL.close bio
 366     end
 367
 368 fun requestRegen () =
 369     let
 370         val (_, bio) = requestBio (fn () => ())
 371     in
 372         Msg.send (bio, MsgRegenerate);
 373         case Msg.recv bio of
 374             NONE => print "Server closed connection unexpectedly.\n"
 375           | SOME m =>
 376             case m of
 377                 MsgOk => print "Regeneration succeeded.\n"
 378               | MsgError s => print ("Regeneration failed: " ^ s ^ "\n")
 379               | _ => print "Unexpected server reply.\n";
 380         OpenSSL.close bio
 381     end
 382
 383 fun requestRmdom dom =
 384     let
 385         val (_, bio) = requestBio (fn () => ())
 386     in
 387         Msg.send (bio, MsgRmdom dom);
 388         case Msg.recv bio of
 389             NONE => print "Server closed connection unexpectedly.\n"
 390           | SOME m =>
 391             case m of
 392                 MsgOk => print "Removal succeeded.\n"
 393               | MsgError s => print ("Removal failed: " ^ s ^ "\n")
 394               | _ => print "Unexpected server reply.\n";
 395         OpenSSL.close bio
 396     end
 397
 398 fun requestRmuser user =
 399     let
 400         val (_, bio) = requestBio (fn () => ())
 401     in
 402         Msg.send (bio, MsgRmuser user);
 403         case Msg.recv bio of
 404             NONE => print "Server closed connection unexpectedly.\n"
 405           | SOME m =>
 406             case m of
 407                 MsgOk => print "Removal succeeded.\n"
 408               | MsgError s => print ("Removal failed: " ^ s ^ "\n")
 409               | _ => print "Unexpected server reply.\n";
 410         OpenSSL.close bio
 411     end
 412
 413 fun requestDbUser dbtype =
 414     let
 415         val (_, bio) = requestBio (fn () => ())
 416     in
 417         Msg.send (bio, MsgCreateDbUser dbtype);
 418         case Msg.recv bio of
 419             NONE => print "Server closed connection unexpectedly.\n"
 420           | SOME m =>
 421             case m of
 422                 MsgOk => print "Your user has been created.\n"
 423               | MsgError s => print ("Creation failed: " ^ s ^ "\n")
 424               | _ => print "Unexpected server reply.\n";
 425         OpenSSL.close bio
 426     end
 427
 428 fun requestDbPasswd rc =
 429     let
 430         val (_, bio) = requestBio (fn () => ())
 431     in
 432         Msg.send (bio, MsgDbPasswd rc);
 433         case Msg.recv bio of
 434             NONE => print "Server closed connection unexpectedly.\n"
 435           | SOME m =>
 436             case m of
 437                 MsgOk => print "Your password has been changed.\n"
 438               | MsgError s => print ("Password set failed: " ^ s ^ "\n")
 439               | _ => print "Unexpected server reply.\n";
 440         OpenSSL.close bio
 441     end
 442
 443 fun requestDbTable p =
 444     let
 445         val (user, bio) = requestBio (fn () => ())
 446     in
 447         Msg.send (bio, MsgCreateDbTable p);
 448         case Msg.recv bio of
 449             NONE => print "Server closed connection unexpectedly.\n"
 450           | SOME m =>
 451             case m of
 452                 MsgOk => print ("Your database " ^ user ^ "_" ^ #dbname p ^ " has been created.\n")
 453               | MsgError s => print ("Creation failed: " ^ s ^ "\n")
 454               | _ => print "Unexpected server reply.\n";
 455         OpenSSL.close bio
 456     end
 457
 458 fun requestListMailboxes domain =
 459     let
 460         val (_, bio) = requestBio (fn () => ())
 461     in
 462         Msg.send (bio, MsgListMailboxes domain);
 463         (case Msg.recv bio of
 464              NONE => Vmail.Error "Server closed connection unexpectedly."
 465            | SOME m =>
 466              case m of
 467                  MsgMailboxes users => (Msg.send (bio, MsgOk);
 468                                         Vmail.Listing users)
 469                | MsgError s => Vmail.Error ("Creation failed: " ^ s)
 470                | _ => Vmail.Error "Unexpected server reply.")
 471         before OpenSSL.close bio
 472     end
 473
 474 fun requestNewMailbox p =
 475     let
 476         val (_, bio) = requestBio (fn () => ())
 477     in
 478         Msg.send (bio, MsgNewMailbox p);
 479         case Msg.recv bio of
 480             NONE => print "Server closed connection unexpectedly.\n"
 481           | SOME m =>
 482             case m of
 483                 MsgOk => print ("A mapping for " ^ #user p ^ "@" ^ #domain p ^ " has been created.\n")
 484               | MsgError s => print ("Creation failed: " ^ s ^ "\n")
 485               | _ => print "Unexpected server reply.\n";
 486         OpenSSL.close bio
 487     end
 488
 489 fun requestPasswdMailbox p =
 490     let
 491         val (_, bio) = requestBio (fn () => ())
 492     in
 493         Msg.send (bio, MsgPasswdMailbox p);
 494         case Msg.recv bio of
 495             NONE => print "Server closed connection unexpectedly.\n"
 496           | SOME m =>
 497             case m of
 498                 MsgOk => print ("The password for " ^ #user p ^ "@" ^ #domain p ^ " has been changed.\n")
 499               | MsgError s => print ("Set failed: " ^ s ^ "\n")
 500               | _ => print "Unexpected server reply.\n";
 501         OpenSSL.close bio
 502     end
 503
 504 fun requestRmMailbox p =
 505     let
 506         val (_, bio) = requestBio (fn () => ())
 507     in
 508         Msg.send (bio, MsgRmMailbox p);
 509         case Msg.recv bio of
 510             NONE => print "Server closed connection unexpectedly.\n"
 511           | SOME m =>
 512             case m of
 513                 MsgOk => print ("The mapping for mailbox " ^ #user p ^ "@" ^ #domain p ^ " has been deleted.\n")
 514               | MsgError s => print ("Remove failed: " ^ s ^ "\n")
 515               | _ => print "Unexpected server reply.\n";
 516         OpenSSL.close bio
 517     end
 518
 519 fun requestSaQuery addr =
 520     let
 521         val (_, bio) = requestBio (fn () => ())
 522     in
 523         Msg.send (bio, MsgSaQuery addr);
 524         (case Msg.recv bio of
 525              NONE => print "Server closed connection unexpectedly.\n"
 526            | SOME m =>
 527              case m of
 528                  MsgSaStatus b => (print ("SpamAssassin filtering for " ^ addr ^ " is "
 529                                           ^ (if b then "ON" else "OFF") ^ ".\n");
 530                                    Msg.send (bio, MsgOk))
 531                | MsgError s => print ("Query failed: " ^ s ^ "\n")
 532                | _ => print "Unexpected server reply.\n")
 533         before OpenSSL.close bio
 534     end
 535
 536 fun requestSaSet p =
 537     let
 538         val (_, bio) = requestBio (fn () => ())
 539     in
 540         Msg.send (bio, MsgSaSet p);
 541         case Msg.recv bio of
 542             NONE => print "Server closed connection unexpectedly.\n"
 543           | SOME m =>
 544             case m of
 545                 MsgOk => print ("SpamAssassin filtering for " ^ #1 p ^ " is now "
 546                                 ^ (if #2 p then "ON" else "OFF") ^ ".\n")
 547               | MsgError s => print ("Set failed: " ^ s ^ "\n")
 548               | _ => print "Unexpected server reply.\n";
 549         OpenSSL.close bio
 550     end
 551
 552 fun requestSmtpLog domain =
 553     let
 554         val (_, bio) = requestBio (fn () => ())
 555
 556         val _ = Msg.send (bio, MsgSmtpLogReq domain)
 557
 558         fun loop () =
 559             case Msg.recv bio of
 560                 NONE => print "Server closed connection unexpectedly.\n"
 561               | SOME m =>
 562                 case m of
 563                     MsgOk => ()
 564                   | MsgSmtpLogRes line => (print line;
 565                                            loop ())
 566                   | MsgError s => print ("Log search failed: " ^ s ^ "\n")
 567                   | _ => print "Unexpected server reply.\n"
 568     in
 569         loop ();
 570         OpenSSL.close bio
 571     end
 572
 573 fun regenerate context =
 574     let
 575         val b = basis ()
 576         val () = Tycheck.disallowExterns ()
 577
 578         val () = Domain.resetGlobal ()
 579
 580         fun contactNode (node, ip) =
 581             if node = Config.defaultNode then
 582                 Domain.resetLocal ()
 583             else let
 584                     val bio = OpenSSL.connect (context,
 585                                                ip
 586                                                ^ ":"
 587                                                ^ Int.toString Config.slavePort)
 588                 in
 589                     Msg.send (bio, MsgRegenerate);
 590                     case Msg.recv bio of
 591                         NONE => print "Slave closed connection unexpectedly\n"
 592                       | SOME m =>
 593                         case m of
 594                             MsgOk => print ("Slave " ^ node ^ " pre-regeneration finished\n")
 595                           | MsgError s => print ("Slave " ^ node
 596                                                  ^ " returned error: " ^
 597                                                  s ^ "\n")
 598                           | _ => print ("Slave " ^ node
 599                                         ^ " returned unexpected command\n");
 600                     OpenSSL.close bio
 601                 end
 602
 603         fun doUser user =
 604             let
 605                 val _ = Domain.setUser user
 606                 val _ = ErrorMsg.reset ()
 607
 608                 val dname = Config.domtoolDir user
 609
 610                 val dir = Posix.FileSys.opendir dname
 611
 612                 fun loop files =
 613                     case Posix.FileSys.readdir dir of
 614                         NONE => (Posix.FileSys.closedir dir;
 615                                  files)
 616                       | SOME fname =>
 617                         if notTmp fname then
 618                             loop (OS.Path.joinDirFile {dir = dname,
 619                                                        file = fname}
 620                                   :: files)
 621                         else
 622                             loop files
 623
 624                 val files = loop []
 625                 val (_, files) = Order.order (SOME b) files
 626             in
 627                 if !ErrorMsg.anyErrors then
 628                     print ("User " ^ user ^ "'s configuration has errors!\n")
 629                 else
 630                     app eval' files
 631             end
 632                 handle IO.Io _ => ()
 633                      | OS.SysErr (s, _) => print ("System error processing user " ^ user ^ ": " ^ s ^ "\n")
 634     in
 635         app contactNode Config.nodeIps;
 636         Env.pre ();
 637         app doUser (Acl.users ());
 638         Env.post ()
 639     end
 640
 641 fun rmuser user =
 642     let
 643         val doms = Acl.class {user = user, class = "domain"}
 644         val doms = List.filter (fn dom =>
 645                                    case Acl.whoHas {class = "domain", value = dom} of
 646                                        [_] => true
 647                                      | _ => false) (StringSet.listItems doms)
 648     in
 649         Acl.rmuser user;
 650         Domain.rmdom doms
 651     end
 652
 653 fun service () =
 654     let
 655         val () = Acl.read Config.aclFile
 656
 657         val context = OpenSSL.context (Config.serverCert,
 658                                        Config.serverKey,
 659                                        Config.trustStore)
 660         val _ = Domain.set_context context
 661
 662         val sock = OpenSSL.listen (context, Config.dispatcherPort)
 663
 664         fun loop () =
 665             case OpenSSL.accept sock of
 666                 NONE => ()
 667               | SOME bio =>
 668                 let
 669                     val user = OpenSSL.peerCN bio
 670                     val () = print ("\nConnection from " ^ user ^ " at " ^ Date.toString (Date.fromTimeUniv (Time.now ())) ^ "\n")
 671                     val () = Domain.setUser user
 672
 673                     fun doIt f cleanup =
 674                         ((case f () of
 675                              (msgLocal, SOME msgRemote) =>
 676                              (print msgLocal;
 677                               print "\n";
 678                               Msg.send (bio, MsgError msgRemote))
 679                            | (msgLocal, NONE) =>
 680                              (print msgLocal;
 681                               print "\n";
 682                               Msg.send (bio, MsgOk)))
 683                          handle OpenSSL.OpenSSL _ =>
 684                                 print "OpenSSL error\n"
 685                               | OS.SysErr (s, _) =>
 686                                 (print "System error: ";
 687                                  print s;
 688                                  print "\n";
 689                                  Msg.send (bio, MsgError ("System error: " ^ s))
 690                                  handle OpenSSL.OpenSSL _ => ())
 691                               | Fail s =>
 692                                 (print "Failure: ";
 693                                  print s;
 694                                  print "\n";
 695                                  Msg.send (bio, MsgError ("Failure: " ^ s))
 696                                  handle OpenSSL.OpenSSL _ => ())
 697                               | ErrorMsg.Error =>
 698                                 (print "Compilation error\n";
 699                                  Msg.send (bio, MsgError "Error during configuration evaluation")
 700                                  handle OpenSSL.OpenSSL _ => ());
 701                          (cleanup ();
 702                           ignore (OpenSSL.readChar bio);
 703                           OpenSSL.close bio)
 704                          handle OpenSSL.OpenSSL _ => ();
 705                          loop ())
 706
 707                     fun doConfig codes =
 708                         let
 709                             val _ = print "Configuration:\n"
 710                             val _ = app (fn s => (print s; print "\n")) codes
 711                             val _ = print "\n"
 712
 713                             val outname = OS.FileSys.tmpName ()
 714
 715                             fun doOne code =
 716                                 let
 717                                     val outf = TextIO.openOut outname
 718                                 in
 719                                     TextIO.output (outf, code);
 720                                     TextIO.closeOut outf;
 721                                     eval' outname
 722                                 end
 723                         in
 724                             doIt (fn () => (Env.pre ();
 725                                             app doOne codes;
 726                                             Env.post ();
 727                                             Msg.send (bio, MsgOk);
 728                                             ("Configuration complete.", NONE)))
 729                                  (fn () => OS.FileSys.remove outname)
 730                         end
 731
 732                     fun checkAddr s =
 733                         case String.fields (fn ch => ch = #"@") s of
 734                             [user'] =>
 735                             if user = user' then
 736                                 SOME (SetSA.User s)
 737                             else
 738                                 NONE
 739                           | [user', domain] =>
 740                             if Domain.validEmailUser user' andalso Domain.yourDomain domain then
 741                                 SOME (SetSA.Email s)
 742                             else
 743                                 NONE
 744                           | _ => NONE
 745
 746                     fun cmdLoop () =
 747                         case Msg.recv bio of
 748                             NONE => (OpenSSL.close bio
 749                                      handle OpenSSL.OpenSSL _ => ();
 750                                      loop ())
 751                           | SOME m =>
 752                             case m of
 753                                 MsgConfig code => doConfig [code]
 754                               | MsgMultiConfig codes => doConfig codes
 755
 756                               | MsgShutdown =>
 757                                 if Acl.query {user = user, class = "priv", value = "all"}
 758                                    orelse Acl.query {user = user, class = "priv", value = "shutdown"} then
 759                                     print ("Domtool dispatcher shutting down at " ^ Date.toString (Date.fromTimeUniv (Time.now ())) ^ "\n\n")
 760                                 else
 761                                     (print "Unauthorized shutdown command!\n";
 762                                      OpenSSL.close bio
 763                                      handle OpenSSL.OpenSSL _ => ();
 764                                      loop ())
 765
 766                               | MsgGrant acl =>
 767                                 doIt (fn () =>
 768                                          if Acl.query {user = user, class = "priv", value = "all"} then
 769                                              (Acl.grant acl;
 770                                               Acl.write Config.aclFile;
 771                                               ("Granted permission " ^ #value acl ^ " to " ^ #user acl ^ " in " ^ #class acl ^ ".",
 772                                                NONE))
 773                                          else
 774                                              ("Unauthorized user asked to grant a permission!",
 775                                               SOME "Not authorized to grant privileges"))
 776                                      (fn () => ())
 777
 778                               | MsgRevoke acl =>
 779                                 doIt (fn () =>
 780                                          if Acl.query {user = user, class = "priv", value = "all"} then
 781                                              (Acl.revoke acl;
 782                                               Acl.write Config.aclFile;
 783                                               ("Revoked permission " ^ #value acl ^ " from " ^ #user acl ^ " in " ^ #class acl ^ ".",
 784                                                NONE))
 785                                          else
 786                                              ("Unauthorized user asked to revoke a permission!",
 787                                               SOME "Not authorized to revoke privileges"))
 788                                      (fn () => ())
 789
 790                               | MsgListPerms user =>
 791                                 doIt (fn () =>
 792                                          (Msg.send (bio, MsgPerms (Acl.queryAll user));
 793                                           ("Sent permission list for user " ^ user ^ ".",
 794                                            NONE)))
 795                                      (fn () => ())
 796
 797                               | MsgWhoHas perm =>
 798                                 doIt (fn () =>
 799                                          (Msg.send (bio, MsgWhoHasResponse (Acl.whoHas perm));
 800                                           ("Sent whohas response for " ^ #class perm ^ " / " ^ #value perm ^ ".",
 801                                            NONE)))
 802                                      (fn () => ())
 803
 804                               | MsgRmdom doms =>
 805                                 doIt (fn () =>
 806                                          if Acl.query {user = user, class = "priv", value = "all"}
 807                                             orelse List.all (fn dom => Acl.query {user = user, class = "domain", value = dom}) doms then
 808                                              (Domain.rmdom doms;
 809                                               app (fn dom =>
 810                                                       Acl.revokeFromAll {class = "domain", value = dom}) doms;
 811                                               Acl.write Config.aclFile;
 812                                               ("Removed domains" ^ foldl (fn (d, s) => s ^ " " ^ d) "" doms ^ ".",
 813                                                NONE))
 814                                          else
 815                                              ("Unauthorized user asked to remove a domain!",
 816                                               SOME "Not authorized to remove that domain"))
 817                                      (fn () => ())
 818
 819                               | MsgRegenerate =>
 820                                 doIt (fn () =>
 821                                          if Acl.query {user = user, class = "priv", value = "regen"}
 822                                             orelse Acl.query {user = user, class = "priv", value = "all"} then
 823                                              (regenerate context;
 824                                               ("Regenerated all configuration.",
 825                                                NONE))
 826                                          else
 827                                              ("Unauthorized user asked to regenerate!",
 828                                               SOME "Not authorized to regenerate"))
 829                                      (fn () => ())
 830
 831                               | MsgRmuser user' =>
 832                                 doIt (fn () =>
 833                                          if Acl.query {user = user, class = "priv", value = "all"} then
 834                                              (rmuser user';
 835                                               Acl.write Config.aclFile;
 836                                               ("Removed user " ^ user' ^ ".",
 837                                                NONE))
 838                                          else
 839                                              ("Unauthorized user asked to remove a user!",
 840                                               SOME "Not authorized to remove users"))
 841                                      (fn () => ())
 842
 843                               | MsgCreateDbUser {dbtype, passwd} =>
 844                                 doIt (fn () =>
 845                                          case Dbms.lookup dbtype of
 846                                              NONE => ("Database user creation request with unknown datatype type " ^ dbtype,
 847                                                       SOME ("Unknown database type " ^ dbtype))
 848                                            | SOME handler =>
 849                                              case #adduser handler {user = user, passwd = passwd} of
 850                                                  NONE => ("Added " ^ dbtype ^ " user " ^ user ^ ".",
 851                                                           NONE)
 852                                                | SOME msg =>
 853                                                  ("Error adding a " ^ dbtype ^ " user " ^ user ^ ": " ^ msg,
 854                                                   SOME ("Error adding user: " ^ msg)))
 855                                      (fn () => ())
 856
 857                               | MsgDbPasswd {dbtype, passwd} =>
 858                                 doIt (fn () =>
 859                                          case Dbms.lookup dbtype of
 860                                              NONE => ("Database passwd request with unknown datatype type " ^ dbtype,
 861                                                       SOME ("Unknown database type " ^ dbtype))
 862                                            | SOME handler =>
 863                                              case #passwd handler {user = user, passwd = passwd} of
 864                                                  NONE => ("Changed " ^ dbtype ^ " password of user " ^ user ^ ".",
 865                                                           NONE)
 866                                                | SOME msg =>
 867                                                  ("Error setting " ^ dbtype ^ " password of user " ^ user ^ ": " ^ msg,
 868                                                   SOME ("Error adding user: " ^ msg)))
 869                                      (fn () => ())
 870
 871                               | MsgCreateDbTable {dbtype, dbname} =>
 872                                 doIt (fn () =>
 873                                          if Dbms.validDbname dbname then
 874                                              case Dbms.lookup dbtype of
 875                                                  NONE => ("Database creation request with unknown datatype type " ^ dbtype,
 876                                                           SOME ("Unknown database type " ^ dbtype))
 877                                                | SOME handler =>
 878                                                  case #createdb handler {user = user, dbname = dbname} of
 879                                                      NONE => ("Created database " ^ user ^ "_" ^ dbname ^ ".",
 880                                                               NONE)
 881                                                    | SOME msg => ("Error creating database " ^ user ^ "_" ^ dbname ^ ": " ^ msg,
 882                                                                   SOME ("Error creating database: " ^ msg))
 883                                          else
 884                                              ("Invalid database name " ^ user ^ "_" ^ dbname,
 885                                               SOME ("Invalid database name " ^ dbname)))
 886                                      (fn () => ())
 887
 888                               | MsgListMailboxes domain =>
 889                                 doIt (fn () =>
 890                                          if not (Domain.yourDomain domain) then
 891                                              ("User wasn't authorized to list mailboxes for " ^ domain,
 892                                               SOME "You're not authorized to configure that domain.")
 893                                          else
 894                                              case Vmail.list domain of
 895                                                  Vmail.Listing users => (Msg.send (bio, MsgMailboxes users);
 896                                                                          ("Sent mailbox list for " ^ domain,
 897                                                                           NONE))
 898                                                | Vmail.Error msg => ("Error listing mailboxes for " ^ domain ^ ": " ^ msg,
 899                                                                      SOME msg))
 900                                      (fn () => ())
 901
 902                               | MsgNewMailbox {domain, user = emailUser, passwd, mailbox} =>
 903                                 doIt (fn () =>
 904                                          if not (Domain.yourDomain domain) then
 905                                              ("User wasn't authorized to add a mailbox to " ^ domain,
 906                                               SOME "You're not authorized to configure that domain.")
 907                                          else if not (Domain.validEmailUser emailUser) then
 908                                              ("Invalid e-mail username " ^ emailUser,
 909                                               SOME "Invalid e-mail username")
 910                                          else if not (CharVector.all Char.isGraph passwd) then
 911                                              ("Invalid password",
 912                                               SOME "Invalid password; may only contain printable, non-space characters")
 913                                          else if not (Domain.yourPath mailbox) then
 914                                              ("User wasn't authorized to add a mailbox at " ^ mailbox,
 915                                               SOME "You're not authorized to use that mailbox location.")
 916                                          else
 917                                              case Vmail.add {requester = user,
 918                                                              domain = domain, user = emailUser,
 919                                                              passwd = passwd, mailbox = mailbox} of
 920                                                  NONE => ("Added mailbox " ^ emailUser ^ "@" ^ domain ^ " at " ^ mailbox,
 921                                                           NONE)
 922                                                | SOME msg => ("Error adding mailbox " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
 923                                                               SOME msg))
 924                                      (fn () => ())
 925
 926                               | MsgPasswdMailbox {domain, user = emailUser, passwd} =>
 927                                 doIt (fn () =>
 928                                          if not (Domain.yourDomain domain) then
 929                                              ("User wasn't authorized to change password of a mailbox for " ^ domain,
 930                                               SOME "You're not authorized to configure that domain.")
 931                                          else if not (Domain.validEmailUser emailUser) then
 932                                              ("Invalid e-mail username " ^ emailUser,
 933                                               SOME "Invalid e-mail username")
 934                                          else if not (CharVector.all Char.isGraph passwd) then
 935                                              ("Invalid password",
 936                                               SOME "Invalid password; may only contain printable, non-space characters")
 937                                          else
 938                                              case Vmail.passwd {domain = domain, user = emailUser,
 939                                                                 passwd = passwd} of
 940                                                  NONE => ("Changed password of mailbox " ^ emailUser ^ "@" ^ domain,
 941                                                           NONE)
 942                                                | SOME msg => ("Error changing mailbox password for " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
 943                                                               SOME msg))
 944                                      (fn () => ())
 945
 946                               | MsgRmMailbox {domain, user = emailUser} =>
 947                                 doIt (fn () =>
 948                                          if not (Domain.yourDomain domain) then
 949                                              ("User wasn't authorized to change password of a mailbox for " ^ domain,
 950                                               SOME "You're not authorized to configure that domain.")
 951                                          else if not (Domain.validEmailUser emailUser) then
 952                                              ("Invalid e-mail username " ^ emailUser,
 953                                               SOME "Invalid e-mail username")
 954                                          else
 955                                              case Vmail.rm {domain = domain, user = emailUser} of
 956                                                  NONE => ("Deleted mailbox " ^ emailUser ^ "@" ^ domain,
 957                                                           NONE)
 958                                                | SOME msg => ("Error deleting mailbox " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
 959                                                               SOME msg))
 960                                      (fn () => ())
 961
 962                               | MsgSaQuery addr =>
 963                                 doIt (fn () =>
 964                                          case checkAddr addr of
 965                                              NONE => ("User tried to query SA filtering for " ^ addr,
 966                                                       SOME "You aren't allowed to configure SA filtering for that recipient.")
 967                                            | SOME addr' => (Msg.send (bio, MsgSaStatus (SetSA.query addr'));
 968                                                             ("Queried SA filtering status for " ^ addr,
 969                                                              NONE)))
 970                                      (fn () => ())
 971
 972                               | MsgSaSet (addr, b) =>
 973                                 doIt (fn () =>
 974                                          case checkAddr addr of
 975                                              NONE => ("User tried to set SA filtering for " ^ addr,
 976                                                       SOME "You aren't allowed to configure SA filtering for that recipient.")
 977                                            | SOME addr' => (SetSA.set (addr', b);
 978                                                             Msg.send (bio, MsgOk);
 979                                                             ("Set SA filtering status for " ^ addr ^ " to "
 980                                                              ^ (if b then "ON" else "OFF"),
 981                                                              NONE)))
 982                                      (fn () => ())
 983
 984                               | MsgSmtpLogReq domain =>
 985                                 doIt (fn () =>
 986                                          if not (Domain.yourDomain domain) then
 987                                              ("Unauthorized user tried to request SMTP logs for " ^ domain,
 988                                               SOME "You aren't authorized to configure that domain.")
 989                                          else
 990                                              (SmtpLog.search (fn line => Msg.send (bio, MsgSmtpLogRes line))
 991                                               domain;
 992                                               ("Requested SMTP logs for " ^ domain,
 993                                                NONE)))
 994                                 (fn () => ())
 995
 996                               | _ =>
 997                                 doIt (fn () => ("Unexpected command",
 998                                                 SOME "Unexpected command"))
 999                                      (fn () => ())
1000                 in
1001                     cmdLoop ()
1002                 end
1003                     handle OpenSSL.OpenSSL s =>
1004                            (print ("OpenSSL error: " ^ s ^ "\n");
1005                             OpenSSL.close bio
1006                             handle OpenSSL.OpenSSL _ => ();
1007                             loop ())
1008                          | OS.SysErr (s, _) =>
1009                            (print ("System error: " ^ s ^ "\n");
1010                             OpenSSL.close bio
1011                             handle OpenSSL.OpenSSL _ => ();
1012                             loop ())
1013     in
1014         print ("Domtool dispatcher starting up at " ^ Date.toString (Date.fromTimeUniv (Time.now ())) ^ "\n");
1015         print "Listening for connections....\n";
1016         loop ();
1017         OpenSSL.shutdown sock
1018     end
1019
1020 fun slave () =
1021     let
1022         val host = Slave.hostname ()
1023
1024         val context = OpenSSL.context (Config.certDir ^ "/" ^ host ^ ".pem",
1025                                        Config.keyDir ^ "/" ^ host ^ "/key.pem",
1026                                        Config.trustStore)
1027
1028         val sock = OpenSSL.listen (context, Config.slavePort)
1029
1030         fun loop () =
1031             case OpenSSL.accept sock of
1032                 NONE => ()
1033               | SOME bio =>
1034                 let
1035                     val peer = OpenSSL.peerCN bio
1036                     val () = print ("\nConnection from " ^ peer ^ "\n")
1037                 in
1038                     if peer <> Config.dispatcherName then
1039                         (print "Not authorized!\n";
1040                          OpenSSL.close bio;
1041                          loop ())
1042                     else let
1043                             fun loop' files =
1044                                 case Msg.recv bio of
1045                                     NONE => print "Dispatcher closed connection unexpectedly\n"
1046                                   | SOME m =>
1047                                     case m of
1048                                         MsgFile file => loop' (file :: files)
1049                                       | MsgDoFiles => (Slave.handleChanges files;
1050                                                        Msg.send (bio, MsgOk))
1051                                       | MsgRegenerate => (Domain.resetLocal ();
1052                                                           Msg.send (bio, MsgOk))
1053                                       | _ => (print "Dispatcher sent unexpected command\n";
1054                                               Msg.send (bio, MsgError "Unexpected command"))
1055                         in
1056                             loop' [];
1057                             ignore (OpenSSL.readChar bio);
1058                             OpenSSL.close bio;
1059                             loop ()
1060                         end
1061                 end handle OpenSSL.OpenSSL s =>
1062                            (print ("OpenSSL error: "^ s ^ "\n");
1063                             OpenSSL.close bio
1064                                           handle OpenSSL.OpenSSL _ => ();
1065                             loop ())
1066                          | OS.SysErr (s, _) =>
1067                            (print ("System error: "^ s ^ "\n");
1068                             OpenSSL.close bio
1069                             handle OpenSSL.OpenSSL _ => ();
1070                             loop ())
1071     in
1072         loop ();
1073         OpenSSL.shutdown sock
1074     end
1075
1076 fun listBasis () =
1077     let
1078         val dir = Posix.FileSys.opendir Config.libRoot
1079
1080         fun loop files =
1081             case Posix.FileSys.readdir dir of
1082                 NONE => (Posix.FileSys.closedir dir;
1083                          files)
1084               | SOME fname =>
1085                 if String.isSuffix ".dtl" fname then
1086                     loop (OS.Path.joinDirFile {dir = Config.libRoot,
1087                                                file = fname}
1088                           :: files)
1089                 else
1090                     loop files
1091     in
1092         loop []
1093     end
1094
1095 fun autodocBasis outdir =
1096     Autodoc.autodoc {outdir = outdir, infiles = listBasis ()}
1097
1098 end