src/main.sml

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