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