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