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