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 (_, bio) = requestBio (fn () => ())
 739     in
 740         Msg.send (bio, MsgMysqlFixperms);
 741         case Msg.recv bio of
 742             NONE => print "Server closed connection unexpectedly.\n"
 743           | SOME m =>
 744             case m of
 745                 MsgOk => print "Permissions granted.\n"
 746               | MsgError s => print ("Failed: " ^ s ^ "\n")
 747               | _ => print "Unexpected server reply.\n";
 748         OpenSSL.close bio
 749     end
 750
 751 fun requestApt {node, pkg} =
 752     let
 753         val (user, context) = requestContext (fn () => ())
 754         val bio = OpenSSL.connect true (context, if node = Config.masterNode then
 755                                                      dispatcher
 756                                                  else
 757                                                      Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
 758
 759         val _ = Msg.send (bio, MsgQuery (QApt pkg))
 760
 761         fun loop () =
 762             case Msg.recv bio of
 763                 NONE => (print "Server closed connection unexpectedly.\n";
 764                          OS.Process.failure)
 765               | SOME m =>
 766                 case m of
 767                     MsgYes => (print "Package is installed.\n";
 768                                OS.Process.success)
 769                   | MsgNo => (print "Package is not installed.\n";
 770                               OS.Process.failure)
 771                   | MsgError s => (print ("APT query failed: " ^ s ^ "\n");
 772                                    OS.Process.failure)
 773                   | _ => (print "Unexpected server reply.\n";
 774                           OS.Process.failure)
 775     in
 776         loop ()
 777         before OpenSSL.close bio
 778     end
 779
 780 fun requestCron {node, uname} =
 781     let
 782         val (user, context) = requestContext (fn () => ())
 783         val bio = OpenSSL.connect true (context, if node = Config.masterNode then
 784                                                      dispatcher
 785                                                  else
 786                                                      Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
 787
 788         val _ = Msg.send (bio, MsgQuery (QCron uname))
 789
 790         fun loop () =
 791             case Msg.recv bio of
 792                 NONE => (print "Server closed connection unexpectedly.\n";
 793                          OS.Process.failure)
 794               | SOME m =>
 795                 case m of
 796                     MsgYes => (print "User has cron permissions.\n";
 797                                OS.Process.success)
 798                   | MsgNo => (print "User does not have cron permissions.\n";
 799                               OS.Process.failure)
 800                   | MsgError s => (print ("Cron query failed: " ^ s ^ "\n");
 801                                    OS.Process.failure)
 802                   | _ => (print "Unexpected server reply.\n";
 803                           OS.Process.failure)
 804     in
 805         loop ()
 806         before OpenSSL.close bio
 807     end
 808
 809 fun requestFtp {node, uname} =
 810     let
 811         val (user, context) = requestContext (fn () => ())
 812         val bio = OpenSSL.connect true (context, if node = Config.masterNode then
 813                                                      dispatcher
 814                                                  else
 815                                                      Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
 816
 817         val _ = Msg.send (bio, MsgQuery (QFtp uname))
 818
 819         fun loop () =
 820             case Msg.recv bio of
 821                 NONE => (print "Server closed connection unexpectedly.\n";
 822                          OS.Process.failure)
 823               | SOME m =>
 824                 case m of
 825                     MsgYes => (print "User has FTP permissions.\n";
 826                                OS.Process.success)
 827                   | MsgNo => (print "User does not have FTP permissions.\n";
 828                               OS.Process.failure)
 829                   | MsgError s => (print ("FTP query failed: " ^ s ^ "\n");
 830                                    OS.Process.failure)
 831                   | _ => (print "Unexpected server reply.\n";
 832                           OS.Process.failure)
 833     in
 834         loop ()
 835         before OpenSSL.close bio
 836     end
 837
 838 fun requestTrustedPath {node, uname} =
 839     let
 840         val (user, context) = requestContext (fn () => ())
 841         val bio = OpenSSL.connect true (context, if node = Config.masterNode then
 842                                                      dispatcher
 843                                                  else
 844                                                      Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
 845
 846         val _ = Msg.send (bio, MsgQuery (QTrustedPath uname))
 847
 848         fun loop () =
 849             case Msg.recv bio of
 850                 NONE => (print "Server closed connection unexpectedly.\n";
 851                          OS.Process.failure)
 852               | SOME m =>
 853                 case m of
 854                     MsgYes => (print "User has trusted path restriction.\n";
 855                                OS.Process.success)
 856                   | MsgNo => (print "User does not have trusted path restriction.\n";
 857                               OS.Process.failure)
 858                   | MsgError s => (print ("Trusted path query failed: " ^ s ^ "\n");
 859                                    OS.Process.failure)
 860                   | _ => (print "Unexpected server reply.\n";
 861                           OS.Process.failure)
 862     in
 863         loop ()
 864         before OpenSSL.close bio
 865     end
 866
 867 fun requestSocketPerm {node, uname} =
 868     let
 869         val (user, context) = requestContext (fn () => ())
 870         val bio = OpenSSL.connect true (context, if node = Config.masterNode then
 871                                                      dispatcher
 872                                                  else
 873                                                      Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
 874
 875         val _ = Msg.send (bio, MsgQuery (QSocket uname))
 876
 877         fun loop () =
 878             case Msg.recv bio of
 879                 NONE => (print "Server closed connection unexpectedly.\n";
 880                          OS.Process.failure)
 881               | SOME m =>
 882                 case m of
 883                     MsgSocket p => (case p of
 884                                         Any => print "Any\n"
 885                                       | Client => print "Client\n"
 886                                       | Server => print "Server\n"
 887                                       | Nada => print "Nada\n";
 888                                     OS.Process.success)
 889                   | MsgError s => (print ("Socket permission query failed: " ^ s ^ "\n");
 890                                    OS.Process.failure)
 891                   | _ => (print "Unexpected server reply.\n";
 892                           OS.Process.failure)
 893     in
 894         loop ()
 895         before OpenSSL.close bio
 896     end
 897
 898 fun requestFirewall {node, uname} =
 899     let
 900         val (user, context) = requestContext (fn () => ())
 901         val bio = OpenSSL.connect true (context, if node = Config.masterNode then
 902                                                      dispatcher
 903                                                  else
 904                                                      Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
 905
 906         val _ = Msg.send (bio, MsgQuery (QFirewall uname))
 907
 908         fun loop () =
 909             case Msg.recv bio of
 910                 NONE => (print "Server closed connection unexpectedly.\n";
 911                          OS.Process.failure)
 912               | SOME m =>
 913                 case m of
 914                     MsgFirewall ls => (app (fn s => (print s; print "\n")) ls;
 915                                        OS.Process.success)
 916                   | MsgError s => (print ("Firewall query failed: " ^ s ^ "\n");
 917                                    OS.Process.failure)
 918                   | _ => (print "Unexpected server reply.\n";
 919                           OS.Process.failure)
 920     in
 921         loop ()
 922         before OpenSSL.close bio
 923     end
 924
 925 fun requestDescribe dom =
 926     let
 927         val (_, bio) = requestBio (fn () => ())
 928     in
 929         Msg.send (bio, MsgDescribe dom);
 930         case Msg.recv bio of
 931             NONE => print "Server closed connection unexpectedly.\n"
 932           | SOME m =>
 933             case m of
 934                 MsgDescription s => print s
 935               | MsgError s => print ("Description failed: " ^ s ^ "\n")
 936               | _ => print "Unexpected server reply.\n";
 937         OpenSSL.close bio
 938     end
 939
 940 fun requestReUsers () =
 941     let
 942         val (_, bio) = requestBio (fn () => ())
 943     in
 944         Msg.send (bio, MsgReUsers);
 945         case Msg.recv bio of
 946             NONE => print "Server closed connection unexpectedly.\n"
 947           | SOME m =>
 948             case m of
 949                 MsgOk => print "Callbacks run.\n"
 950               | MsgError s => print ("Failed: " ^ s ^ "\n")
 951               | _ => print "Unexpected server reply.\n";
 952         OpenSSL.close bio
 953     end
 954
 955 structure SS = StringSet
 956
 957 fun domainList dname =
 958     let
 959         val dir = Posix.FileSys.opendir dname
 960
 961         fun visitNode dset =
 962             case Posix.FileSys.readdir dir of
 963                 NONE => dset
 964               | SOME node =>
 965                 let
 966                     val path = OS.Path.joinDirFile {dir = dname,
 967                                                     file = node}
 968
 969                     fun visitDomains (path, bfor, dset) =
 970                         let
 971                             val dir = Posix.FileSys.opendir path
 972
 973                             fun loop dset =
 974                                 case Posix.FileSys.readdir dir of
 975                                     NONE => dset
 976                                   | SOME dname =>
 977                                     let
 978                                         val path = OS.Path.joinDirFile {dir = path,
 979                                                                         file = dname}
 980                                     in
 981                                         if Posix.FileSys.ST.isDir (Posix.FileSys.stat path) then
 982                                             let
 983                                                 val bfor = dname :: bfor
 984                                             in
 985                                                 loop (visitDomains (path, bfor,
 986                                                                     SS.add (dset,
 987                                                                             String.concatWith "." bfor)))
 988                                             end
 989                                         else
 990                                             loop dset
 991                                     end
 992                         in
 993                             loop dset
 994                             before Posix.FileSys.closedir dir
 995                         end
 996                 in
 997                     visitNode (visitDomains (path, [], dset))
 998                 end
 999     in
1000         visitNode SS.empty
1001         before Posix.FileSys.closedir dir
1002     end
1003
1004 fun regenerateEither tc checker context =
1005     let
1006         val () = print "Starting regeneration....\n"
1007
1008         val domainsBefore =
1009             if tc then
1010                 SS.empty
1011             else
1012                 domainList Config.resultRoot
1013
1014         fun ifReal f =
1015             if tc then
1016                 ()
1017             else
1018                 f ()
1019
1020         val _ = ErrorMsg.reset ()
1021
1022         val b = basis ()
1023         val () = Tycheck.disallowExterns ()
1024
1025         val () = ifReal (fn () =>
1026                             (ignore (OS.Process.system ("rm -rf " ^ Config.oldResultRoot ^ "/*"));
1027                              ignore (OS.Process.system ("cp -r " ^ Config.resultRoot
1028                                                         ^ "/* " ^ Config.oldResultRoot ^ "/"));
1029                              Domain.resetGlobal ()))
1030
1031         val ok = ref true
1032
1033         fun contactNode (node, ip) =
1034             if node = Config.defaultNode then
1035                 Domain.resetLocal ()
1036             else let
1037                     val bio = OpenSSL.connect true (context,
1038                                                     ip
1039                                                     ^ ":"
1040                                                     ^ Int.toString Config.slavePort)
1041                 in
1042                     Msg.send (bio, MsgRegenerate);
1043                     case Msg.recv bio of
1044                         NONE => print "Slave closed connection unexpectedly\n"
1045                       | SOME m =>
1046                         case m of
1047                             MsgOk => print ("Slave " ^ node ^ " pre-regeneration finished\n")
1048                           | MsgError s => print ("Slave " ^ node
1049                                                  ^ " returned error: " ^
1050                                                  s ^ "\n")
1051                           | _ => print ("Slave " ^ node
1052                                         ^ " returned unexpected command\n");
1053                     OpenSSL.close bio
1054                 end
1055                  handle OpenSSL.OpenSSL s => print ("OpenSSL error: " ^ s ^ "\n")
1056
1057         fun doUser user =
1058             let
1059                 val _ = Domain.setUser user
1060                 val _ = ErrorMsg.reset ()
1061
1062                 val dname = Config.domtoolDir user
1063             in
1064                 if Posix.FileSys.access (dname, []) then
1065                     let
1066                         val dir = Posix.FileSys.opendir dname
1067
1068                         fun loop files =
1069                             case Posix.FileSys.readdir dir of
1070                                 NONE => (Posix.FileSys.closedir dir;
1071                                          files)
1072                               | SOME fname =>
1073                                 if notTmp fname then
1074                                     loop (OS.Path.joinDirFile {dir = dname,
1075                                                                file = fname}
1076                                           :: files)
1077                                 else
1078                                     loop files
1079
1080                         val files = loop []
1081                         val (_, files) = Order.order (SOME b) files
1082
1083                         fun checker' (file, (G, evs)) =
1084                             checker G evs file
1085                     in
1086                         if !ErrorMsg.anyErrors then
1087                             (ErrorMsg.reset ();
1088                              print ("User " ^ user ^ "'s configuration has errors!\n");
1089                              ok := false)
1090                         else
1091                             ();
1092                         ignore (foldl checker' (basis (), Defaults.eInit ()) files)
1093                     end
1094                 else if String.isSuffix "_admin" user then
1095                     ()
1096                 else
1097                     (print ("Couldn't access " ^ user ^ "'s ~/.domtool directory.\n");
1098                      ok := false)
1099             end
1100             handle IO.Io {name, function, ...} =>
1101                    (print ("IO error processing user " ^ user ^ ": " ^ function ^ ": " ^ name ^ "\n");
1102                     ok := false)
1103                  | exn as OS.SysErr (s, _) => (print ("System error processing user " ^ user ^ ": " ^ s ^ "\n");
1104                                                ok := false)
1105                  | ErrorMsg.Error => (ErrorMsg.reset ();
1106                                       print ("User " ^ user ^ " had a compilation error.\n");
1107                                       ok := false)
1108                  | _ => (print "Unknown exception during regeneration!\n";
1109                          ok := false)
1110     in
1111         ifReal (fn () => (app contactNode Config.nodeIps;
1112                           Env.pre ()));
1113         app doUser (Acl.users ());
1114         ifReal (fn () =>
1115                    let
1116                        val domainsAfter = domainList Config.resultRoot
1117                        val domainsGone = SS.difference (domainsBefore, domainsAfter)
1118                    in
1119                        if SS.isEmpty domainsGone then
1120                            ()
1121                        else
1122                            (print "Domains to kill:";
1123                             SS.app (fn s => (print " "; print s)) domainsGone;
1124                             print "\n";
1125
1126                             Domain.rmdom' Config.oldResultRoot (SS.listItems domainsGone));
1127
1128                        Env.post ()
1129                    end);
1130         !ok
1131     end
1132
1133 val regenerate = regenerateEither false eval
1134 val regenerateTc = regenerateEither true
1135                                     (fn G => fn evs => fn file =>
1136                                                           (#1 (check G file), evs))
1137
1138 fun usersChanged () =
1139     (Domain.onUsersChange ();
1140      ignore (OS.Process.system Config.publish_reusers))
1141
1142 fun rmuser user =
1143     let
1144         val doms = Acl.class {user = user, class = "domain"}
1145         val doms = List.filter (fn dom =>
1146                                    case Acl.whoHas {class = "domain", value = dom} of
1147                                        [_] => true
1148                                      | _ => false) (StringSet.listItems doms)
1149     in
1150         Acl.rmuser user;
1151         Domain.rmdom doms;
1152         usersChanged ()
1153     end
1154
1155 fun now () = Date.toString (Date.fromTimeUniv (Time.now ()))
1156
1157 fun answerQuery q =
1158     case q of
1159         QApt pkg => if Apt.installed pkg then MsgYes else MsgNo
1160       | QCron user => if Cron.allowed user then MsgYes else MsgNo
1161       | QFtp user => if Ftp.allowed user then MsgYes else MsgNo
1162       | QTrustedPath user => if TrustedPath.query user then MsgYes else MsgNo
1163       | QSocket user => MsgSocket (SocketPerm.query user)
1164       | QFirewall user => MsgFirewall (Firewall.query user)
1165
1166 fun describeQuery q =
1167     case q of
1168         QApt pkg => "Requested installation status of package " ^ pkg
1169       | QCron user => "Asked about cron permissions for user " ^ user
1170       | QFtp user => "Asked about FTP permissions for user " ^ user
1171       | QTrustedPath user => "Asked about trusted path settings for user " ^ user
1172       | QSocket user => "Asked about socket permissions for user " ^ user
1173       | QFirewall user => "Asked about firewall rules for user " ^ user
1174
1175 fun doIt' loop bio f cleanup =
1176                ((case f () of
1177                      (msgLocal, SOME msgRemote) =>
1178                      (print msgLocal;
1179                       print "\n";
1180                       Msg.send (bio, MsgError msgRemote))
1181                    | (msgLocal, NONE) =>
1182                      (print msgLocal;
1183                       print "\n";
1184                       Msg.send (bio, MsgOk)))
1185                 handle e as (OpenSSL.OpenSSL s) =>
1186                        (print ("OpenSSL error: " ^ s ^ "\n");
1187                         app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);
1188                         Msg.send (bio, MsgError ("OpenSSL error: " ^ s))
1189                         handle OpenSSL.OpenSSL _ => ())
1190                      | OS.SysErr (s, _) =>
1191                        (print "System error: ";
1192                         print s;
1193                         print "\n";
1194                         Msg.send (bio, MsgError ("System error: " ^ s))
1195                         handle OpenSSL.OpenSSL _ => ())
1196                      | Fail s =>
1197                        (print "Failure: ";
1198                         print s;
1199                         print "\n";
1200                         Msg.send (bio, MsgError ("Failure: " ^ s))
1201                         handle OpenSSL.OpenSSL _ => ())
1202                      | ErrorMsg.Error =>
1203                        (print "Compilation error\n";
1204                         Msg.send (bio, MsgError "Error during configuration evaluation")
1205                         handle OpenSSL.OpenSSL _ => ());
1206                 (cleanup ();
1207                  ignore (OpenSSL.readChar bio);
1208                  OpenSSL.close bio)
1209                 handle OpenSSL.OpenSSL _ => ();
1210                 loop ())
1211
1212 fun service () =
1213     let
1214         val host = Slave.hostname ()
1215
1216         val () = Acl.read Config.aclFile
1217
1218         val context = context (Config.certDir ^ "/" ^ host ^ ".pem",
1219                                Config.keyDir ^ "/" ^ host ^ "/key.pem",
1220                                Config.trustStore)
1221         val _ = Domain.set_context context
1222
1223         val sock = OpenSSL.listen (context, Config.dispatcherPort)
1224
1225         fun loop () =
1226             (case OpenSSL.accept sock of
1227                  NONE => ()
1228                | SOME bio =>
1229                  let
1230                      val user = OpenSSL.peerCN bio
1231                      val () = print ("\nConnection from " ^ user ^ " at " ^ now () ^ "\n")
1232                      val () = Domain.setUser user
1233                      val doIt = doIt' loop bio
1234
1235                      fun doConfig codes =
1236                          let
1237                              val _ = print "Configuration:\n"
1238                              val _ = app (fn s => (print s; print "\n")) codes
1239                              val _ = print "\n"
1240
1241                              val outname = OS.FileSys.tmpName ()
1242
1243                              fun doOne (code, (G, evs)) =
1244                                  let
1245                                      val outf = TextIO.openOut outname
1246                                  in
1247                                      TextIO.output (outf, code);
1248                                      TextIO.closeOut outf;
1249                                      eval G evs outname
1250                                  end
1251                          in
1252                              doIt (fn () => (Env.pre ();
1253                                              ignore (foldl doOne (basis (), Defaults.eInit ()) codes);
1254                                              Env.post ();
1255                                              Msg.send (bio, MsgOk);
1256                                              ("Configuration complete.", NONE)))
1257                                   (fn () => OS.FileSys.remove outname)
1258                          end
1259
1260                      fun checkAddr s =
1261                          case String.fields (fn ch => ch = #"@") s of
1262                              [user'] =>
1263                              if user = user' then
1264                                  SOME (SetSA.User s)
1265                              else
1266                                  NONE
1267                            | [user', domain] =>
1268                              if Domain.validEmailUser user' andalso Domain.yourDomain domain then
1269                                  SOME (SetSA.Email s)
1270                              else
1271                                  NONE
1272                            | _ => NONE
1273
1274                      fun cmdLoop () =
1275                          case Msg.recv bio of
1276                              NONE => (OpenSSL.close bio
1277                                       handle OpenSSL.OpenSSL _ => ();
1278                                       loop ())
1279                            | SOME m =>
1280                              case m of
1281                                  MsgConfig code => doConfig [code]
1282                                | MsgMultiConfig codes => doConfig codes
1283
1284                                | MsgShutdown =>
1285                                  if Acl.query {user = user, class = "priv", value = "all"}
1286                                     orelse Acl.query {user = user, class = "priv", value = "shutdown"} then
1287                                      print ("Domtool dispatcher shutting down at " ^ now () ^ "\n\n")
1288                                  else
1289                                      (print "Unauthorized shutdown command!\n";
1290                                       OpenSSL.close bio
1291                                       handle OpenSSL.OpenSSL _ => ();
1292                                       loop ())
1293
1294                                | MsgGrant acl =>
1295                                  doIt (fn () =>
1296                                           if Acl.query {user = user, class = "priv", value = "all"} then
1297                                               (Acl.grant acl;
1298                                                Acl.write Config.aclFile;
1299                                                if #class acl = "user" then
1300                                                    usersChanged ()
1301                                                else
1302                                                    ();
1303                                                ("Granted permission " ^ #value acl ^ " to " ^ #user acl ^ " in " ^ #class acl ^ ".",
1304                                                 NONE))
1305                                           else
1306                                               ("Unauthorized user asked to grant a permission!",
1307                                                SOME "Not authorized to grant privileges"))
1308                                       (fn () => ())
1309
1310                                | MsgRevoke acl =>
1311                                  doIt (fn () =>
1312                                           if Acl.query {user = user, class = "priv", value = "all"} then
1313                                               (Acl.revoke acl;
1314                                                Acl.write Config.aclFile;
1315                                                ("Revoked permission " ^ #value acl ^ " from " ^ #user acl ^ " in " ^ #class acl ^ ".",
1316                                                 NONE))
1317                                           else
1318                                               ("Unauthorized user asked to revoke a permission!",
1319                                                SOME "Not authorized to revoke privileges"))
1320                                       (fn () => ())
1321
1322                                | MsgListPerms user =>
1323                                  doIt (fn () =>
1324                                           (Msg.send (bio, MsgPerms (Acl.queryAll user));
1325                                            ("Sent permission list for user " ^ user ^ ".",
1326                                             NONE)))
1327                                       (fn () => ())
1328
1329                                | MsgWhoHas perm =>
1330                                  doIt (fn () =>
1331                                           (Msg.send (bio, MsgWhoHasResponse (Acl.whoHas perm));
1332                                            ("Sent whohas response for " ^ #class perm ^ " / " ^ #value perm ^ ".",
1333                                             NONE)))
1334                                       (fn () => ())
1335
1336                                | MsgRmdom doms =>
1337                                  doIt (fn () =>
1338                                           if Acl.query {user = user, class = "priv", value = "all"}
1339                                              orelse List.all (fn dom => Domain.validDomain dom
1340                                                                         andalso Acl.queryDomain {user = user, domain = dom}) doms then
1341                                               (Domain.rmdom doms;
1342                                                (*app (fn dom =>
1343                                                        Acl.revokeFromAll {class = "domain", value = dom}) doms;
1344                                                Acl.write Config.aclFile;*)
1345                                                ("Removed domains" ^ foldl (fn (d, s) => s ^ " " ^ d) "" doms ^ ".",
1346                                                 NONE))
1347                                           else
1348                                               ("Unauthorized user asked to remove a domain!",
1349                                                SOME "Not authorized to remove that domain"))
1350                                       (fn () => ())
1351
1352                                | MsgRegenerate =>
1353                                  doIt (fn () =>
1354                                           if Acl.query {user = user, class = "priv", value = "regen"}
1355                                              orelse Acl.query {user = user, class = "priv", value = "all"} then
1356                                               (if regenerate context then
1357                                                    ("Regenerated all configuration.",
1358                                                     NONE)
1359                                                else
1360                                                    ("Error regenerating configuration!",
1361                                                     SOME "Error regenerating configuration!  Consult /var/log/domtool.log."))
1362                                           else
1363                                               ("Unauthorized user asked to regenerate!",
1364                                                SOME "Not authorized to regenerate"))
1365                                       (fn () => ())
1366
1367                                | MsgRegenerateTc =>
1368                                  doIt (fn () =>
1369                                           if Acl.query {user = user, class = "priv", value = "regen"}
1370                                              orelse Acl.query {user = user, class = "priv", value = "all"} then
1371                                               (if regenerateTc context then
1372                                                    ("Checked all configuration.",
1373                                                     NONE)
1374                                                else
1375                                                    ("Found a compilation error!",
1376                                                     SOME "Found a compilation error!  Consult /var/log/domtool.log."))
1377                                           else
1378                                               ("Unauthorized user asked to regenerate -tc!",
1379                                                SOME "Not authorized to regenerate -tc"))
1380                                       (fn () => ())
1381
1382                                | MsgRmuser user' =>
1383                                  doIt (fn () =>
1384                                           if Acl.query {user = user, class = "priv", value = "all"} then
1385                                               (rmuser user';
1386                                                Acl.write Config.aclFile;
1387                                                ("Removed user " ^ user' ^ ".",
1388                                                 NONE))
1389                                           else
1390                                               ("Unauthorized user asked to remove a user!",
1391                                                SOME "Not authorized to remove users"))
1392                                       (fn () => ())
1393
1394                                | MsgListMailboxes domain =>
1395                                  doIt (fn () =>
1396                                           if not (Domain.yourDomain domain) then
1397                                               ("User wasn't authorized to list mailboxes for " ^ domain,
1398                                                SOME "You're not authorized to configure that domain.")
1399                                           else
1400                                               case Vmail.list domain of
1401                                                   Vmail.Listing users => (Msg.send (bio, MsgMailboxes users);
1402                                                                           ("Sent mailbox list for " ^ domain,
1403                                                                            NONE))
1404                                                 | Vmail.Error msg => ("Error listing mailboxes for " ^ domain ^ ": " ^ msg,
1405                                                                       SOME msg))
1406                                       (fn () => ())
1407
1408                                | MsgNewMailbox {domain, user = emailUser, passwd, mailbox} =>
1409                                  doIt (fn () =>
1410                                           if not (Domain.yourDomain domain) then
1411                                               ("User wasn't authorized to add a mailbox to " ^ domain,
1412                                                SOME "You're not authorized to configure that domain.")
1413                                           else if not (Domain.validEmailUser emailUser) then
1414                                               ("Invalid e-mail username " ^ emailUser,
1415                                                SOME "Invalid e-mail username")
1416                                           else if not (CharVector.all Char.isGraph passwd) then
1417                                               ("Invalid password",
1418                                                SOME "Invalid password; may only contain printable, non-space characters")
1419                                           else if not (Domain.yourPath mailbox) then
1420                                               ("User wasn't authorized to add a mailbox at " ^ mailbox,
1421                                                SOME ("You're not authorized to use that mailbox location. ("
1422                                                      ^ mailbox ^ ")"))
1423                                           else
1424                                               case Vmail.add {requester = user,
1425                                                               domain = domain, user = emailUser,
1426                                                               passwd = passwd, mailbox = mailbox} of
1427                                                   NONE => ("Added mailbox " ^ emailUser ^ "@" ^ domain ^ " at " ^ mailbox,
1428                                                            NONE)
1429                                                 | SOME msg => ("Error adding mailbox " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
1430                                                                SOME msg))
1431                                       (fn () => ())
1432
1433                                | MsgPasswdMailbox {domain, user = emailUser, passwd} =>
1434                                  doIt (fn () =>
1435                                           if not (Domain.yourDomain domain) then
1436                                               ("User wasn't authorized to change password of a mailbox for " ^ domain,
1437                                                SOME "You're not authorized to configure that domain.")
1438                                           else if not (Domain.validEmailUser emailUser) then
1439                                               ("Invalid e-mail username " ^ emailUser,
1440                                                SOME "Invalid e-mail username")
1441                                           else if not (CharVector.all Char.isGraph passwd) then
1442                                               ("Invalid password",
1443                                                SOME "Invalid password; may only contain printable, non-space characters")
1444                                           else
1445                                               case Vmail.passwd {domain = domain, user = emailUser,
1446                                                                  passwd = passwd} of
1447                                                   NONE => ("Changed password of mailbox " ^ emailUser ^ "@" ^ domain,
1448                                                            NONE)
1449                                                 | SOME msg => ("Error changing mailbox password for " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
1450                                                                SOME msg))
1451                                       (fn () => ())
1452
1453                                | MsgRmMailbox {domain, user = emailUser} =>
1454                                  doIt (fn () =>
1455                                           if not (Domain.yourDomain domain) then
1456                                               ("User wasn't authorized to change password of a mailbox for " ^ domain,
1457                                                SOME "You're not authorized to configure that domain.")
1458                                           else if not (Domain.validEmailUser emailUser) then
1459                                               ("Invalid e-mail username " ^ emailUser,
1460                                                SOME "Invalid e-mail username")
1461                                           else
1462                                               case Vmail.rm {domain = domain, user = emailUser} of
1463                                                   NONE => ("Deleted mailbox " ^ emailUser ^ "@" ^ domain,
1464                                                            NONE)
1465                                                 | SOME msg => ("Error deleting mailbox " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
1466                                                                SOME msg))
1467                                       (fn () => ())
1468
1469                                | MsgSaQuery addr =>
1470                                  doIt (fn () =>
1471                                           case checkAddr addr of
1472                                               NONE => ("User tried to query SA filtering for " ^ addr,
1473                                                        SOME "You aren't allowed to configure SA filtering for that recipient.")
1474                                             | SOME addr' => (Msg.send (bio, MsgSaStatus (SetSA.query addr'));
1475                                                              ("Queried SA filtering status for " ^ addr,
1476                                                               NONE)))
1477                                       (fn () => ())
1478
1479                                | MsgSaSet (addr, b) =>
1480                                  doIt (fn () =>
1481                                           case checkAddr addr of
1482                                               NONE => ("User tried to set SA filtering for " ^ addr,
1483                                                        SOME "You aren't allowed to configure SA filtering for that recipient.")
1484                                             | SOME addr' => (SetSA.set (addr', b);
1485                                                              Msg.send (bio, MsgOk);
1486                                                              ("Set SA filtering status for " ^ addr ^ " to "
1487                                                               ^ (if b then "ON" else "OFF"),
1488                                                               NONE)))
1489                                       (fn () => ())
1490
1491                                | MsgSmtpLogReq domain =>
1492                                  doIt (fn () =>
1493                                           if not (Domain.yourDomain domain) then
1494                                               ("Unauthorized user tried to request SMTP logs for " ^ domain,
1495                                                SOME "You aren't authorized to configure that domain.")
1496                                           else
1497                                               (SmtpLog.search (fn line => Msg.send (bio, MsgSmtpLogRes line))
1498                                                               domain;
1499                                                ("Requested SMTP logs for " ^ domain,
1500                                                 NONE)))
1501                                       (fn () => ())
1502
1503                                | MsgQuery q =>
1504                                  doIt (fn () => (Msg.send (bio, answerQuery q);
1505                                                  (describeQuery q,
1506                                                   NONE)))
1507                                       (fn () => ())
1508
1509                                | MsgMysqlFixperms =>
1510                                  (print "Starting mysql-fixperms\n";
1511                                   doIt (fn () => if OS.Process.isSuccess
1512                                                         (OS.Process.system "/usr/bin/sudo -H /afs/hcoop.net/common/etc/scripts/mysql-grant-table-drop") then
1513                                                      ("Requested mysql-fixperms",
1514                                                       NONE)
1515                                                  else
1516                                                      ("Requested mysql-fixperms, but execution failed!",
1517                                                       SOME "Script execution failed."))
1518                                        (fn () => ()))
1519
1520                                | MsgDescribe dom =>
1521                                  doIt (fn () => if not (Domain.validDomain dom) then
1522                                                     ("Requested description of invalid domain " ^ dom,
1523                                                      SOME "Invalid domain name")
1524                                                 else if not (Domain.yourDomain dom
1525                                                              orelse Acl.query {user = user, class = "priv", value = "all"}) then
1526                                                     ("Requested description of " ^ dom ^ ", but not allowed access",
1527                                                      SOME "Access denied")
1528                                                 else
1529                                                     (Msg.send (bio, MsgDescription (Domain.describe dom));
1530                                                      ("Sent description of domain " ^ dom,
1531                                                       NONE)))
1532                                       (fn () => ())
1533
1534                                | MsgReUsers =>
1535                                  doIt (fn () => if Acl.query {user = user, class = "priv", value = "regen"}
1536                                                    orelse Acl.query {user = user, class = "priv", value = "all"} then
1537                                                     (usersChanged ();
1538                                                      ("Users change callbacks run", NONE))
1539                                                 else
1540                                                     ("Unauthorized user asked to reusers!",
1541                                                      SOME "You aren't authorized to regenerate files."))
1542                                       (fn () => ())
1543
1544                                | _ =>
1545                                  doIt (fn () => ("Unexpected command",
1546                                                  SOME "Unexpected command"))
1547                                       (fn () => ())
1548                  in
1549                      cmdLoop ()
1550                  end
1551                  handle e as (OpenSSL.OpenSSL s) =>
1552                         (print ("OpenSSL error: " ^ s ^ "\n");
1553                          app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);
1554                          OpenSSL.close bio
1555                          handle OpenSSL.OpenSSL _ => ();
1556                          loop ())
1557                       | OS.SysErr (s, _) =>
1558                         (print ("System error: " ^ s ^ "\n");
1559                          OpenSSL.close bio
1560                          handle OpenSSL.OpenSSL _ => ();
1561                          loop ())
1562                       | IO.Io {name, function, cause} =>
1563                         (print ("IO error: " ^ function ^ " for " ^ name ^ "\n");
1564                          app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory cause);
1565                          OpenSSL.close bio
1566                          handle OpenSSL.OpenSSL _ => ();
1567                          loop ())
1568                       | OS.Path.InvalidArc =>
1569                         (print "Invalid arc\n";
1570                          OpenSSL.close bio
1571                          handle OpenSSL.OpenSSL _ => ();
1572                          loop ())
1573                       | e =>
1574                         (print "Unknown exception in main loop!\n";
1575                          app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);
1576                          OpenSSL.close bio
1577                          handle OpenSSL.OpenSSL _ => ();
1578                          loop ()))
1579             handle e as (OpenSSL.OpenSSL s) =>
1580                    (print ("OpenSSL error: " ^ s ^ "\n");
1581                     app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);
1582                     loop ())
1583                  | OS.SysErr (s, _) =>
1584                    (print ("System error: " ^ s ^ "\n");
1585                     loop ())
1586                  | IO.Io {name, function, cause} =>
1587                    (print ("IO error: " ^ function ^ " for " ^ name ^ "\n");
1588                     app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory cause);
1589                     loop ())
1590                  | e =>
1591                    (print "Unknown exception in main loop!\n";
1592                     app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);
1593                     loop ())
1594     in
1595         print ("Domtool dispatcher starting up at " ^ now () ^ "\n");
1596         print "Listening for connections....\n";
1597         loop ();
1598         OpenSSL.shutdown sock
1599     end
1600
1601 fun slave () =
1602     let
1603         val host = Slave.hostname ()
1604
1605         val context = context (Config.certDir ^ "/" ^ host ^ ".pem",
1606                                Config.keyDir ^ "/" ^ host ^ "/key.pem",
1607                                Config.trustStore)
1608
1609         val sock = OpenSSL.listen (context, Config.slavePort)
1610
1611         val _ = print ("Slave server starting at " ^ now () ^ "\n")
1612
1613         fun loop () =
1614             (case OpenSSL.accept sock of
1615                  NONE => ()
1616                | SOME bio =>
1617                  let
1618                      val peer = OpenSSL.peerCN bio
1619                      val () = print ("\nConnection from " ^ peer ^ " at " ^ now () ^ "\n")
1620                  in
1621                      if peer = Config.dispatcherName then let
1622                              fun loop' files =
1623                                  case Msg.recv bio of
1624                                      NONE => print "Dispatcher closed connection unexpectedly\n"
1625                                    | SOME m =>
1626                                      case m of
1627                                          MsgFile file => loop' (file :: files)
1628                                        | MsgDoFiles => (Slave.handleChanges files;
1629                                                         Msg.send (bio, MsgOk))
1630                                        | MsgRegenerate => (Domain.resetLocal ();
1631                                                            Msg.send (bio, MsgOk))
1632                                        | MsgVmailChanged => (if Vmail.doChanged () then
1633                                                                  Msg.send (bio, MsgOk)
1634                                                              else
1635                                                                  Msg.send (bio, MsgError "userdb update failed"))
1636                                        | _ => (print "Dispatcher sent unexpected command\n";
1637                                                Msg.send (bio, MsgError "Unexpected command"))
1638                          in
1639                              loop' [];
1640                              ignore (OpenSSL.readChar bio);
1641                              OpenSSL.close bio;
1642                              loop ()
1643                          end
1644                      else if peer = "domtool" then
1645                          case Msg.recv bio of
1646                              SOME MsgShutdown => (OpenSSL.close bio;
1647                                                   print ("Shutting down at " ^ now () ^ "\n\n"))
1648                            | _ => (OpenSSL.close bio;
1649                                    loop ())
1650                      else
1651                          let
1652                              val doIt = doIt' loop bio
1653                              val user = peer
1654                          in
1655                              case Msg.recv bio of
1656                                  NONE => (OpenSSL.close bio
1657                                           handle OpenSSL.OpenSSL _ => ();
1658                                           loop ())
1659                                | SOME m =>
1660                                  case m of
1661                                      (MsgQuery q) => (print (describeQuery q ^ "\n");
1662                                                       Msg.send (bio, answerQuery q);
1663                                                       ignore (OpenSSL.readChar bio);
1664                                                       OpenSSL.close bio;
1665                                                       loop ())
1666                                    | MsgCreateDbUser {dbtype, passwd} =>
1667                                      doIt (fn () =>
1668                                               case Dbms.lookup dbtype of
1669                                                   NONE => ("Database user creation request with unknown datatype type " ^ dbtype,
1670                                                            SOME ("Unknown database type " ^ dbtype))
1671                                                 | SOME handler =>
1672                                                   case #adduser handler {user = user, passwd = passwd} of
1673                                                       NONE => ("Added " ^ dbtype ^ " user " ^ user ^ ".",
1674                                                                NONE)
1675                                                     | SOME msg =>
1676                                                       ("Error adding a " ^ dbtype ^ " user " ^ user ^ ": " ^ msg,
1677                                                        SOME ("Error adding user: " ^ msg)))
1678                                           (fn () => ())
1679
1680                                    | MsgDbPasswd {dbtype, passwd} =>
1681                                      doIt (fn () =>
1682                                               case Dbms.lookup dbtype of
1683                                                   NONE => ("Database passwd request with unknown datatype type " ^ dbtype,
1684                                                            SOME ("Unknown database type " ^ dbtype))
1685                                                 | SOME handler =>
1686                                                   case #passwd handler {user = user, passwd = passwd} of
1687                                                       NONE => ("Changed " ^ dbtype ^ " password of user " ^ user ^ ".",
1688                                                                NONE)
1689                                                     | SOME msg =>
1690                                                       ("Error setting " ^ dbtype ^ " password of user " ^ user ^ ": " ^ msg,
1691                                                        SOME ("Error adding user: " ^ msg)))
1692                                           (fn () => ())
1693
1694                                    | MsgCreateDb {dbtype, dbname, encoding} =>
1695                                      doIt (fn () =>
1696                                               if Dbms.validDbname dbname then
1697                                                   case Dbms.lookup dbtype of
1698                                                       NONE => ("Database creation request with unknown datatype type " ^ dbtype,
1699                                                                SOME ("Unknown database type " ^ dbtype))
1700                                                     | SOME handler =>
1701                                                       if not (Dbms.validEncoding encoding) then
1702                                                           ("Invalid encoding " ^ valOf encoding ^ " requested for database creation.",
1703                                                            SOME "Invalid encoding")
1704                                                       else
1705                                                           case #createdb handler {user = user, dbname = dbname, encoding = encoding} of
1706                                                               NONE => ("Created database " ^ user ^ "_" ^ dbname ^ ".",
1707                                                                        NONE)
1708                                                             | SOME msg => ("Error creating database " ^ user ^ "_" ^ dbname ^ ": " ^ msg,
1709                                                                            SOME ("Error creating database: " ^ msg))
1710                                               else
1711                                                   ("Invalid database name " ^ user ^ "_" ^ dbname,
1712                                                    SOME ("Invalid database name " ^ dbname)))
1713                                           (fn () => ())
1714
1715                                    | MsgDropDb {dbtype, dbname} =>
1716                                      doIt (fn () =>
1717                                               if Dbms.validDbname dbname then
1718                                                   case Dbms.lookup dbtype of
1719                                                       NONE => ("Database drop request with unknown datatype type " ^ dbtype,
1720                                                                SOME ("Unknown database type " ^ dbtype))
1721                                                     | SOME handler =>
1722                                                       case #dropdb handler {user = user, dbname = dbname} of
1723                                                           NONE => ("Drop database " ^ user ^ "_" ^ dbname ^ ".",
1724                                                                    NONE)
1725                                                         | SOME msg => ("Error dropping database " ^ user ^ "_" ^ dbname ^ ": " ^ msg,
1726                                                                        SOME ("Error dropping database: " ^ msg))
1727                                               else
1728                                                   ("Invalid database name " ^ user ^ "_" ^ dbname,
1729                                                    SOME ("Invalid database name " ^ dbname)))
1730                                           (fn () => ())
1731
1732                                    | MsgGrantDb {dbtype, dbname} =>
1733                                      doIt (fn () =>
1734                                               if Dbms.validDbname dbname then
1735                                                   case Dbms.lookup dbtype of
1736                                                       NONE => ("Database drop request with unknown datatype type " ^ dbtype,
1737                                                                SOME ("Unknown database type " ^ dbtype))
1738                                                     | SOME handler =>
1739                                                       case #grant handler {user = user, dbname = dbname} of
1740                                                           NONE => ("Grant permissions to database " ^ user ^ "_" ^ dbname ^ ".",
1741                                                                    NONE)
1742                                                         | SOME msg => ("Error granting permissions to database " ^ user ^ "_" ^ dbname ^ ": " ^ msg,
1743                                                                        SOME ("Error granting permissions to database: " ^ msg))
1744                                               else
1745                                                   ("Invalid database name " ^ user ^ "_" ^ dbname,
1746                                                    SOME ("Invalid database name " ^ dbname)))
1747                                           (fn () => ())
1748                                    | _ => (OpenSSL.close bio;
1749                                            loop ())
1750                          end
1751                  end handle OpenSSL.OpenSSL s =>
1752                             (print ("OpenSSL error: " ^ s ^ "\n");
1753                              OpenSSL.close bio
1754                              handle OpenSSL.OpenSSL _ => ();
1755                              loop ())
1756                           | e as OS.SysErr (s, _) =>
1757                             (app (fn s => print (s ^ "\n")) (SMLofNJ.exnHistory e);
1758                              print ("System error: "^ s ^ "\n");
1759                              OpenSSL.close bio
1760                              handle OpenSSL.OpenSSL _ => ();
1761                              loop ())
1762                           | IO.Io {function, name, ...} =>
1763                             (print ("IO error: " ^ function ^ ": " ^ name ^ "\n");
1764                              OpenSSL.close bio
1765                              handle OpenSSL.OpenSSL _ => ();
1766                              loop ())
1767                           | e =>
1768                             (app (fn s => print (s ^ "\n")) (SMLofNJ.exnHistory e);
1769                              print "Uncaught exception!\n";
1770                              OpenSSL.close bio
1771                              handle OpenSSL.OpenSSL _ => ();
1772                              loop ()))
1773             handle OpenSSL.OpenSSL s =>
1774                    (print ("OpenSSL error: " ^ s ^ "\n");
1775                     loop ())
1776                  | e =>
1777                    (app (fn s => print (s ^ "\n")) (SMLofNJ.exnHistory e);
1778                     print "Uncaught exception!\n";
1779                     loop ())
1780     in
1781         loop ();
1782         OpenSSL.shutdown sock
1783     end
1784
1785 fun listBasis () =
1786     let
1787         val dir = Posix.FileSys.opendir Config.libRoot
1788
1789         fun loop files =
1790             case Posix.FileSys.readdir dir of
1791                 NONE => (Posix.FileSys.closedir dir;
1792                          files)
1793               | SOME fname =>
1794                 if String.isSuffix ".dtl" fname then
1795                     loop (OS.Path.joinDirFile {dir = Config.libRoot,
1796                                                file = fname}
1797                           :: files)
1798                 else
1799                     loop files
1800     in
1801         loop []
1802     end
1803
1804 fun autodocBasis outdir =
1805     Autodoc.autodoc {outdir = outdir, infiles = listBasis ()}
1806
1807 end