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 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 fun reduce fname =
  96     let
  97         val (G, body) = check fname
  98     in
  99         if !ErrorMsg.anyErrors then
 100             NONE
 101         else
 102             case body of
 103                 SOME body =>
 104                 let
 105                     val body' = Reduce.reduceExp G body
 106                 in
 107                     (*printd (PD.hovBox (PD.PPS.Rel 0,
 108                                          [PD.string "Result:",
 109                                           PD.space 1,
 110                                           p_exp body']))*)
 111                     SOME body'
 112                 end
 113               | _ => NONE
 114     end
 115
 116 fun eval fname =
 117     case reduce fname of
 118         (SOME body') =>
 119         if !ErrorMsg.anyErrors then
 120             raise ErrorMsg.Error
 121         else
 122             Eval.exec (Defaults.eInit ()) body'
 123       | NONE => raise ErrorMsg.Error
 124
 125 val dispatcher =
 126     Config.dispatcher ^ ":" ^ Int.toString Config.dispatcherPort
 127
 128 fun requestContext f =
 129     let
 130         val uid = Posix.ProcEnv.getuid ()
 131         val user = Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid uid)
 132
 133         val () = Acl.read Config.aclFile
 134         val () = Domain.setUser user
 135
 136         val () = f ()
 137
 138         val context = OpenSSL.context (Config.certDir ^ "/" ^ user ^ ".pem",
 139                                        Config.keyDir ^ "/" ^ user ^ "/key.pem",
 140                                        Config.trustStore)
 141     in
 142         (user, context)
 143     end
 144
 145 fun requestBio f =
 146     let
 147         val (user, context) = requestContext f
 148     in
 149         (user, OpenSSL.connect (context, dispatcher))
 150     end
 151
 152 fun request fname =
 153     let
 154         val (user, bio) = requestBio (fn () => ignore (check fname))
 155
 156         val inf = TextIO.openIn fname
 157
 158         fun loop lines =
 159             case TextIO.inputLine inf of
 160                 NONE => String.concat (List.rev lines)
 161               | SOME line => loop (line :: lines)
 162
 163         val code = loop []
 164     in
 165         TextIO.closeIn inf;
 166         Msg.send (bio, MsgConfig code);
 167         case Msg.recv bio of
 168             NONE => print "Server closed connection unexpectedly.\n"
 169           | SOME m =>
 170             case m of
 171                 MsgOk => print "Configuration succeeded.\n"
 172               | MsgError s => print ("Configuration failed: " ^ s ^ "\n")
 173               | _ => print "Unexpected server reply.\n";
 174         OpenSSL.close bio
 175     end
 176     handle ErrorMsg.Error => ()
 177
 178 fun requestGrant acl =
 179     let
 180         val (user, bio) = requestBio (fn () => ())
 181     in
 182         Msg.send (bio, MsgGrant acl);
 183         case Msg.recv bio of
 184             NONE => print "Server closed connection unexpectedly.\n"
 185           | SOME m =>
 186             case m of
 187                 MsgOk => print "Grant succeeded.\n"
 188               | MsgError s => print ("Grant failed: " ^ s ^ "\n")
 189               | _ => print "Unexpected server reply.\n";
 190         OpenSSL.close bio
 191     end
 192
 193 fun requestRevoke acl =
 194     let
 195         val (user, bio) = requestBio (fn () => ())
 196     in
 197         Msg.send (bio, MsgRevoke acl);
 198         case Msg.recv bio of
 199             NONE => print "Server closed connection unexpectedly.\n"
 200           | SOME m =>
 201             case m of
 202                 MsgOk => print "Revoke succeeded.\n"
 203               | MsgError s => print ("Revoke failed: " ^ s ^ "\n")
 204               | _ => print "Unexpected server reply.\n";
 205         OpenSSL.close bio
 206     end
 207
 208 fun requestListPerms user =
 209     let
 210         val (_, bio) = requestBio (fn () => ())
 211     in
 212         Msg.send (bio, MsgListPerms user);
 213         (case Msg.recv bio of
 214              NONE => (print "Server closed connection unexpectedly.\n";
 215                       NONE)
 216            | SOME m =>
 217              case m of
 218                  MsgPerms perms => SOME perms
 219                | MsgError s => (print ("Listing failed: " ^ s ^ "\n");
 220                                 NONE)
 221                | _ => (print "Unexpected server reply.\n";
 222                        NONE))
 223         before OpenSSL.close bio
 224     end
 225
 226 fun requestWhoHas perm =
 227     let
 228         val (_, bio) = requestBio (fn () => ())
 229     in
 230         Msg.send (bio, MsgWhoHas perm);
 231         (case Msg.recv bio of
 232              NONE => (print "Server closed connection unexpectedly.\n";
 233                       NONE)
 234            | SOME m =>
 235              case m of
 236                  MsgWhoHasResponse users => SOME users
 237                | MsgError s => (print ("whohas failed: " ^ s ^ "\n");
 238                                 NONE)
 239                | _ => (print "Unexpected server reply.\n";
 240                        NONE))
 241         before OpenSSL.close bio
 242     end
 243
 244 fun service () =
 245     let
 246         val () = Acl.read Config.aclFile
 247
 248         val context = OpenSSL.context (Config.serverCert,
 249                                        Config.serverKey,
 250                                        Config.trustStore)
 251         val _ = Domain.set_context context
 252
 253         val sock = OpenSSL.listen (context, Config.dispatcherPort)
 254
 255         fun loop () =
 256             case OpenSSL.accept sock of
 257                 NONE => ()
 258               | SOME bio =>
 259                 let
 260                     val user = OpenSSL.peerCN bio
 261                     val () = print ("\nConnection from " ^ user ^ "\n")
 262                     val () = Domain.setUser user
 263
 264                     fun cmdLoop () =
 265                         case Msg.recv bio of
 266                             NONE => (OpenSSL.close bio
 267                                      handle OpenSSL.OpenSSL _ => ();
 268                                      loop ())
 269                           | SOME m =>
 270                             case m of
 271                                 MsgConfig code =>
 272                                 let
 273                                     val _ = print "Configuration:\n"
 274                                     val _ = print code
 275                                     val _ = print "\n"
 276
 277                                     val outname = OS.FileSys.tmpName ()
 278                                     val outf = TextIO.openOut outname
 279                                 in
 280                                     TextIO.output (outf, code);
 281                                     TextIO.closeOut outf;
 282                                     (eval outname;
 283                                      Msg.send (bio, MsgOk))
 284                                     handle ErrorMsg.Error =>
 285                                            (print "Compilation error\n";
 286                                             Msg.send (bio,
 287                                                       MsgError "Error during configuration evaluation"))
 288                                          | OpenSSL.OpenSSL s =>
 289                                            (print "OpenSSL error\n";
 290                                             Msg.send (bio,
 291                                                       MsgError
 292                                                           ("Error during configuration evaluation: "
 293                                                            ^ s)));
 294                                     OS.FileSys.remove outname;
 295                                     (ignore (OpenSSL.readChar bio);
 296                                      OpenSSL.close bio)
 297                                     handle OpenSSL.OpenSSL _ => ();
 298                                     loop ()
 299                                 end
 300
 301                               | MsgGrant acl =>
 302                                 if Acl.query {user = user, class = "priv", value = "all"} then
 303                                     ((Acl.grant acl;
 304                                       Acl.write Config.aclFile;
 305                                       Msg.send (bio, MsgOk);
 306                                       print ("Granted permission " ^ #value acl ^ " to " ^ #user acl ^ " in " ^ #class acl ^ ".\n"))
 307                                      handle OpenSSL.OpenSSL s =>
 308                                             (print "OpenSSL error\n";
 309                                              Msg.send (bio,
 310                                                        MsgError
 311                                                            ("Error during granting: "
 312                                                             ^ s)));
 313                                     (ignore (OpenSSL.readChar bio);
 314                                      OpenSSL.close bio)
 315                                     handle OpenSSL.OpenSSL _ => ();
 316                                     loop ())
 317                                 else
 318                                     ((Msg.send (bio, MsgError "Not authorized to grant privileges");
 319                                       print "Unauthorized user asked to grant a permission!\n";
 320                                       ignore (OpenSSL.readChar bio);
 321                                       OpenSSL.close bio)
 322                                      handle OpenSSL.OpenSSL _ => ();
 323                                      loop ())
 324
 325                               | MsgRevoke acl =>
 326                                 if Acl.query {user = user, class = "priv", value = "all"} then
 327                                     ((Acl.revoke acl;
 328                                       Acl.write Config.aclFile;
 329                                       Msg.send (bio, MsgOk);
 330                                       print ("Revoked permission " ^ #value acl ^ " from " ^ #user acl ^ " in " ^ #class acl ^ ".\n"))
 331                                      handle OpenSSL.OpenSSL s =>
 332                                             (print "OpenSSL error\n";
 333                                              Msg.send (bio,
 334                                                        MsgError
 335                                                            ("Error during revocation: "
 336                                                             ^ s)));
 337                                     (ignore (OpenSSL.readChar bio);
 338                                      OpenSSL.close bio)
 339                                     handle OpenSSL.OpenSSL _ => ();
 340                                     loop ())
 341                                 else
 342                                     ((Msg.send (bio, MsgError "Not authorized to revoke privileges");
 343                                       print "Unauthorized user asked to revoke a permission!\n";
 344                                       ignore (OpenSSL.readChar bio);
 345                                       OpenSSL.close bio)
 346                                      handle OpenSSL.OpenSSL _ => ();
 347                                      loop ())
 348
 349                               | MsgListPerms user =>
 350                                 ((Msg.send (bio, MsgPerms (Acl.queryAll user));
 351                                   print ("Sent permission list for user " ^ user ^ ".\n"))
 352                                  handle OpenSSL.OpenSSL s =>
 353                                         (print "OpenSSL error\n";
 354                                          Msg.send (bio,
 355                                                    MsgError
 356                                                        ("Error during permission listing: "
 357                                                         ^ s)));
 358                                 (ignore (OpenSSL.readChar bio);
 359                                  OpenSSL.close bio)
 360                                 handle OpenSSL.OpenSSL _ => ();
 361                                 loop ())
 362
 363                               | MsgWhoHas perm =>
 364                                 ((Msg.send (bio, MsgWhoHasResponse (Acl.whoHas perm));
 365                                   print ("Sent whohas response for " ^ #class perm ^ " / " ^ #value perm ^ ".\n"))
 366                                  handle OpenSSL.OpenSSL s =>
 367                                         (print "OpenSSL error\n";
 368                                          Msg.send (bio,
 369                                                    MsgError
 370                                                        ("Error during whohas: "
 371                                                         ^ s)));
 372                                 (ignore (OpenSSL.readChar bio);
 373                                  OpenSSL.close bio)
 374                                 handle OpenSSL.OpenSSL _ => ();
 375                                 loop ())
 376
 377                               | _ =>
 378                                 (Msg.send (bio, MsgError "Unexpected command")
 379                                  handle OpenSSL.OpenSSL _ => ();
 380                                  OpenSSL.close bio
 381                                  handle OpenSSL.OpenSSL _ => ();
 382                                  loop ())
 383                 in
 384                     cmdLoop ()
 385                 end
 386                     handle OpenSSL.OpenSSL s =>
 387                            (print ("OpenSSL error: " ^ s ^ "\n");
 388                             OpenSSL.close bio
 389                             handle OpenSSL.OpenSSL _ => ();
 390                             loop ())
 391                          | OS.SysErr (s, _) =>
 392                            (print ("System error: " ^ s ^ "\n");
 393                             OpenSSL.close bio
 394                             handle OpenSSL.OpenSSL _ => ();
 395                             loop ())
 396     in
 397         print "Listening for connections....\n";
 398         loop ();
 399         OpenSSL.shutdown sock
 400     end
 401
 402 fun slave () =
 403     let
 404         val host = Slave.hostname ()
 405
 406         val context = OpenSSL.context (Config.certDir ^ "/" ^ host ^ ".pem",
 407                                        Config.keyDir ^ "/" ^ host ^ "/key.pem",
 408                                        Config.trustStore)
 409
 410         val sock = OpenSSL.listen (context, Config.slavePort)
 411
 412         fun loop () =
 413             case OpenSSL.accept sock of
 414                 NONE => ()
 415               | SOME bio =>
 416                 let
 417                     val peer = OpenSSL.peerCN bio
 418                     val () = print ("\nConnection from " ^ peer ^ "\n")
 419                 in
 420                     if peer <> Config.dispatcherName then
 421                         (print "Not authorized!\n";
 422                          OpenSSL.close bio;
 423                          loop ())
 424                     else let
 425                             fun loop' files =
 426                                 case Msg.recv bio of
 427                                     NONE => print "Dispatcher closed connection unexpectedly\n"
 428                                   | SOME m =>
 429                                     case m of
 430                                         MsgFile file => loop' (file :: files)
 431                                       | MsgDoFiles => (Slave.handleChanges files;
 432                                                        Msg.send (bio, MsgOk))
 433                                       | _ => (print "Dispatcher sent unexpected command\n";
 434                                               Msg.send (bio, MsgError "Unexpected command"))
 435                         in
 436                             loop' [];
 437                             ignore (OpenSSL.readChar bio);
 438                             OpenSSL.close bio;
 439                             loop ()
 440                         end
 441                 end handle OpenSSL.OpenSSL s =>
 442                            (print ("OpenSSL error: "^ s ^ "\n");
 443                             OpenSSL.close bio
 444                                           handle OpenSSL.OpenSSL _ => ();
 445                             loop ())
 446                          | OS.SysErr (s, _) =>
 447                            (print ("System error: "^ s ^ "\n");
 448                             OpenSSL.close bio
 449                             handle OpenSSL.OpenSSL _ => ();
 450                             loop ())
 451     in
 452         loop ();
 453         OpenSSL.shutdown sock
 454     end
 455
 456 fun autodocBasis outdir =
 457     let
 458         val dir = Posix.FileSys.opendir Config.libRoot
 459
 460         fun loop files =
 461             case Posix.FileSys.readdir dir of
 462                 NONE => (Posix.FileSys.closedir dir;
 463                          files)
 464               | SOME fname =>
 465                 if String.isSuffix ".dtl" fname then
 466                     loop (OS.Path.joinDirFile {dir = Config.libRoot,
 467                                                file = fname}
 468                           :: files)
 469                 else
 470                     loop files
 471
 472         val files = loop []
 473     in
 474         Autodoc.autodoc {outdir = outdir, infiles = files}
 475     end
 476
 477 end