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