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