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 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             (b, NONE)
  73         else
  74             let
  75                 val _ = ErrorMsg.reset ()
  76                 val prog = Parse.parse fname
  77             in
  78                 if !ErrorMsg.anyErrors then
  79                     (Env.empty, NONE)
  80                 else
  81                     let
  82                         val G' = Tycheck.checkFile b (Defaults.tInit ()) prog
  83                     in
  84                         (G', #3 prog)
  85                     end
  86             end
  87     end
  88
  89 fun reduce fname =
  90     let
  91         val (G, body) = check fname
  92     in
  93         if !ErrorMsg.anyErrors then
  94             NONE
  95         else
  96             case body of
  97                 SOME body =>
  98                 let
  99                     val body' = Reduce.reduceExp G body
 100                 in
 101                     (*printd (PD.hovBox (PD.PPS.Rel 0,
 102                                          [PD.string "Result:",
 103                                           PD.space 1,
 104                                           p_exp body']))*)
 105                     SOME body'
 106                 end
 107               | _ => NONE
 108     end
 109
 110 fun eval fname =
 111     case reduce fname of
 112         (SOME body') =>
 113         if !ErrorMsg.anyErrors then
 114             ()
 115         else
 116             Eval.exec (Defaults.eInit ()) body'
 117       | NONE => ()
 118
 119 val dispatcher =
 120     Config.dispatcher ^ ":" ^ Int.toString Config.dispatcherPort
 121
 122 fun request fname =
 123     let
 124         val uid = Posix.ProcEnv.getuid ()
 125         val user = Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid uid)
 126
 127         val () = Acl.read Config.aclFile
 128         val () = Domain.setUser user
 129         val _ = check fname
 130
 131         val context = OpenSSL.context (Config.certDir ^ "/" ^ user ^ ".pem",
 132                                        Config.keyDir ^ "/" ^ user ^ ".pem",
 133                                        Config.trustStore)
 134
 135         val bio = OpenSSL.connect (context, dispatcher)
 136
 137         val inf = TextIO.openIn fname
 138
 139         fun loop () =
 140             case TextIO.inputLine inf of
 141                 NONE => ()
 142               | SOME line => (OpenSSL.writeAll (bio, line);
 143                               loop ())
 144     in
 145         loop ();
 146         TextIO.closeIn inf;
 147         OpenSSL.close bio
 148     end
 149     handle ErrorMsg.Error => ()
 150
 151 fun service () =
 152     let
 153         val () = Acl.read Config.aclFile
 154
 155         val context = OpenSSL.context (Config.serverCert,
 156                                        Config.serverKey,
 157                                        Config.trustStore)
 158
 159         val sock = OpenSSL.listen (context, Config.dispatcherPort)
 160
 161         fun loop () =
 162             case OpenSSL.accept sock of
 163                 NONE => ()
 164               | SOME bio =>
 165                 let
 166                     val user = OpenSSL.peerCN bio
 167                     val () = print ("\nConnection from " ^ user ^ "\n")
 168                     val () = Domain.setUser user
 169
 170                     val outname = OS.FileSys.tmpName ()
 171                     val outf = TextIO.openOut outname
 172
 173                     fun loop' () =
 174                         case OpenSSL.readOne bio of
 175                             NONE => ()
 176                           | SOME line => (TextIO.output (outf, line);
 177                                           loop' ())
 178                 in
 179                     (loop' ();
 180                      TextIO.closeOut outf;
 181                      eval outname
 182                      handle ErrorMsg.Error => ();
 183                      OS.FileSys.remove outname;
 184                      OpenSSL.close bio)
 185                     handle OpenSSL.OpenSSL _ => ();
 186                     loop ()
 187                 end
 188     in
 189         loop ();
 190         OpenSSL.shutdown sock
 191     end
 192
 193 end