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 host = Slave.hostname ()
1132
1133         val () = Acl.read Config.aclFile
1134
1135         val context = context (Config.certDir ^ "/" ^ host ^ ".pem",
1136                                Config.keyDir ^ "/" ^ host ^ "/key.pem",
1137                                Config.trustStore)
1138         val _ = Domain.set_context context
1139
1140         val sock = OpenSSL.listen (context, Config.dispatcherPort)
1141
1142         fun loop () =
1143             (case OpenSSL.accept sock of
1144                  NONE => ()
1145                | SOME bio =>
1146                  let
1147                      val user = OpenSSL.peerCN bio
1148                      val () = print ("\nConnection from " ^ user ^ " at " ^ now () ^ "\n")
1149                      val () = Domain.setUser user
1150
1151                      fun doIt f cleanup =
1152                          ((case f () of
1153                                (msgLocal, SOME msgRemote) =>
1154                                (print msgLocal;
1155                                 print "\n";
1156                                 Msg.send (bio, MsgError msgRemote))
1157                              | (msgLocal, NONE) =>
1158                                (print msgLocal;
1159                                 print "\n";
1160                                 Msg.send (bio, MsgOk)))
1161                           handle e as (OpenSSL.OpenSSL s) =>
1162                                  (print ("OpenSSL error: " ^ s ^ "\n");
1163                                   app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);
1164                                   Msg.send (bio, MsgError ("OpenSSL error: " ^ s))
1165                                   handle OpenSSL.OpenSSL _ => ())
1166                                | OS.SysErr (s, _) =>
1167                                  (print "System error: ";
1168                                   print s;
1169                                   print "\n";
1170                                   Msg.send (bio, MsgError ("System error: " ^ s))
1171                                   handle OpenSSL.OpenSSL _ => ())
1172                                | Fail s =>
1173                                  (print "Failure: ";
1174                                   print s;
1175                                   print "\n";
1176                                   Msg.send (bio, MsgError ("Failure: " ^ s))
1177                                   handle OpenSSL.OpenSSL _ => ())
1178                                | ErrorMsg.Error =>
1179                                  (print "Compilation error\n";
1180                                   Msg.send (bio, MsgError "Error during configuration evaluation")
1181                                   handle OpenSSL.OpenSSL _ => ());
1182                           (cleanup ();
1183                            ignore (OpenSSL.readChar bio);
1184                            OpenSSL.close bio)
1185                           handle OpenSSL.OpenSSL _ => ();
1186                           loop ())
1187
1188                      fun doConfig codes =
1189                          let
1190                              val _ = print "Configuration:\n"
1191                              val _ = app (fn s => (print s; print "\n")) codes
1192                              val _ = print "\n"
1193
1194                              val outname = OS.FileSys.tmpName ()
1195
1196                              fun doOne (code, (G, evs)) =
1197                                  let
1198                                      val outf = TextIO.openOut outname
1199                                  in
1200                                      TextIO.output (outf, code);
1201                                      TextIO.closeOut outf;
1202                                      eval G evs outname
1203                                  end
1204                          in
1205                              doIt (fn () => (Env.pre ();
1206                                              ignore (foldl doOne (basis (), Defaults.eInit ()) codes);
1207                                              Env.post ();
1208                                              Msg.send (bio, MsgOk);
1209                                              ("Configuration complete.", NONE)))
1210                                   (fn () => OS.FileSys.remove outname)
1211                          end
1212
1213                      fun checkAddr s =
1214                          case String.fields (fn ch => ch = #"@") s of
1215                              [user'] =>
1216                              if user = user' then
1217                                  SOME (SetSA.User s)
1218                              else
1219                                  NONE
1220                            | [user', domain] =>
1221                              if Domain.validEmailUser user' andalso Domain.yourDomain domain then
1222                                  SOME (SetSA.Email s)
1223                              else
1224                                  NONE
1225                            | _ => NONE
1226
1227                      fun cmdLoop () =
1228                          case Msg.recv bio of
1229                              NONE => (OpenSSL.close bio
1230                                       handle OpenSSL.OpenSSL _ => ();
1231                                       loop ())
1232                            | SOME m =>
1233                              case m of
1234                                  MsgConfig code => doConfig [code]
1235                                | MsgMultiConfig codes => doConfig codes
1236
1237                                | MsgShutdown =>
1238                                  if Acl.query {user = user, class = "priv", value = "all"}
1239                                     orelse Acl.query {user = user, class = "priv", value = "shutdown"} then
1240                                      print ("Domtool dispatcher shutting down at " ^ now () ^ "\n\n")
1241                                  else
1242                                      (print "Unauthorized shutdown command!\n";
1243                                       OpenSSL.close bio
1244                                       handle OpenSSL.OpenSSL _ => ();
1245                                       loop ())
1246
1247                                | MsgGrant acl =>
1248                                  doIt (fn () =>
1249                                           if Acl.query {user = user, class = "priv", value = "all"} then
1250                                               (Acl.grant acl;
1251                                                Acl.write Config.aclFile;
1252                                                ("Granted permission " ^ #value acl ^ " to " ^ #user acl ^ " in " ^ #class acl ^ ".",
1253                                                 NONE))
1254                                           else
1255                                               ("Unauthorized user asked to grant a permission!",
1256                                                SOME "Not authorized to grant privileges"))
1257                                       (fn () => ())
1258
1259                                | MsgRevoke acl =>
1260                                  doIt (fn () =>
1261                                           if Acl.query {user = user, class = "priv", value = "all"} then
1262                                               (Acl.revoke acl;
1263                                                Acl.write Config.aclFile;
1264                                                ("Revoked permission " ^ #value acl ^ " from " ^ #user acl ^ " in " ^ #class acl ^ ".",
1265                                                 NONE))
1266                                           else
1267                                               ("Unauthorized user asked to revoke a permission!",
1268                                                SOME "Not authorized to revoke privileges"))
1269                                       (fn () => ())
1270
1271                                | MsgListPerms user =>
1272                                  doIt (fn () =>
1273                                           (Msg.send (bio, MsgPerms (Acl.queryAll user));
1274                                            ("Sent permission list for user " ^ user ^ ".",
1275                                             NONE)))
1276                                       (fn () => ())
1277
1278                                | MsgWhoHas perm =>
1279                                  doIt (fn () =>
1280                                           (Msg.send (bio, MsgWhoHasResponse (Acl.whoHas perm));
1281                                            ("Sent whohas response for " ^ #class perm ^ " / " ^ #value perm ^ ".",
1282                                             NONE)))
1283                                       (fn () => ())
1284
1285                                | MsgRmdom doms =>
1286                                  doIt (fn () =>
1287                                           if Acl.query {user = user, class = "priv", value = "all"}
1288                                              orelse List.all (fn dom => Domain.validDomain dom
1289                                                                         andalso Acl.queryDomain {user = user, domain = dom}) doms then
1290                                               (Domain.rmdom doms;
1291                                                (*app (fn dom =>
1292                                                        Acl.revokeFromAll {class = "domain", value = dom}) doms;
1293                                                Acl.write Config.aclFile;*)
1294                                                ("Removed domains" ^ foldl (fn (d, s) => s ^ " " ^ d) "" doms ^ ".",
1295                                                 NONE))
1296                                           else
1297                                               ("Unauthorized user asked to remove a domain!",
1298                                                SOME "Not authorized to remove that domain"))
1299                                       (fn () => ())
1300
1301                                | MsgRegenerate =>
1302                                  doIt (fn () =>
1303                                           if Acl.query {user = user, class = "priv", value = "regen"}
1304                                              orelse Acl.query {user = user, class = "priv", value = "all"} then
1305                                               (if regenerate context then
1306                                                    ("Regenerated all configuration.",
1307                                                     NONE)
1308                                                else
1309                                                    ("Error regenerating configuration!",
1310                                                     SOME "Error regenerating configuration!  Consult /var/log/domtool.log."))
1311                                           else
1312                                               ("Unauthorized user asked to regenerate!",
1313                                                SOME "Not authorized to regenerate"))
1314                                       (fn () => ())
1315
1316                                | MsgRegenerateTc =>
1317                                  doIt (fn () =>
1318                                           if Acl.query {user = user, class = "priv", value = "regen"}
1319                                              orelse Acl.query {user = user, class = "priv", value = "all"} then
1320                                               (if regenerateTc context then
1321                                                    ("Checked all configuration.",
1322                                                     NONE)
1323                                                else
1324                                                    ("Found a compilation error!",
1325                                                     SOME "Found a compilation error!  Consult /var/log/domtool.log."))
1326                                           else
1327                                               ("Unauthorized user asked to regenerate -tc!",
1328                                                SOME "Not authorized to regenerate -tc"))
1329                                       (fn () => ())
1330
1331                                | MsgRmuser user' =>
1332                                  doIt (fn () =>
1333                                           if Acl.query {user = user, class = "priv", value = "all"} then
1334                                               (rmuser user';
1335                                                Acl.write Config.aclFile;
1336                                                ("Removed user " ^ user' ^ ".",
1337                                                 NONE))
1338                                           else
1339                                               ("Unauthorized user asked to remove a user!",
1340                                                SOME "Not authorized to remove users"))
1341                                       (fn () => ())
1342
1343                                | MsgCreateDbUser {dbtype, passwd} =>
1344                                  doIt (fn () =>
1345                                           case Dbms.lookup dbtype of
1346                                               NONE => ("Database user creation request with unknown datatype type " ^ dbtype,
1347                                                        SOME ("Unknown database type " ^ dbtype))
1348                                             | SOME handler =>
1349                                               case #adduser handler {user = user, passwd = passwd} of
1350                                                   NONE => ("Added " ^ dbtype ^ " user " ^ user ^ ".",
1351                                                            NONE)
1352                                                 | SOME msg =>
1353                                                   ("Error adding a " ^ dbtype ^ " user " ^ user ^ ": " ^ msg,
1354                                                    SOME ("Error adding user: " ^ msg)))
1355                                       (fn () => ())
1356
1357                                | MsgDbPasswd {dbtype, passwd} =>
1358                                  doIt (fn () =>
1359                                           case Dbms.lookup dbtype of
1360                                               NONE => ("Database passwd request with unknown datatype type " ^ dbtype,
1361                                                        SOME ("Unknown database type " ^ dbtype))
1362                                             | SOME handler =>
1363                                               case #passwd handler {user = user, passwd = passwd} of
1364                                                   NONE => ("Changed " ^ dbtype ^ " password of user " ^ user ^ ".",
1365                                                            NONE)
1366                                                 | SOME msg =>
1367                                                   ("Error setting " ^ dbtype ^ " password of user " ^ user ^ ": " ^ msg,
1368                                                    SOME ("Error adding user: " ^ msg)))
1369                                       (fn () => ())
1370
1371                                | MsgCreateDb {dbtype, dbname, encoding} =>
1372                                  doIt (fn () =>
1373                                           if Dbms.validDbname dbname then
1374                                               case Dbms.lookup dbtype of
1375                                                   NONE => ("Database creation request with unknown datatype type " ^ dbtype,
1376                                                            SOME ("Unknown database type " ^ dbtype))
1377                                                 | SOME handler =>
1378                                                   if not (Dbms.validEncoding encoding) then
1379                                                       ("Invalid encoding " ^ valOf encoding ^ " requested for database creation.",
1380                                                        SOME "Invalid encoding")
1381                                                   else
1382                                                       case #createdb handler {user = user, dbname = dbname, encoding = encoding} of
1383                                                           NONE => ("Created database " ^ user ^ "_" ^ dbname ^ ".",
1384                                                                    NONE)
1385                                                         | SOME msg => ("Error creating database " ^ user ^ "_" ^ dbname ^ ": " ^ msg,
1386                                                                        SOME ("Error creating database: " ^ msg))
1387                                           else
1388                                               ("Invalid database name " ^ user ^ "_" ^ dbname,
1389                                                SOME ("Invalid database name " ^ dbname)))
1390                                       (fn () => ())
1391
1392                                | MsgDropDb {dbtype, dbname} =>
1393                                  doIt (fn () =>
1394                                           if Dbms.validDbname dbname then
1395                                               case Dbms.lookup dbtype of
1396                                                   NONE => ("Database drop request with unknown datatype type " ^ dbtype,
1397                                                            SOME ("Unknown database type " ^ dbtype))
1398                                                 | SOME handler =>
1399                                                   case #dropdb handler {user = user, dbname = dbname} of
1400                                                       NONE => ("Drop database " ^ user ^ "_" ^ dbname ^ ".",
1401                                                                NONE)
1402                                                     | SOME msg => ("Error dropping database " ^ user ^ "_" ^ dbname ^ ": " ^ msg,
1403                                                                    SOME ("Error dropping database: " ^ msg))
1404                                           else
1405                                               ("Invalid database name " ^ user ^ "_" ^ dbname,
1406                                                SOME ("Invalid database name " ^ dbname)))
1407                                       (fn () => ())
1408
1409                                | MsgGrantDb {dbtype, dbname} =>
1410                                  doIt (fn () =>
1411                                           if Dbms.validDbname dbname then
1412                                               case Dbms.lookup dbtype of
1413                                                   NONE => ("Database drop request with unknown datatype type " ^ dbtype,
1414                                                            SOME ("Unknown database type " ^ dbtype))
1415                                                 | SOME handler =>
1416                                                   case #grant handler {user = user, dbname = dbname} of
1417                                                       NONE => ("Grant permissions to database " ^ user ^ "_" ^ dbname ^ ".",
1418                                                                NONE)
1419                                                     | SOME msg => ("Error granting permissions to database " ^ user ^ "_" ^ dbname ^ ": " ^ msg,
1420                                                                    SOME ("Error granting permissions to database: " ^ msg))
1421                                           else
1422                                               ("Invalid database name " ^ user ^ "_" ^ dbname,
1423                                                SOME ("Invalid database name " ^ dbname)))
1424                                       (fn () => ())
1425
1426                                | MsgListMailboxes domain =>
1427                                  doIt (fn () =>
1428                                           if not (Domain.yourDomain domain) then
1429                                               ("User wasn't authorized to list mailboxes for " ^ domain,
1430                                                SOME "You're not authorized to configure that domain.")
1431                                           else
1432                                               case Vmail.list domain of
1433                                                   Vmail.Listing users => (Msg.send (bio, MsgMailboxes users);
1434                                                                           ("Sent mailbox list for " ^ domain,
1435                                                                            NONE))
1436                                                 | Vmail.Error msg => ("Error listing mailboxes for " ^ domain ^ ": " ^ msg,
1437                                                                       SOME msg))
1438                                       (fn () => ())
1439
1440                                | MsgNewMailbox {domain, user = emailUser, passwd, mailbox} =>
1441                                  doIt (fn () =>
1442                                           if not (Domain.yourDomain domain) then
1443                                               ("User wasn't authorized to add a mailbox to " ^ domain,
1444                                                SOME "You're not authorized to configure that domain.")
1445                                           else if not (Domain.validEmailUser emailUser) then
1446                                               ("Invalid e-mail username " ^ emailUser,
1447                                                SOME "Invalid e-mail username")
1448                                           else if not (CharVector.all Char.isGraph passwd) then
1449                                               ("Invalid password",
1450                                                SOME "Invalid password; may only contain printable, non-space characters")
1451                                           else if not (Domain.yourPath mailbox) then
1452                                               ("User wasn't authorized to add a mailbox at " ^ mailbox,
1453                                                SOME ("You're not authorized to use that mailbox location. ("
1454                                                      ^ mailbox ^ ")"))
1455                                           else
1456                                               case Vmail.add {requester = user,
1457                                                               domain = domain, user = emailUser,
1458                                                               passwd = passwd, mailbox = mailbox} of
1459                                                   NONE => ("Added mailbox " ^ emailUser ^ "@" ^ domain ^ " at " ^ mailbox,
1460                                                            NONE)
1461                                                 | SOME msg => ("Error adding mailbox " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
1462                                                                SOME msg))
1463                                       (fn () => ())
1464
1465                                | MsgPasswdMailbox {domain, user = emailUser, passwd} =>
1466                                  doIt (fn () =>
1467                                           if not (Domain.yourDomain domain) then
1468                                               ("User wasn't authorized to change password of a mailbox for " ^ domain,
1469                                                SOME "You're not authorized to configure that domain.")
1470                                           else if not (Domain.validEmailUser emailUser) then
1471                                               ("Invalid e-mail username " ^ emailUser,
1472                                                SOME "Invalid e-mail username")
1473                                           else if not (CharVector.all Char.isGraph passwd) then
1474                                               ("Invalid password",
1475                                                SOME "Invalid password; may only contain printable, non-space characters")
1476                                           else
1477                                               case Vmail.passwd {domain = domain, user = emailUser,
1478                                                                  passwd = passwd} of
1479                                                   NONE => ("Changed password of mailbox " ^ emailUser ^ "@" ^ domain,
1480                                                            NONE)
1481                                                 | SOME msg => ("Error changing mailbox password for " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
1482                                                                SOME msg))
1483                                       (fn () => ())
1484
1485                                | MsgRmMailbox {domain, user = emailUser} =>
1486                                  doIt (fn () =>
1487                                           if not (Domain.yourDomain domain) then
1488                                               ("User wasn't authorized to change password of a mailbox for " ^ domain,
1489                                                SOME "You're not authorized to configure that domain.")
1490                                           else if not (Domain.validEmailUser emailUser) then
1491                                               ("Invalid e-mail username " ^ emailUser,
1492                                                SOME "Invalid e-mail username")
1493                                           else
1494                                               case Vmail.rm {domain = domain, user = emailUser} of
1495                                                   NONE => ("Deleted mailbox " ^ emailUser ^ "@" ^ domain,
1496                                                            NONE)
1497                                                 | SOME msg => ("Error deleting mailbox " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
1498                                                                SOME msg))
1499                                       (fn () => ())
1500
1501                                | MsgSaQuery addr =>
1502                                  doIt (fn () =>
1503                                           case checkAddr addr of
1504                                               NONE => ("User tried to query SA filtering for " ^ addr,
1505                                                        SOME "You aren't allowed to configure SA filtering for that recipient.")
1506                                             | SOME addr' => (Msg.send (bio, MsgSaStatus (SetSA.query addr'));
1507                                                              ("Queried SA filtering status for " ^ addr,
1508                                                               NONE)))
1509                                       (fn () => ())
1510
1511                                | MsgSaSet (addr, b) =>
1512                                  doIt (fn () =>
1513                                           case checkAddr addr of
1514                                               NONE => ("User tried to set SA filtering for " ^ addr,
1515                                                        SOME "You aren't allowed to configure SA filtering for that recipient.")
1516                                             | SOME addr' => (SetSA.set (addr', b);
1517                                                              Msg.send (bio, MsgOk);
1518                                                              ("Set SA filtering status for " ^ addr ^ " to "
1519                                                               ^ (if b then "ON" else "OFF"),
1520                                                               NONE)))
1521                                       (fn () => ())
1522
1523                                | MsgSmtpLogReq domain =>
1524                                  doIt (fn () =>
1525                                           if not (Domain.yourDomain domain) then
1526                                               ("Unauthorized user tried to request SMTP logs for " ^ domain,
1527                                                SOME "You aren't authorized to configure that domain.")
1528                                           else
1529                                               (SmtpLog.search (fn line => Msg.send (bio, MsgSmtpLogRes line))
1530                                                               domain;
1531                                                ("Requested SMTP logs for " ^ domain,
1532                                                 NONE)))
1533                                       (fn () => ())
1534
1535                                | MsgQuery q =>
1536                                  doIt (fn () => (Msg.send (bio, answerQuery q);
1537                                                  (describeQuery q,
1538                                                   NONE)))
1539                                       (fn () => ())
1540
1541                                | MsgMysqlFixperms =>
1542                                  doIt (fn () => if OS.Process.isSuccess
1543                                                        (OS.Process.system "/usr/bin/sudo -H /afs/hcoop.net/common/etc/scripts/mysql-grant-table-drop") then
1544                                                     ("Requested mysql-fixperms",
1545                                                      NONE)
1546                                                  else
1547                                                      ("Requested mysql-fixperms, but execution failed!",
1548                                                       SOME "Script execution failed."))
1549                                       (fn () => ())
1550
1551                                | MsgDescribe dom =>
1552                                  doIt (fn () => if not (Domain.validDomain dom) then
1553                                                     ("Requested description of invalid domain " ^ dom,
1554                                                      SOME "Invalid domain name")
1555                                                 else if not (Domain.yourDomain dom
1556                                                              orelse Acl.query {user = user, class = "priv", value = "all"}) then
1557                                                     ("Requested description of " ^ dom ^ ", but not allowed access",
1558                                                      SOME "Access denied")
1559                                                 else
1560                                                     (Msg.send (bio, MsgDescription (Domain.describe dom));
1561                                                      ("Sent description of domain " ^ dom,
1562                                                       NONE)))
1563                                       (fn () => ())
1564
1565                                | _ =>
1566                                  doIt (fn () => ("Unexpected command",
1567                                                  SOME "Unexpected command"))
1568                                       (fn () => ())
1569                  in
1570                      cmdLoop ()
1571                  end
1572                  handle e as (OpenSSL.OpenSSL s) =>
1573                         (print ("OpenSSL error: " ^ s ^ "\n");
1574                          app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);
1575                          OpenSSL.close bio
1576                          handle OpenSSL.OpenSSL _ => ();
1577                          loop ())
1578                       | OS.SysErr (s, _) =>
1579                         (print ("System error: " ^ s ^ "\n");
1580                          OpenSSL.close bio
1581                          handle OpenSSL.OpenSSL _ => ();
1582                          loop ())
1583                       | IO.Io {name, function, cause} =>
1584                         (print ("IO error: " ^ function ^ " for " ^ name ^ "\n");
1585                          app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory cause);
1586                          OpenSSL.close bio
1587                          handle OpenSSL.OpenSSL _ => ();
1588                          loop ())
1589                       | OS.Path.InvalidArc =>
1590                         (print "Invalid arc\n";
1591                          OpenSSL.close bio
1592                          handle OpenSSL.OpenSSL _ => ();
1593                          loop ())
1594                       | e =>
1595                         (print "Unknown exception in main loop!\n";
1596                          app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);
1597                          OpenSSL.close bio
1598                          handle OpenSSL.OpenSSL _ => ();
1599                          loop ()))
1600             handle e as (OpenSSL.OpenSSL s) =>
1601                    (print ("OpenSSL error: " ^ s ^ "\n");
1602                     app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);
1603                     loop ())
1604                  | OS.SysErr (s, _) =>
1605                    (print ("System error: " ^ s ^ "\n");
1606                     loop ())
1607                  | IO.Io {name, function, cause} =>
1608                    (print ("IO error: " ^ function ^ " for " ^ name ^ "\n");
1609                     app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory cause);
1610                     loop ())
1611                  | e =>
1612                    (print "Unknown exception in main loop!\n";
1613                     app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);
1614                     loop ())
1615     in
1616         print ("Domtool dispatcher starting up at " ^ now () ^ "\n");
1617         print "Listening for connections....\n";
1618         loop ();
1619         OpenSSL.shutdown sock
1620     end
1621
1622 fun slave () =
1623     let
1624         val host = Slave.hostname ()
1625
1626         val context = context (Config.certDir ^ "/" ^ host ^ ".pem",
1627                                Config.keyDir ^ "/" ^ host ^ "/key.pem",
1628                                Config.trustStore)
1629
1630         val sock = OpenSSL.listen (context, Config.slavePort)
1631
1632         val _ = print ("Slave server starting at " ^ now () ^ "\n")
1633
1634         fun loop () =
1635             case OpenSSL.accept sock of
1636                 NONE => ()
1637               | SOME bio =>
1638                 let
1639                     val peer = OpenSSL.peerCN bio
1640                     val () = print ("\nConnection from " ^ peer ^ " at " ^ now () ^ "\n")
1641                 in
1642                     if peer = Config.dispatcherName then let
1643                             fun loop' files =
1644                                 case Msg.recv bio of
1645                                     NONE => print "Dispatcher closed connection unexpectedly\n"
1646                                   | SOME m =>
1647                                     case m of
1648                                         MsgFile file => loop' (file :: files)
1649                                       | MsgDoFiles => (Slave.handleChanges files;
1650                                                        Msg.send (bio, MsgOk))
1651                                       | MsgRegenerate => (Domain.resetLocal ();
1652                                                           Msg.send (bio, MsgOk))
1653                                       | _ => (print "Dispatcher sent unexpected command\n";
1654                                               Msg.send (bio, MsgError "Unexpected command"))
1655                         in
1656                             loop' [];
1657                             ignore (OpenSSL.readChar bio);
1658                             OpenSSL.close bio;
1659                             loop ()
1660                         end
1661                     else if peer = "domtool" then
1662                         case Msg.recv bio of
1663                             SOME MsgShutdown => (OpenSSL.close bio;
1664                                                  print ("Shutting down at " ^ now () ^ "\n\n"))
1665                           | _ => (OpenSSL.close bio;
1666                                   loop ())
1667                     else
1668                         case Msg.recv bio of
1669                             SOME (MsgQuery q) => (print (describeQuery q ^ "\n");
1670                                                   Msg.send (bio, answerQuery q);
1671                                                   ignore (OpenSSL.readChar bio);
1672                                                   OpenSSL.close bio;
1673                                                   loop ())
1674                           | _ => (OpenSSL.close bio;
1675                                   loop ())
1676                 end handle OpenSSL.OpenSSL s =>
1677                            (print ("OpenSSL error: " ^ s ^ "\n");
1678                             OpenSSL.close bio
1679                                           handle OpenSSL.OpenSSL _ => ();
1680                             loop ())
1681                          | e as OS.SysErr (s, _) =>
1682                            (app (fn s => print (s ^ "\n")) (SMLofNJ.exnHistory e);
1683                             print ("System error: "^ s ^ "\n");
1684                             OpenSSL.close bio
1685                             handle OpenSSL.OpenSSL _ => ();
1686                             loop ())
1687                          | IO.Io {function, name, ...} =>
1688                            (print ("IO error: " ^ function ^ ": " ^ name ^ "\n");
1689                             OpenSSL.close bio
1690                             handle OpenSSL.OpenSSL _ => ();
1691                             loop ())
1692                          | e =>
1693                            (app (fn s => print (s ^ "\n")) (SMLofNJ.exnHistory e);
1694                             print "Uncaught exception!\n";
1695                             OpenSSL.close bio
1696                             handle OpenSSL.OpenSSL _ => ();
1697                             loop ())
1698     in
1699         loop ();
1700         OpenSSL.shutdown sock
1701     end
1702
1703 fun listBasis () =
1704     let
1705         val dir = Posix.FileSys.opendir Config.libRoot
1706
1707         fun loop files =
1708             case Posix.FileSys.readdir dir of
1709                 NONE => (Posix.FileSys.closedir dir;
1710                          files)
1711               | SOME fname =>
1712                 if String.isSuffix ".dtl" fname then
1713                     loop (OS.Path.joinDirFile {dir = Config.libRoot,
1714                                                file = fname}
1715                           :: files)
1716                 else
1717                     loop files
1718     in
1719         loop []
1720     end
1721
1722 fun autodocBasis outdir =
1723     Autodoc.autodoc {outdir = outdir, infiles = listBasis ()}
1724
1725 end