src/main.sml

   1 (* HCoop Domtool (http://hcoop.sourceforge.net/)
   2  * Copyright (c) 2006, 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 fun requestContext f =
 171     let
 172         val uid = Posix.ProcEnv.getuid ()
 173         val user = Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid uid)
 174
 175         val () = Acl.read Config.aclFile
 176         val () = Domain.setUser user
 177
 178         val () = f ()
 179
 180         val context = OpenSSL.context (Config.certDir ^ "/" ^ user ^ ".pem",
 181                                        Config.keyDir ^ "/" ^ user ^ "/key.pem",
 182                                        Config.trustStore)
 183     in
 184         (user, context)
 185     end
 186
 187 fun requestBio f =
 188     let
 189         val (user, context) = requestContext f
 190     in
 191         (user, OpenSSL.connect (context, dispatcher))
 192     end
 193
 194 fun request fname =
 195     let
 196         val (user, bio) = requestBio (fn () => ignore (check fname))
 197
 198         val inf = TextIO.openIn fname
 199
 200         fun loop lines =
 201             case TextIO.inputLine inf of
 202                 NONE => String.concat (List.rev lines)
 203               | SOME line => loop (line :: lines)
 204
 205         val code = loop []
 206     in
 207         TextIO.closeIn inf;
 208         Msg.send (bio, MsgConfig code);
 209         case Msg.recv bio of
 210             NONE => print "Server closed connection unexpectedly.\n"
 211           | SOME m =>
 212             case m of
 213                 MsgOk => print "Configuration succeeded.\n"
 214               | MsgError s => print ("Configuration failed: " ^ s ^ "\n")
 215               | _ => print "Unexpected server reply.\n";
 216         OpenSSL.close bio
 217     end
 218     handle ErrorMsg.Error => ()
 219
 220 fun requestDir dname =
 221     let
 222         val _ = ErrorMsg.reset ()
 223
 224         val (user, bio) = requestBio (fn () => checkDir dname)
 225
 226         val b = basis ()
 227
 228         val dir = Posix.FileSys.opendir dname
 229
 230         fun loop files =
 231             case Posix.FileSys.readdir dir of
 232                 NONE => (Posix.FileSys.closedir dir;
 233                          files)
 234               | SOME fname =>
 235                 if notTmp fname then
 236                     loop (OS.Path.joinDirFile {dir = dname,
 237                                                file = fname}
 238                           :: files)
 239                 else
 240                     loop files
 241
 242         val files = loop []
 243         val (_, files) = Order.order (SOME b) files
 244
 245         val _ = if !ErrorMsg.anyErrors then
 246                     raise ErrorMsg.Error
 247                 else
 248                     ()
 249
 250         val codes = map (fn fname =>
 251                             let
 252                                 val inf = TextIO.openIn fname
 253
 254                                 fun loop lines =
 255                                     case TextIO.inputLine inf of
 256                                         NONE => String.concat (rev lines)
 257                                       | SOME line => loop (line :: lines)
 258                             in
 259                                 loop []
 260                                 before TextIO.closeIn inf
 261                             end) files
 262     in
 263         if !ErrorMsg.anyErrors then
 264             ()
 265         else
 266             (Msg.send (bio, MsgMultiConfig codes);
 267              case Msg.recv bio of
 268                  NONE => print "Server closed connection unexpectedly.\n"
 269                | SOME m =>
 270                  case m of
 271                      MsgOk => print "Configuration succeeded.\n"
 272                    | MsgError s => print ("Configuration failed: " ^ s ^ "\n")
 273                    | _ => print "Unexpected server reply.\n";
 274              OpenSSL.close bio)
 275     end
 276     handle ErrorMsg.Error => ()
 277
 278 fun requestGrant acl =
 279     let
 280         val (user, bio) = requestBio (fn () => ())
 281     in
 282         Msg.send (bio, MsgGrant acl);
 283         case Msg.recv bio of
 284             NONE => print "Server closed connection unexpectedly.\n"
 285           | SOME m =>
 286             case m of
 287                 MsgOk => print "Grant succeeded.\n"
 288               | MsgError s => print ("Grant failed: " ^ s ^ "\n")
 289               | _ => print "Unexpected server reply.\n";
 290         OpenSSL.close bio
 291     end
 292
 293 fun requestRevoke acl =
 294     let
 295         val (user, bio) = requestBio (fn () => ())
 296     in
 297         Msg.send (bio, MsgRevoke acl);
 298         case Msg.recv bio of
 299             NONE => print "Server closed connection unexpectedly.\n"
 300           | SOME m =>
 301             case m of
 302                 MsgOk => print "Revoke succeeded.\n"
 303               | MsgError s => print ("Revoke failed: " ^ s ^ "\n")
 304               | _ => print "Unexpected server reply.\n";
 305         OpenSSL.close bio
 306     end
 307
 308 fun requestListPerms user =
 309     let
 310         val (_, bio) = requestBio (fn () => ())
 311     in
 312         Msg.send (bio, MsgListPerms user);
 313         (case Msg.recv bio of
 314              NONE => (print "Server closed connection unexpectedly.\n";
 315                       NONE)
 316            | SOME m =>
 317              case m of
 318                  MsgPerms perms => SOME perms
 319                | MsgError s => (print ("Listing failed: " ^ s ^ "\n");
 320                                 NONE)
 321                | _ => (print "Unexpected server reply.\n";
 322                        NONE))
 323         before OpenSSL.close bio
 324     end
 325
 326 fun requestWhoHas perm =
 327     let
 328         val (_, bio) = requestBio (fn () => ())
 329     in
 330         Msg.send (bio, MsgWhoHas perm);
 331         (case Msg.recv bio of
 332              NONE => (print "Server closed connection unexpectedly.\n";
 333                       NONE)
 334            | SOME m =>
 335              case m of
 336                  MsgWhoHasResponse users => SOME users
 337                | MsgError s => (print ("whohas failed: " ^ s ^ "\n");
 338                                 NONE)
 339                | _ => (print "Unexpected server reply.\n";
 340                        NONE))
 341         before OpenSSL.close bio
 342     end
 343
 344 fun requestRegen () =
 345     let
 346         val (_, bio) = requestBio (fn () => ())
 347     in
 348         Msg.send (bio, MsgRegenerate);
 349         case Msg.recv bio of
 350             NONE => print "Server closed connection unexpectedly.\n"
 351           | SOME m =>
 352             case m of
 353                 MsgOk => print "Regeneration succeeded.\n"
 354               | MsgError s => print ("Regeneration failed: " ^ s ^ "\n")
 355               | _ => print "Unexpected server reply.\n";
 356         OpenSSL.close bio
 357     end
 358
 359 fun requestRmdom dom =
 360     let
 361         val (_, bio) = requestBio (fn () => ())
 362     in
 363         Msg.send (bio, MsgRmdom dom);
 364         case Msg.recv bio of
 365             NONE => print "Server closed connection unexpectedly.\n"
 366           | SOME m =>
 367             case m of
 368                 MsgOk => print "Removal succeeded.\n"
 369               | MsgError s => print ("Removal failed: " ^ s ^ "\n")
 370               | _ => print "Unexpected server reply.\n";
 371         OpenSSL.close bio
 372     end
 373
 374 fun requestRmuser user =
 375     let
 376         val (_, bio) = requestBio (fn () => ())
 377     in
 378         Msg.send (bio, MsgRmuser user);
 379         case Msg.recv bio of
 380             NONE => print "Server closed connection unexpectedly.\n"
 381           | SOME m =>
 382             case m of
 383                 MsgOk => print "Removal succeeded.\n"
 384               | MsgError s => print ("Removal failed: " ^ s ^ "\n")
 385               | _ => print "Unexpected server reply.\n";
 386         OpenSSL.close bio
 387     end
 388
 389 fun requestDbUser dbtype =
 390     let
 391         val (_, bio) = requestBio (fn () => ())
 392     in
 393         Msg.send (bio, MsgCreateDbUser dbtype);
 394         case Msg.recv bio of
 395             NONE => print "Server closed connection unexpectedly.\n"
 396           | SOME m =>
 397             case m of
 398                 MsgOk => print "Your user has been created.\n"
 399               | MsgError s => print ("Creation failed: " ^ s ^ "\n")
 400               | _ => print "Unexpected server reply.\n";
 401         OpenSSL.close bio
 402     end
 403
 404 fun requestDbTable p =
 405     let
 406         val (user, bio) = requestBio (fn () => ())
 407     in
 408         Msg.send (bio, MsgCreateDbTable p);
 409         case Msg.recv bio of
 410             NONE => print "Server closed connection unexpectedly.\n"
 411           | SOME m =>
 412             case m of
 413                 MsgOk => print ("Your database " ^ user ^ "_" ^ #dbname p ^ " has been created.\n")
 414               | MsgError s => print ("Creation failed: " ^ s ^ "\n")
 415               | _ => print "Unexpected server reply.\n";
 416         OpenSSL.close bio
 417     end
 418
 419 fun regenerate context =
 420     let
 421         val b = basis ()
 422         val () = Tycheck.disallowExterns ()
 423
 424         val () = Domain.resetGlobal ()
 425
 426         fun contactNode (node, ip) =
 427             if node = Config.defaultNode then
 428                 Domain.resetLocal ()
 429             else let
 430                     val bio = OpenSSL.connect (context,
 431                                                ip
 432                                                ^ ":"
 433                                                ^ Int.toString Config.slavePort)
 434                 in
 435                     Msg.send (bio, MsgRegenerate);
 436                     case Msg.recv bio of
 437                         NONE => print "Slave closed connection unexpectedly\n"
 438                       | SOME m =>
 439                         case m of
 440                             MsgOk => print ("Slave " ^ node ^ " pre-regeneration finished\n")
 441                           | MsgError s => print ("Slave " ^ node
 442                                                  ^ " returned error: " ^
 443                                                  s ^ "\n")
 444                           | _ => print ("Slave " ^ node
 445                                         ^ " returned unexpected command\n");
 446                     OpenSSL.close bio
 447                 end
 448
 449         fun doUser user =
 450             let
 451                 val _ = Domain.setUser user
 452                 val _ = ErrorMsg.reset ()
 453
 454                 val dname = Config.domtoolDir user
 455
 456                 val dir = Posix.FileSys.opendir dname
 457
 458                 fun loop files =
 459                     case Posix.FileSys.readdir dir of
 460                         NONE => (Posix.FileSys.closedir dir;
 461                                  files)
 462                       | SOME fname =>
 463                         if notTmp fname then
 464                             loop (OS.Path.joinDirFile {dir = dname,
 465                                                        file = fname}
 466                                   :: files)
 467                         else
 468                             loop files
 469
 470                 val files = loop []
 471                 val (_, files) = Order.order (SOME b) files
 472             in
 473                 if !ErrorMsg.anyErrors then
 474                     print ("User " ^ user ^ "'s configuration has errors!\n")
 475                 else
 476                     app eval' files
 477             end
 478                 handle IO.Io _ => ()
 479                      | OS.SysErr (s, _) => print ("System error processing user " ^ user ^ ": " ^ s ^ "\n")
 480     in
 481         app contactNode Config.nodeIps;
 482         Env.pre ();
 483         app doUser (Acl.users ());
 484         Env.post ()
 485     end
 486
 487 fun rmuser user =
 488     let
 489         val doms = Acl.class {user = user, class = "domain"}
 490         val doms = List.filter (fn dom =>
 491                                    case Acl.whoHas {class = "domain", value = dom} of
 492                                        [_] => true
 493                                      | _ => false) (StringSet.listItems doms)
 494     in
 495         Acl.rmuser user;
 496         Domain.rmdom doms
 497     end
 498
 499 fun service () =
 500     let
 501         val () = Acl.read Config.aclFile
 502
 503         val context = OpenSSL.context (Config.serverCert,
 504                                        Config.serverKey,
 505                                        Config.trustStore)
 506         val _ = Domain.set_context context
 507
 508         val sock = OpenSSL.listen (context, Config.dispatcherPort)
 509
 510         fun loop () =
 511             case OpenSSL.accept sock of
 512                 NONE => ()
 513               | SOME bio =>
 514                 let
 515                     val user = OpenSSL.peerCN bio
 516                     val () = print ("\nConnection from " ^ user ^ "\n")
 517                     val () = Domain.setUser user
 518
 519                     fun doConfig codes =
 520                         let
 521                             val _ = print "Configuration:\n"
 522                             val _ = app (fn s => (print s; print "\n")) codes
 523                             val _ = print "\n"
 524
 525                             val outname = OS.FileSys.tmpName ()
 526
 527                             fun doOne code =
 528                                 let
 529                                     val outf = TextIO.openOut outname
 530                                 in
 531                                     TextIO.output (outf, code);
 532                                     TextIO.closeOut outf;
 533                                     eval' outname
 534                                 end
 535                         in
 536                             (Env.pre ();
 537                              app doOne codes;
 538                              Env.post ();
 539                              Msg.send (bio, MsgOk))
 540                             handle ErrorMsg.Error =>
 541                                    (print "Compilation error\n";
 542                                     Msg.send (bio,
 543                                               MsgError "Error during configuration evaluation"))
 544                                  | OpenSSL.OpenSSL s =>
 545                                    (print "OpenSSL error\n";
 546                                     Msg.send (bio,
 547                                               MsgError
 548                                                   ("Error during configuration evaluation: "
 549                                                    ^ s)));
 550                            OS.FileSys.remove outname;
 551                            (ignore (OpenSSL.readChar bio);
 552                             OpenSSL.close bio)
 553                            handle OpenSSL.OpenSSL _ => ();
 554                            loop ()
 555                         end
 556
 557                     fun cmdLoop () =
 558                         case Msg.recv bio of
 559                             NONE => (OpenSSL.close bio
 560                                      handle OpenSSL.OpenSSL _ => ();
 561                                      loop ())
 562                           | SOME m =>
 563                             case m of
 564                                 MsgConfig code => doConfig [code]
 565                               | MsgMultiConfig codes => doConfig codes
 566
 567                               | MsgGrant acl =>
 568                                 if Acl.query {user = user, class = "priv", value = "all"} then
 569                                     ((Acl.grant acl;
 570                                       Acl.write Config.aclFile;
 571                                       Msg.send (bio, MsgOk);
 572                                       print ("Granted permission " ^ #value acl ^ " to " ^ #user acl ^ " in " ^ #class acl ^ ".\n"))
 573                                      handle OpenSSL.OpenSSL s =>
 574                                             (print "OpenSSL error\n";
 575                                              Msg.send (bio,
 576                                                        MsgError
 577                                                            ("Error during granting: "
 578                                                             ^ s)));
 579                                     (ignore (OpenSSL.readChar bio);
 580                                      OpenSSL.close bio)
 581                                     handle OpenSSL.OpenSSL _ => ();
 582                                     loop ())
 583                                 else
 584                                     ((Msg.send (bio, MsgError "Not authorized to grant privileges");
 585                                       print "Unauthorized user asked to grant a permission!\n";
 586                                       ignore (OpenSSL.readChar bio);
 587                                       OpenSSL.close bio)
 588                                      handle OpenSSL.OpenSSL _ => ();
 589                                      loop ())
 590
 591                               | MsgRevoke acl =>
 592                                 if Acl.query {user = user, class = "priv", value = "all"} then
 593                                     ((Acl.revoke acl;
 594                                       Acl.write Config.aclFile;
 595                                       Msg.send (bio, MsgOk);
 596                                       print ("Revoked permission " ^ #value acl ^ " from " ^ #user acl ^ " in " ^ #class acl ^ ".\n"))
 597                                      handle OpenSSL.OpenSSL s =>
 598                                             (print "OpenSSL error\n";
 599                                              Msg.send (bio,
 600                                                        MsgError
 601                                                            ("Error during revocation: "
 602                                                             ^ s)));
 603                                     (ignore (OpenSSL.readChar bio);
 604                                      OpenSSL.close bio)
 605                                     handle OpenSSL.OpenSSL _ => ();
 606                                     loop ())
 607                                 else
 608                                     ((Msg.send (bio, MsgError "Not authorized to revoke privileges");
 609                                       print "Unauthorized user asked to revoke a permission!\n";
 610                                       ignore (OpenSSL.readChar bio);
 611                                       OpenSSL.close bio)
 612                                      handle OpenSSL.OpenSSL _ => ();
 613                                      loop ())
 614
 615                               | MsgListPerms user =>
 616                                 ((Msg.send (bio, MsgPerms (Acl.queryAll user));
 617                                   print ("Sent permission list for user " ^ user ^ ".\n"))
 618                                  handle OpenSSL.OpenSSL s =>
 619                                         (print "OpenSSL error\n";
 620                                          Msg.send (bio,
 621                                                    MsgError
 622                                                        ("Error during permission listing: "
 623                                                         ^ s)));
 624                                 (ignore (OpenSSL.readChar bio);
 625                                  OpenSSL.close bio)
 626                                 handle OpenSSL.OpenSSL _ => ();
 627                                 loop ())
 628
 629                               | MsgWhoHas perm =>
 630                                 ((Msg.send (bio, MsgWhoHasResponse (Acl.whoHas perm));
 631                                   print ("Sent whohas response for " ^ #class perm ^ " / " ^ #value perm ^ ".\n"))
 632                                  handle OpenSSL.OpenSSL s =>
 633                                         (print "OpenSSL error\n";
 634                                          Msg.send (bio,
 635                                                    MsgError
 636                                                        ("Error during whohas: "
 637                                                         ^ s)));
 638                                 (ignore (OpenSSL.readChar bio);
 639                                  OpenSSL.close bio)
 640                                 handle OpenSSL.OpenSSL _ => ();
 641                                 loop ())
 642
 643                               | MsgRmdom doms =>
 644                                 if Acl.query {user = user, class = "priv", value = "all"}
 645                                    orelse List.all (fn dom => Acl.query {user = user, class = "domain", value = dom}) doms then
 646                                     ((Domain.rmdom doms;
 647                                       app (fn dom =>
 648                                               Acl.revokeFromAll {class = "domain", value = dom}) doms;
 649                                       Acl.write Config.aclFile;
 650                                       Msg.send (bio, MsgOk);
 651                                       print ("Removed domains" ^ foldl (fn (d, s) => s ^ " " ^ d) "" doms ^ ".\n"))
 652                                      handle OpenSSL.OpenSSL s =>
 653                                             (print "OpenSSL error\n";
 654                                              Msg.send (bio,
 655                                                        MsgError
 656                                                            ("Error during revocation: "
 657                                                             ^ s)));
 658                                     (ignore (OpenSSL.readChar bio);
 659                                      OpenSSL.close bio)
 660                                     handle OpenSSL.OpenSSL _ => ();
 661                                     loop ())
 662                                 else
 663                                     ((Msg.send (bio, MsgError "Not authorized to remove that domain");
 664                                       print "Unauthorized user asked to remove a domain!\n";
 665                                       ignore (OpenSSL.readChar bio);
 666                                       OpenSSL.close bio)
 667                                      handle OpenSSL.OpenSSL _ => ();
 668                                      loop ())
 669
 670                               | MsgRegenerate =>
 671                                 if Acl.query {user = user, class = "priv", value = "regen"}
 672                                    orelse Acl.query {user = user, class = "priv", value = "all"} then
 673                                     ((regenerate context;
 674                                       Msg.send (bio, MsgOk);
 675                                       print "Regenerated all configuration.\n")
 676                                      handle OpenSSL.OpenSSL s =>
 677                                             (print "OpenSSL error\n";
 678                                              Msg.send (bio,
 679                                                        MsgError
 680                                                            ("Error during regeneration: "
 681                                                             ^ s)));
 682                                     (ignore (OpenSSL.readChar bio);
 683                                      OpenSSL.close bio)
 684                                     handle OpenSSL.OpenSSL _ => ();
 685                                     loop ())
 686                                 else
 687                                     ((Msg.send (bio, MsgError "Not authorized to regeneration");
 688                                       print "Unauthorized user asked to regenerate!\n";
 689                                       ignore (OpenSSL.readChar bio);
 690                                       OpenSSL.close bio)
 691                                      handle OpenSSL.OpenSSL _ => ();
 692                                      loop ())
 693
 694                               | MsgRmuser user' =>
 695                                 if Acl.query {user = user, class = "priv", value = "all"} then
 696                                     ((rmuser user';
 697                                       Acl.write Config.aclFile;
 698                                       Msg.send (bio, MsgOk);
 699                                       print ("Removed user " ^ user' ^ ".\n"))
 700                                      handle OpenSSL.OpenSSL s =>
 701                                             (print "OpenSSL error\n";
 702                                              Msg.send (bio,
 703                                                        MsgError
 704                                                            ("Error during revocation: "
 705                                                             ^ s)));
 706                                     (ignore (OpenSSL.readChar bio);
 707                                      OpenSSL.close bio)
 708                                     handle OpenSSL.OpenSSL _ => ();
 709                                     loop ())
 710                                 else
 711                                     ((Msg.send (bio, MsgError "Not authorized to remove users");
 712                                       print "Unauthorized user asked to remove a user!\n";
 713                                       ignore (OpenSSL.readChar bio);
 714                                       OpenSSL.close bio)
 715                                      handle OpenSSL.OpenSSL _ => ();
 716                                      loop ())
 717
 718                               | MsgCreateDbUser dbtype =>
 719                                 (case Dbms.lookup dbtype of
 720                                      NONE => ((Msg.send (bio, MsgError ("Unknown database type " ^ dbtype));
 721                                                print ("Database user creation request with unknown datatype type " ^ dbtype);
 722                                                ignore (OpenSSL.readChar bio))
 723                                               handle OpenSSL.OpenSSL _ => ();
 724                                               OpenSSL.close bio
 725                                               handle OpenSSL.OpenSSL _ => ();
 726                                               loop ())
 727                                    | SOME handler =>
 728                                      case #adduser handler user of
 729                                          NONE => ((Msg.send (bio, MsgOk);
 730                                                    print ("Added " ^ dbtype ^ " user " ^ user ^ ".\n"))
 731                                                   handle OpenSSL.OpenSSL s =>
 732                                                          (print "OpenSSL error\n";
 733                                                           Msg.send (bio,
 734                                                                     MsgError
 735                                                                         ("Error during creation: "
 736                                                                          ^ s)));
 737                                                   (ignore (OpenSSL.readChar bio);
 738                                                    OpenSSL.close bio)
 739                                                   handle OpenSSL.OpenSSL _ => ();
 740                                                   loop ())
 741                                        | SOME msg => ((Msg.send (bio, MsgError ("Error adding user: " ^ msg));
 742                                                        print ("Error adding a " ^ dbtype ^ " user " ^ user ^ ": " ^ msg ^ "\n");
 743                                                        ignore (OpenSSL.readChar bio);
 744                                                        OpenSSL.close bio)
 745                                                       handle OpenSSL.OpenSSL _ => ();
 746                                                       loop ()))
 747
 748                               | MsgCreateDbTable {dbtype, dbname} =>
 749                                 if Dbms.validDbname dbname then
 750                                     (case Dbms.lookup dbtype of
 751                                          NONE => ((Msg.send (bio, MsgError ("Unknown database type " ^ dbtype));
 752                                                    print ("Database creation request with unknown datatype type " ^ dbtype);
 753                                                    ignore (OpenSSL.readChar bio))
 754                                                   handle OpenSSL.OpenSSL _ => ();
 755                                                   OpenSSL.close bio
 756                                                   handle OpenSSL.OpenSSL _ => ();
 757                                                   loop ())
 758                                        | SOME handler =>
 759                                          case #createdb handler {user = user, dbname = dbname} of
 760                                              NONE => ((Msg.send (bio, MsgOk);
 761                                                        print ("Created database " ^ user ^ "_" ^ dbname ^ ".\n"))
 762                                                       handle OpenSSL.OpenSSL s =>
 763                                                              (print "OpenSSL error\n";
 764                                                               Msg.send (bio,
 765                                                                         MsgError
 766                                                                             ("Error during creation: "
 767                                                                              ^ s)));
 768                                                       (ignore (OpenSSL.readChar bio);
 769                                                        OpenSSL.close bio)
 770                                                       handle OpenSSL.OpenSSL _ => ();
 771                                                       loop ())
 772                                            | SOME msg => ((Msg.send (bio, MsgError ("Error creating database: " ^ msg));
 773                                                            print ("Error creating database " ^ user ^ "_" ^ dbname ^ ": " ^ msg ^ "\n");
 774                                                            ignore (OpenSSL.readChar bio);
 775                                                            OpenSSL.close bio)
 776                                                           handle OpenSSL.OpenSSL _ => ();
 777                                                           loop ()))
 778                                 else
 779                                     ((Msg.send (bio, MsgError ("Invalid database name " ^ dbname));
 780                                       print ("Invalid database name " ^ user ^ "_" ^ dbname ^ "\n");
 781                                       ignore (OpenSSL.readChar bio);
 782                                       OpenSSL.close bio)
 783                                      handle OpenSSL.OpenSSL _ => ();
 784                                      loop ())
 785
 786                               | _ =>
 787                                 (Msg.send (bio, MsgError "Unexpected command")
 788                                  handle OpenSSL.OpenSSL _ => ();
 789                                  OpenSSL.close bio
 790                                  handle OpenSSL.OpenSSL _ => ();
 791                                  loop ())
 792                 in
 793                     cmdLoop ()
 794                 end
 795                     handle OpenSSL.OpenSSL s =>
 796                            (print ("OpenSSL error: " ^ s ^ "\n");
 797                             OpenSSL.close bio
 798                             handle OpenSSL.OpenSSL _ => ();
 799                             loop ())
 800                          | OS.SysErr (s, _) =>
 801                            (print ("System error: " ^ s ^ "\n");
 802                             OpenSSL.close bio
 803                             handle OpenSSL.OpenSSL _ => ();
 804                             loop ())
 805     in
 806         print "Listening for connections....\n";
 807         loop ();
 808         OpenSSL.shutdown sock
 809     end
 810
 811 fun slave () =
 812     let
 813         val host = Slave.hostname ()
 814
 815         val context = OpenSSL.context (Config.certDir ^ "/" ^ host ^ ".pem",
 816                                        Config.keyDir ^ "/" ^ host ^ "/key.pem",
 817                                        Config.trustStore)
 818
 819         val sock = OpenSSL.listen (context, Config.slavePort)
 820
 821         fun loop () =
 822             case OpenSSL.accept sock of
 823                 NONE => ()
 824               | SOME bio =>
 825                 let
 826                     val peer = OpenSSL.peerCN bio
 827                     val () = print ("\nConnection from " ^ peer ^ "\n")
 828                 in
 829                     if peer <> Config.dispatcherName then
 830                         (print "Not authorized!\n";
 831                          OpenSSL.close bio;
 832                          loop ())
 833                     else let
 834                             fun loop' files =
 835                                 case Msg.recv bio of
 836                                     NONE => print "Dispatcher closed connection unexpectedly\n"
 837                                   | SOME m =>
 838                                     case m of
 839                                         MsgFile file => loop' (file :: files)
 840                                       | MsgDoFiles => (Slave.handleChanges files;
 841                                                        Msg.send (bio, MsgOk))
 842                                       | MsgRegenerate => (Domain.resetLocal ();
 843                                                           Msg.send (bio, MsgOk))
 844                                       | _ => (print "Dispatcher sent unexpected command\n";
 845                                               Msg.send (bio, MsgError "Unexpected command"))
 846                         in
 847                             loop' [];
 848                             ignore (OpenSSL.readChar bio);
 849                             OpenSSL.close bio;
 850                             loop ()
 851                         end
 852                 end handle OpenSSL.OpenSSL s =>
 853                            (print ("OpenSSL error: "^ s ^ "\n");
 854                             OpenSSL.close bio
 855                                           handle OpenSSL.OpenSSL _ => ();
 856                             loop ())
 857                          | OS.SysErr (s, _) =>
 858                            (print ("System error: "^ s ^ "\n");
 859                             OpenSSL.close bio
 860                             handle OpenSSL.OpenSSL _ => ();
 861                             loop ())
 862     in
 863         loop ();
 864         OpenSSL.shutdown sock
 865     end
 866
 867 fun listBasis () =
 868     let
 869         val dir = Posix.FileSys.opendir Config.libRoot
 870
 871         fun loop files =
 872             case Posix.FileSys.readdir dir of
 873                 NONE => (Posix.FileSys.closedir dir;
 874                          files)
 875               | SOME fname =>
 876                 if String.isSuffix ".dtl" fname then
 877                     loop (OS.Path.joinDirFile {dir = Config.libRoot,
 878                                                file = fname}
 879                           :: files)
 880                 else
 881                     loop files
 882     in
 883         loop []
 884     end
 885
 886 fun autodocBasis outdir =
 887     Autodoc.autodoc {outdir = outdir, infiles = listBasis ()}
 888
 889 end