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