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