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 request fname =
 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 _ = check fname
 137
 138         val uid = Posix.ProcEnv.getuid ()
 139         val user = Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid uid)
 140
 141         val context = OpenSSL.context (Config.certDir ^ "/" ^ user ^ ".pem",
 142                                        Config.keyDir ^ "/" ^ user ^ "/key.pem",
 143                                        Config.trustStore)
 144
 145         val bio = OpenSSL.connect (context, dispatcher)
 146
 147         val inf = TextIO.openIn fname
 148
 149         fun loop lines =
 150             case TextIO.inputLine inf of
 151                 NONE => String.concat (List.rev lines)
 152               | SOME line => loop (line :: lines)
 153
 154         val code = loop []
 155     in
 156         TextIO.closeIn inf;
 157         Msg.send (bio, MsgConfig code);
 158         case Msg.recv bio of
 159             NONE => print "Server closed connection unexpectedly.\n"
 160           | SOME m =>
 161             case m of
 162                 MsgOk => print "Configuration succeeded.\n"
 163               | MsgError s => print ("Configuration failed: " ^ s ^ "\n")
 164               | _ => print "Unexpected server reply.\n";
 165         OpenSSL.close bio
 166     end
 167     handle ErrorMsg.Error => ()
 168
 169 fun service () =
 170     let
 171         val () = Acl.read Config.aclFile
 172
 173         val context = OpenSSL.context (Config.serverCert,
 174                                        Config.serverKey,
 175                                        Config.trustStore)
 176         val _ = Domain.set_context context
 177
 178         val sock = OpenSSL.listen (context, Config.dispatcherPort)
 179
 180         fun loop () =
 181             case OpenSSL.accept sock of
 182                 NONE => ()
 183               | SOME bio =>
 184                 let
 185                     val user = OpenSSL.peerCN bio
 186                     val () = print ("\nConnection from " ^ user ^ "\n")
 187                     val () = Domain.setUser user
 188
 189                     fun cmdLoop () =
 190                         case Msg.recv bio of
 191                             NONE => (OpenSSL.close bio
 192                                      handle OpenSSL.OpenSSL _ => ();
 193                                      loop ())
 194                           | SOME m =>
 195                             case m of
 196                                 MsgConfig code =>
 197                                 let
 198                                     val _ = print "Configuration:\n"
 199                                     val _ = print code
 200                                     val _ = print "\n"
 201
 202                                     val outname = OS.FileSys.tmpName ()
 203                                     val outf = TextIO.openOut outname
 204                                 in
 205                                     TextIO.output (outf, code);
 206                                     TextIO.closeOut outf;
 207                                     (eval outname;
 208                                      Msg.send (bio, MsgOk))
 209                                     handle ErrorMsg.Error =>
 210                                            (print "Compilation error\n";
 211                                             Msg.send (bio,
 212                                                       MsgError "Error during configuration evaluation"))
 213                                          | OpenSSL.OpenSSL s =>
 214                                            (print "OpenSSL error\n";
 215                                             Msg.send (bio,
 216                                                       MsgError
 217                                                           ("Error during configuration evaluation: "
 218                                                            ^ s)));
 219                                            OS.FileSys.remove outname;
 220                                            (ignore (OpenSSL.readChar bio);
 221                                             OpenSSL.close bio)
 222                                            handle OpenSSL.OpenSSL _ => ();
 223                                            loop ()
 224                                 end
 225                               | _ =>
 226                                 (Msg.send (bio, MsgError "Unexpected command")
 227                                  handle OpenSSL.OpenSSL _ => ();
 228                                  OpenSSL.close bio
 229                                  handle OpenSSL.OpenSSL _ => ();
 230                                  loop ())
 231                 in
 232                     cmdLoop ()
 233                 end
 234                     handle OpenSSL.OpenSSL s =>
 235                            (print ("OpenSSL error: " ^ s ^ "\n");
 236                             OpenSSL.close bio
 237                             handle OpenSSL.OpenSSL _ => ();
 238                             loop ())
 239                          | OS.SysErr (s, _) =>
 240                            (print ("System error: " ^ s ^ "\n");
 241                             OpenSSL.close bio
 242                             handle OpenSSL.OpenSSL _ => ();
 243                             loop ())
 244     in
 245         print "Listening for connections....\n";
 246         loop ();
 247         OpenSSL.shutdown sock
 248     end
 249
 250 fun slave () =
 251     let
 252         val host = Slave.hostname ()
 253
 254         val context = OpenSSL.context (Config.certDir ^ "/" ^ host ^ ".pem",
 255                                        Config.keyDir ^ "/" ^ host ^ "/key.pem",
 256                                        Config.trustStore)
 257
 258         val sock = OpenSSL.listen (context, Config.slavePort)
 259
 260         fun loop () =
 261             case OpenSSL.accept sock of
 262                 NONE => ()
 263               | SOME bio =>
 264                 let
 265                     val peer = OpenSSL.peerCN bio
 266                     val () = print ("\nConnection from " ^ peer ^ "\n")
 267                 in
 268                     if peer <> Config.dispatcherName then
 269                         (print "Not authorized!\n";
 270                          OpenSSL.close bio;
 271                          loop ())
 272                     else let
 273                             fun loop' files =
 274                                 case Msg.recv bio of
 275                                     NONE => print "Dispatcher closed connection unexpectedly\n"
 276                                   | SOME m =>
 277                                     case m of
 278                                         MsgFile file => loop' (file :: files)
 279                                       | MsgDoFiles => (Slave.handleChanges files;
 280                                                        Msg.send (bio, MsgOk))
 281                                       | _ => (print "Dispatcher sent unexpected command\n";
 282                                               Msg.send (bio, MsgError "Unexpected command"))
 283                         in
 284                             loop' [];
 285                             ignore (OpenSSL.readChar bio);
 286                             OpenSSL.close bio;
 287                             loop ()
 288                         end
 289                 end handle OpenSSL.OpenSSL s =>
 290                            (print ("OpenSSL error: "^ s ^ "\n");
 291                             OpenSSL.close bio
 292                                           handle OpenSSL.OpenSSL _ => ();
 293                             loop ())
 294                          | OS.SysErr (s, _) =>
 295                            (print ("System error: "^ s ^ "\n");
 296                             OpenSSL.close bio
 297                             handle OpenSSL.OpenSSL _ => ();
 298                             loop ())
 299     in
 300         loop ();
 301         OpenSSL.shutdown sock
 302     end
 303
 304 fun autodocBasis outdir =
 305     let
 306         val dir = Posix.FileSys.opendir Config.libRoot
 307
 308         fun loop files =
 309             case Posix.FileSys.readdir dir of
 310                 NONE => (Posix.FileSys.closedir dir;
 311                          files)
 312               | SOME fname =>
 313                 if String.isSuffix ".dtl" fname then
 314                     loop (OS.Path.joinDirFile {dir = Config.libRoot,
 315                                                file = fname}
 316                           :: files)
 317                 else
 318                     loop files
 319
 320         val files = loop []
 321     in
 322         Autodoc.autodoc {outdir = outdir, infiles = files}
 323     end
 324
 325 end