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             foldl (fn (fname, G) => check' G fname) Env.empty files
  62     end
  63
  64 fun check fname =
  65     let
  66         val _ = ErrorMsg.reset ()
  67         val _ = Env.preTycheck ()
  68
  69         val b = basis ()
  70     in
  71         if !ErrorMsg.anyErrors then
  72             raise ErrorMsg.Error
  73         else
  74             let
  75                 val _ = ErrorMsg.reset ()
  76                 val prog = Parse.parse fname
  77             in
  78                 if !ErrorMsg.anyErrors then
  79                     raise ErrorMsg.Error
  80                 else
  81                     let
  82                         val G' = Tycheck.checkFile b (Defaults.tInit ()) prog
  83                     in
  84                         if !ErrorMsg.anyErrors then
  85                             raise ErrorMsg.Error
  86                         else
  87                             (G', #3 prog)
  88                     end
  89             end
  90     end
  91
  92 fun reduce fname =
  93     let
  94         val (G, body) = check fname
  95     in
  96         if !ErrorMsg.anyErrors then
  97             NONE
  98         else
  99             case body of
 100                 SOME body =>
 101                 let
 102                     val body' = Reduce.reduceExp G body
 103                 in
 104                     (*printd (PD.hovBox (PD.PPS.Rel 0,
 105                                          [PD.string "Result:",
 106                                           PD.space 1,
 107                                           p_exp body']))*)
 108                     SOME body'
 109                 end
 110               | _ => NONE
 111     end
 112
 113 fun eval fname =
 114     case reduce fname of
 115         (SOME body') =>
 116         if !ErrorMsg.anyErrors then
 117             raise ErrorMsg.Error
 118         else
 119             Eval.exec (Defaults.eInit ()) body'
 120       | NONE => raise ErrorMsg.Error
 121
 122 val dispatcher =
 123     Config.dispatcher ^ ":" ^ Int.toString Config.dispatcherPort
 124
 125 fun hostname () =
 126     let
 127         val inf = TextIO.openIn "/etc/hostname"
 128     in
 129         case TextIO.inputLine inf of
 130             NONE => (TextIO.closeIn inf; raise Fail "No line in /etc/hostname")
 131           | SOME line => (TextIO.closeIn inf; String.substring (line, 0, size line - 1))
 132     end
 133
 134 fun request fname =
 135     let
 136         val uid = Posix.ProcEnv.getuid ()
 137         val user = Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid uid)
 138
 139         val () = Acl.read Config.aclFile
 140         val () = Domain.setUser user
 141
 142         val _ = check fname
 143
 144         val uid = Posix.ProcEnv.getuid ()
 145         val user = Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid uid)
 146
 147         val context = OpenSSL.context (Config.certDir ^ "/" ^ user ^ ".pem",
 148                                        Config.keyDir ^ "/" ^ user ^ "/key.pem",
 149                                        Config.trustStore)
 150
 151         val bio = OpenSSL.connect (context, dispatcher)
 152
 153         val inf = TextIO.openIn fname
 154
 155         fun loop lines =
 156             case TextIO.inputLine inf of
 157                 NONE => String.concat (List.rev lines)
 158               | SOME line => loop (line :: lines)
 159
 160         val code = loop []
 161     in
 162         TextIO.closeIn inf;
 163         Msg.send (bio, MsgConfig code);
 164         case Msg.recv bio of
 165             NONE => print "Server closed connection unexpectedly.\n"
 166           | SOME m =>
 167             case m of
 168                 MsgOk => print "Configuration succeeded.\n"
 169               | MsgError s => print ("Configuration failed: " ^ s ^ "\n")
 170               | _ => print "Unexpected server reply.\n";
 171         OpenSSL.close bio
 172     end
 173     handle ErrorMsg.Error => ()
 174
 175 fun service () =
 176     let
 177         val () = Acl.read Config.aclFile
 178
 179         val context = OpenSSL.context (Config.serverCert,
 180                                        Config.serverKey,
 181                                        Config.trustStore)
 182         val _ = Domain.set_context context
 183
 184         val sock = OpenSSL.listen (context, Config.dispatcherPort)
 185
 186         fun loop () =
 187             case OpenSSL.accept sock of
 188                 NONE => ()
 189               | SOME bio =>
 190                 let
 191                     val user = OpenSSL.peerCN bio
 192                     val () = print ("\nConnection from " ^ user ^ "\n")
 193                     val () = Domain.setUser user
 194
 195                     fun cmdLoop () =
 196                         case Msg.recv bio of
 197                             NONE => (OpenSSL.close bio
 198                                      handle OpenSSL.OpenSSL _ => ();
 199                                      loop ())
 200                           | SOME m =>
 201                             case m of
 202                                 MsgConfig code =>
 203                                 let
 204                                     val _ = print "Configuration:\n"
 205                                     val _ = print code
 206                                     val _ = print "\n"
 207
 208                                     val outname = OS.FileSys.tmpName ()
 209                                     val outf = TextIO.openOut outname
 210                                 in
 211                                     TextIO.output (outf, code);
 212                                     TextIO.closeOut outf;
 213                                     (eval outname;
 214                                      Msg.send (bio, MsgOk))
 215                                     handle ErrorMsg.Error =>
 216                                            (print "Compilation error\n";
 217                                             Msg.send (bio,
 218                                                       MsgError "Error during configuration evaluation"))
 219                                          | OpenSSL.OpenSSL s =>
 220                                            (print "OpenSSL error\n";
 221                                             Msg.send (bio,
 222                                                       MsgError
 223                                                           ("Error during configuration evaluation: "
 224                                                            ^ s)));
 225                                            OS.FileSys.remove outname;
 226                                            (ignore (OpenSSL.readChar bio);
 227                                             OpenSSL.close bio)
 228                                            handle OpenSSL.OpenSSL _ => ();
 229                                            loop ()
 230                                 end
 231                               | _ =>
 232                                 (Msg.send (bio, MsgError "Unexpected command")
 233                                  handle OpenSSL.OpenSSL _ => ();
 234                                  OpenSSL.close bio
 235                                  handle OpenSSL.OpenSSL _ => ();
 236                                  loop ())
 237                 in
 238                     cmdLoop ()
 239                 end
 240                     handle OpenSSL.OpenSSL s =>
 241                            (print ("OpenSSL error: " ^ s ^ "\n");
 242                             OpenSSL.close bio
 243                             handle OpenSSL.OpenSSL _ => ();
 244                             loop ())
 245                          | OS.SysErr (s, _) =>
 246                            (print ("System error: " ^ s ^ "\n");
 247                             OpenSSL.close bio
 248                             handle OpenSSL.OpenSSL _ => ();
 249                             loop ())
 250     in
 251         print "Listening for connections....\n";
 252         loop ();
 253         OpenSSL.shutdown sock
 254     end
 255
 256 fun slave () =
 257     let
 258         val host = hostname ()
 259
 260         val context = OpenSSL.context (Config.certDir ^ "/" ^ host ^ ".pem",
 261                                        Config.keyDir ^ "/" ^ host ^ "/key.pem",
 262                                        Config.trustStore)
 263
 264         val sock = OpenSSL.listen (context, Config.slavePort)
 265
 266         fun loop () =
 267             case OpenSSL.accept sock of
 268                 NONE => ()
 269               | SOME bio =>
 270                 let
 271                     val peer = OpenSSL.peerCN bio
 272                     val () = print ("\nConnection from " ^ peer ^ "\n")
 273                 in
 274                     if peer <> Config.dispatcherName then
 275                         (print "Not authorized!\n";
 276                          OpenSSL.close bio;
 277                          loop ())
 278                     else let
 279                             fun loop' files =
 280                                 case Msg.recv bio of
 281                                     NONE => print "Dispatcher closed connection unexpectedly\n"
 282                                   | SOME m =>
 283                                     case m of
 284                                         MsgFile file => loop' (file :: files)
 285                                       | MsgDoFiles => (Slave.handleChanges files;
 286                                                        Msg.send (bio, MsgOk))
 287                                       | _ => (print "Dispatcher sent unexpected command\n";
 288                                               Msg.send (bio, MsgError "Unexpected command"))
 289                         in
 290                             loop' [];
 291                             ignore (OpenSSL.readChar bio);
 292                             OpenSSL.close bio;
 293                             loop ()
 294                         end
 295                 end handle OpenSSL.OpenSSL s =>
 296                            (print ("OpenSSL error: "^ s ^ "\n");
 297                             OpenSSL.close bio
 298                                           handle OpenSSL.OpenSSL _ => ();
 299                             loop ())
 300                          | OS.SysErr (s, _) =>
 301                            (print ("System error: "^ s ^ "\n");
 302                             OpenSSL.close bio
 303                             handle OpenSSL.OpenSSL _ => ();
 304                             loop ())
 305     in
 306         loop ();
 307         OpenSSL.shutdown sock
 308     end
 309
 310 fun autodocBasis outdir =
 311     let
 312         val dir = Posix.FileSys.opendir Config.libRoot
 313
 314         fun loop files =
 315             case Posix.FileSys.readdir dir of
 316                 NONE => (Posix.FileSys.closedir dir;
 317                          files)
 318               | SOME fname =>
 319                 if String.isSuffix ".dtl" fname then
 320                     loop (OS.Path.joinDirFile {dir = Config.libRoot,
 321                                                file = fname}
 322                           :: files)
 323                 else
 324                     loop files
 325
 326         val files = loop []
 327     in
 328         Autodoc.autodoc {outdir = outdir, infiles = files}
 329     end
 330
 331 end