src/main.sml

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