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             false
 120         else
 121             (foldl (fn (fname, G) => check' G fname) b files;
 122              !ErrorMsg.anyErrors)
 123     end
 124
 125 fun reduce fname =
 126     let
 127         val (G, body) = check fname
 128     in
 129         if !ErrorMsg.anyErrors then
 130             NONE
 131         else
 132             case body of
 133                 SOME body =>
 134                 let
 135                     val body' = Reduce.reduceExp G body
 136                 in
 137                     (*printd (PD.hovBox (PD.PPS.Rel 0,
 138                                          [PD.string "Result:",
 139                                           PD.space 1,
 140                                           p_exp body']))*)
 141                     SOME body'
 142                 end
 143               | _ => NONE
 144     end
 145
 146 fun eval fname =
 147     case reduce fname of
 148         (SOME body') =>
 149         if !ErrorMsg.anyErrors then
 150             raise ErrorMsg.Error
 151         else
 152             Eval.exec (Defaults.eInit ()) body'
 153       | NONE => raise ErrorMsg.Error
 154
 155 val dispatcher =
 156     Config.dispatcher ^ ":" ^ Int.toString Config.dispatcherPort
 157
 158 fun requestContext f =
 159     let
 160         val uid = Posix.ProcEnv.getuid ()
 161         val user = Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid uid)
 162
 163         val () = Acl.read Config.aclFile
 164         val () = Domain.setUser user
 165
 166         val () = f ()
 167
 168         val context = OpenSSL.context (Config.certDir ^ "/" ^ user ^ ".pem",
 169                                        Config.keyDir ^ "/" ^ user ^ "/key.pem",
 170                                        Config.trustStore)
 171     in
 172         (user, context)
 173     end
 174
 175 fun requestBio f =
 176     let
 177         val (user, context) = requestContext f
 178     in
 179         (user, OpenSSL.connect (context, dispatcher))
 180     end
 181
 182 fun request fname =
 183     let
 184         val (user, bio) = requestBio (fn () => ignore (check fname))
 185
 186         val inf = TextIO.openIn fname
 187
 188         fun loop lines =
 189             case TextIO.inputLine inf of
 190                 NONE => String.concat (List.rev lines)
 191               | SOME line => loop (line :: lines)
 192
 193         val code = loop []
 194     in
 195         TextIO.closeIn inf;
 196         Msg.send (bio, MsgConfig code);
 197         case Msg.recv bio of
 198             NONE => print "Server closed connection unexpectedly.\n"
 199           | SOME m =>
 200             case m of
 201                 MsgOk => print "Configuration succeeded.\n"
 202               | MsgError s => print ("Configuration failed: " ^ s ^ "\n")
 203               | _ => print "Unexpected server reply.\n";
 204         OpenSSL.close bio
 205     end
 206     handle ErrorMsg.Error => ()
 207
 208 fun requestDir dname =
 209     let
 210         val (user, bio) = requestBio (fn () => ignore (checkDir dname))
 211
 212         val b = basis ()
 213
 214         val dir = Posix.FileSys.opendir dname
 215
 216         fun loop files =
 217             case Posix.FileSys.readdir dir of
 218                 NONE => (Posix.FileSys.closedir dir;
 219                          files)
 220               | SOME fname =>
 221                 if notTmp fname then
 222                     loop (OS.Path.joinDirFile {dir = dname,
 223                                                file = fname}
 224                           :: files)
 225                 else
 226                     loop files
 227
 228         val files = loop []
 229         val (_, files) = Order.order (SOME b) files
 230
 231         val _ = if !ErrorMsg.anyErrors then
 232                     raise ErrorMsg.Error
 233                 else
 234                     ()
 235
 236         val codes = map (fn fname =>
 237                             let
 238                                 val inf = TextIO.openIn fname
 239
 240                                 fun loop lines =
 241                                     case TextIO.inputLine inf of
 242                                         NONE => String.concat (rev lines)
 243                                       | SOME line => loop (line :: lines)
 244                             in
 245                                 loop []
 246                                 before TextIO.closeIn inf
 247                             end) files
 248     in
 249         Msg.send (bio, MsgMultiConfig codes);
 250         case Msg.recv bio of
 251             NONE => print "Server closed connection unexpectedly.\n"
 252           | SOME m =>
 253             case m of
 254                 MsgOk => print "Configuration succeeded.\n"
 255               | MsgError s => print ("Configuration failed: " ^ s ^ "\n")
 256               | _ => print "Unexpected server reply.\n";
 257         OpenSSL.close bio
 258     end
 259     handle ErrorMsg.Error => ()
 260
 261 fun requestGrant acl =
 262     let
 263         val (user, bio) = requestBio (fn () => ())
 264     in
 265         Msg.send (bio, MsgGrant acl);
 266         case Msg.recv bio of
 267             NONE => print "Server closed connection unexpectedly.\n"
 268           | SOME m =>
 269             case m of
 270                 MsgOk => print "Grant succeeded.\n"
 271               | MsgError s => print ("Grant failed: " ^ s ^ "\n")
 272               | _ => print "Unexpected server reply.\n";
 273         OpenSSL.close bio
 274     end
 275
 276 fun requestRevoke acl =
 277     let
 278         val (user, bio) = requestBio (fn () => ())
 279     in
 280         Msg.send (bio, MsgRevoke acl);
 281         case Msg.recv bio of
 282             NONE => print "Server closed connection unexpectedly.\n"
 283           | SOME m =>
 284             case m of
 285                 MsgOk => print "Revoke succeeded.\n"
 286               | MsgError s => print ("Revoke failed: " ^ s ^ "\n")
 287               | _ => print "Unexpected server reply.\n";
 288         OpenSSL.close bio
 289     end
 290
 291 fun requestListPerms user =
 292     let
 293         val (_, bio) = requestBio (fn () => ())
 294     in
 295         Msg.send (bio, MsgListPerms user);
 296         (case Msg.recv bio of
 297              NONE => (print "Server closed connection unexpectedly.\n";
 298                       NONE)
 299            | SOME m =>
 300              case m of
 301                  MsgPerms perms => SOME perms
 302                | MsgError s => (print ("Listing failed: " ^ s ^ "\n");
 303                                 NONE)
 304                | _ => (print "Unexpected server reply.\n";
 305                        NONE))
 306         before OpenSSL.close bio
 307     end
 308
 309 fun requestWhoHas perm =
 310     let
 311         val (_, bio) = requestBio (fn () => ())
 312     in
 313         Msg.send (bio, MsgWhoHas perm);
 314         (case Msg.recv bio of
 315              NONE => (print "Server closed connection unexpectedly.\n";
 316                       NONE)
 317            | SOME m =>
 318              case m of
 319                  MsgWhoHasResponse users => SOME users
 320                | MsgError s => (print ("whohas failed: " ^ s ^ "\n");
 321                                 NONE)
 322                | _ => (print "Unexpected server reply.\n";
 323                        NONE))
 324         before OpenSSL.close bio
 325     end
 326
 327 fun requestRmdom dom =
 328     let
 329         val (_, bio) = requestBio (fn () => ())
 330     in
 331         Msg.send (bio, MsgRmdom dom);
 332         case Msg.recv bio of
 333             NONE => print "Server closed connection unexpectedly.\n"
 334           | SOME m =>
 335             case m of
 336                 MsgOk => print "Removal succeeded.\n"
 337               | MsgError s => print ("Removal failed: " ^ s ^ "\n")
 338               | _ => print "Unexpected server reply.\n";
 339         OpenSSL.close bio
 340     end
 341
 342 fun service () =
 343     let
 344         val () = Acl.read Config.aclFile
 345
 346         val context = OpenSSL.context (Config.serverCert,
 347                                        Config.serverKey,
 348                                        Config.trustStore)
 349         val _ = Domain.set_context context
 350
 351         val sock = OpenSSL.listen (context, Config.dispatcherPort)
 352
 353         fun loop () =
 354             case OpenSSL.accept sock of
 355                 NONE => ()
 356               | SOME bio =>
 357                 let
 358                     val user = OpenSSL.peerCN bio
 359                     val () = print ("\nConnection from " ^ user ^ "\n")
 360                     val () = Domain.setUser user
 361
 362                     fun doConfig codes =
 363                         let
 364                             val _ = print "Configuration:\n"
 365                             val _ = app (fn s => (print s; print "\n")) codes
 366                             val _ = print "\n"
 367
 368                             val outname = OS.FileSys.tmpName ()
 369
 370                             fun doOne code =
 371                                 let
 372                                     val outf = TextIO.openOut outname
 373                                 in
 374                                     TextIO.output (outf, code);
 375                                     TextIO.closeOut outf;
 376                                     eval outname
 377                                 end
 378                         in
 379                             (app doOne codes;
 380                              Msg.send (bio, MsgOk))
 381                             handle ErrorMsg.Error =>
 382                                    (print "Compilation error\n";
 383                                     Msg.send (bio,
 384                                               MsgError "Error during configuration evaluation"))
 385                                  | OpenSSL.OpenSSL s =>
 386                                    (print "OpenSSL error\n";
 387                                     Msg.send (bio,
 388                                               MsgError
 389                                                   ("Error during configuration evaluation: "
 390                                                    ^ s)));
 391                            OS.FileSys.remove outname;
 392                            (ignore (OpenSSL.readChar bio);
 393                             OpenSSL.close bio)
 394                            handle OpenSSL.OpenSSL _ => ();
 395                            loop ()
 396                         end
 397
 398                     fun cmdLoop () =
 399                         case Msg.recv bio of
 400                             NONE => (OpenSSL.close bio
 401                                      handle OpenSSL.OpenSSL _ => ();
 402                                      loop ())
 403                           | SOME m =>
 404                             case m of
 405                                 MsgConfig code => doConfig [code]
 406                               | MsgMultiConfig codes => doConfig codes
 407
 408                               | MsgGrant acl =>
 409                                 if Acl.query {user = user, class = "priv", value = "all"} then
 410                                     ((Acl.grant acl;
 411                                       Acl.write Config.aclFile;
 412                                       Msg.send (bio, MsgOk);
 413                                       print ("Granted permission " ^ #value acl ^ " to " ^ #user acl ^ " in " ^ #class acl ^ ".\n"))
 414                                      handle OpenSSL.OpenSSL s =>
 415                                             (print "OpenSSL error\n";
 416                                              Msg.send (bio,
 417                                                        MsgError
 418                                                            ("Error during granting: "
 419                                                             ^ s)));
 420                                     (ignore (OpenSSL.readChar bio);
 421                                      OpenSSL.close bio)
 422                                     handle OpenSSL.OpenSSL _ => ();
 423                                     loop ())
 424                                 else
 425                                     ((Msg.send (bio, MsgError "Not authorized to grant privileges");
 426                                       print "Unauthorized user asked to grant a permission!\n";
 427                                       ignore (OpenSSL.readChar bio);
 428                                       OpenSSL.close bio)
 429                                      handle OpenSSL.OpenSSL _ => ();
 430                                      loop ())
 431
 432                               | MsgRevoke acl =>
 433                                 if Acl.query {user = user, class = "priv", value = "all"} then
 434                                     ((Acl.revoke acl;
 435                                       Acl.write Config.aclFile;
 436                                       Msg.send (bio, MsgOk);
 437                                       print ("Revoked permission " ^ #value acl ^ " from " ^ #user acl ^ " in " ^ #class acl ^ ".\n"))
 438                                      handle OpenSSL.OpenSSL s =>
 439                                             (print "OpenSSL error\n";
 440                                              Msg.send (bio,
 441                                                        MsgError
 442                                                            ("Error during revocation: "
 443                                                             ^ s)));
 444                                     (ignore (OpenSSL.readChar bio);
 445                                      OpenSSL.close bio)
 446                                     handle OpenSSL.OpenSSL _ => ();
 447                                     loop ())
 448                                 else
 449                                     ((Msg.send (bio, MsgError "Not authorized to revoke privileges");
 450                                       print "Unauthorized user asked to revoke a permission!\n";
 451                                       ignore (OpenSSL.readChar bio);
 452                                       OpenSSL.close bio)
 453                                      handle OpenSSL.OpenSSL _ => ();
 454                                      loop ())
 455
 456                               | MsgListPerms user =>
 457                                 ((Msg.send (bio, MsgPerms (Acl.queryAll user));
 458                                   print ("Sent permission list for user " ^ user ^ ".\n"))
 459                                  handle OpenSSL.OpenSSL s =>
 460                                         (print "OpenSSL error\n";
 461                                          Msg.send (bio,
 462                                                    MsgError
 463                                                        ("Error during permission listing: "
 464                                                         ^ s)));
 465                                 (ignore (OpenSSL.readChar bio);
 466                                  OpenSSL.close bio)
 467                                 handle OpenSSL.OpenSSL _ => ();
 468                                 loop ())
 469
 470                               | MsgWhoHas perm =>
 471                                 ((Msg.send (bio, MsgWhoHasResponse (Acl.whoHas perm));
 472                                   print ("Sent whohas response for " ^ #class perm ^ " / " ^ #value perm ^ ".\n"))
 473                                  handle OpenSSL.OpenSSL s =>
 474                                         (print "OpenSSL error\n";
 475                                          Msg.send (bio,
 476                                                    MsgError
 477                                                        ("Error during whohas: "
 478                                                         ^ s)));
 479                                 (ignore (OpenSSL.readChar bio);
 480                                  OpenSSL.close bio)
 481                                 handle OpenSSL.OpenSSL _ => ();
 482                                 loop ())
 483
 484                               | MsgRmdom dom =>
 485                                 if Acl.query {user = user, class = "priv", value = "all"}
 486                                    orelse Acl.query {user = user, class = "domain", value = dom} then
 487                                     ((Domain.rmdom dom;
 488                                       Msg.send (bio, MsgOk);
 489                                       print ("Removed domain " ^ dom ^ ".\n"))
 490                                      handle OpenSSL.OpenSSL s =>
 491                                             (print "OpenSSL error\n";
 492                                              Msg.send (bio,
 493                                                        MsgError
 494                                                            ("Error during revocation: "
 495                                                             ^ s)));
 496                                     (ignore (OpenSSL.readChar bio);
 497                                      OpenSSL.close bio)
 498                                     handle OpenSSL.OpenSSL _ => ();
 499                                     loop ())
 500                                 else
 501                                     ((Msg.send (bio, MsgError "Not authorized to remove that domain");
 502                                       print "Unauthorized user asked to remove a domain!\n";
 503                                       ignore (OpenSSL.readChar bio);
 504                                       OpenSSL.close bio)
 505                                      handle OpenSSL.OpenSSL _ => ();
 506                                      loop ())
 507
 508                               | _ =>
 509                                 (Msg.send (bio, MsgError "Unexpected command")
 510                                  handle OpenSSL.OpenSSL _ => ();
 511                                  OpenSSL.close bio
 512                                  handle OpenSSL.OpenSSL _ => ();
 513                                  loop ())
 514                 in
 515                     cmdLoop ()
 516                 end
 517                     handle OpenSSL.OpenSSL s =>
 518                            (print ("OpenSSL error: " ^ s ^ "\n");
 519                             OpenSSL.close bio
 520                             handle OpenSSL.OpenSSL _ => ();
 521                             loop ())
 522                          | OS.SysErr (s, _) =>
 523                            (print ("System error: " ^ s ^ "\n");
 524                             OpenSSL.close bio
 525                             handle OpenSSL.OpenSSL _ => ();
 526                             loop ())
 527     in
 528         print "Listening for connections....\n";
 529         loop ();
 530         OpenSSL.shutdown sock
 531     end
 532
 533 fun slave () =
 534     let
 535         val host = Slave.hostname ()
 536
 537         val context = OpenSSL.context (Config.certDir ^ "/" ^ host ^ ".pem",
 538                                        Config.keyDir ^ "/" ^ host ^ "/key.pem",
 539                                        Config.trustStore)
 540
 541         val sock = OpenSSL.listen (context, Config.slavePort)
 542
 543         fun loop () =
 544             case OpenSSL.accept sock of
 545                 NONE => ()
 546               | SOME bio =>
 547                 let
 548                     val peer = OpenSSL.peerCN bio
 549                     val () = print ("\nConnection from " ^ peer ^ "\n")
 550                 in
 551                     if peer <> Config.dispatcherName then
 552                         (print "Not authorized!\n";
 553                          OpenSSL.close bio;
 554                          loop ())
 555                     else let
 556                             fun loop' files =
 557                                 case Msg.recv bio of
 558                                     NONE => print "Dispatcher closed connection unexpectedly\n"
 559                                   | SOME m =>
 560                                     case m of
 561                                         MsgFile file => loop' (file :: files)
 562                                       | MsgDoFiles => (Slave.handleChanges files;
 563                                                        Msg.send (bio, MsgOk))
 564                                       | _ => (print "Dispatcher sent unexpected command\n";
 565                                               Msg.send (bio, MsgError "Unexpected command"))
 566                         in
 567                             loop' [];
 568                             ignore (OpenSSL.readChar bio);
 569                             OpenSSL.close bio;
 570                             loop ()
 571                         end
 572                 end handle OpenSSL.OpenSSL s =>
 573                            (print ("OpenSSL error: "^ s ^ "\n");
 574                             OpenSSL.close bio
 575                                           handle OpenSSL.OpenSSL _ => ();
 576                             loop ())
 577                          | OS.SysErr (s, _) =>
 578                            (print ("System error: "^ s ^ "\n");
 579                             OpenSSL.close bio
 580                             handle OpenSSL.OpenSSL _ => ();
 581                             loop ())
 582     in
 583         loop ();
 584         OpenSSL.shutdown sock
 585     end
 586
 587 fun autodocBasis outdir =
 588     let
 589         val dir = Posix.FileSys.opendir Config.libRoot
 590
 591         fun loop files =
 592             case Posix.FileSys.readdir dir of
 593                 NONE => (Posix.FileSys.closedir dir;
 594                          files)
 595               | SOME fname =>
 596                 if String.isSuffix ".dtl" fname then
 597                     loop (OS.Path.joinDirFile {dir = Config.libRoot,
 598                                                file = fname}
 599                           :: files)
 600                 else
 601                     loop files
 602
 603         val files = loop []
 604     in
 605         Autodoc.autodoc {outdir = outdir, infiles = files}
 606     end
 607
 608 end