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