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 val dmy = ErrorMsg.dummyLoc
  28
  29 val defaultT : record ref = ref SM.empty
  30 val defaultV : (unit -> exp) SM.map ref = ref SM.empty
  31
  32 fun registerDefault (name, t, v) =
  33     case SM.find (!defaultT, name) of
  34         NONE => (defaultT := SM.insert (!defaultT, name, t);
  35                  defaultV := SM.insert (!defaultV, name, v))
  36       | SOME _ => raise Fail "Duplicate default environment variable"
  37
  38 fun tInit () = (TAction ((CRoot, dmy),
  39                          !defaultT,
  40                          StringMap.empty),
  41                 dmy)
  42
  43
  44
  45 fun check' G fname =
  46     let
  47         (*val _ = print ("Check " ^ fname ^ "\n")*)
  48         val prog = Parse.parse fname
  49     in
  50         if !ErrorMsg.anyErrors then
  51             G
  52         else
  53             Tycheck.checkFile G (tInit ()) prog
  54     end
  55
  56 fun basis () =
  57     let
  58         val dir = Posix.FileSys.opendir Config.libRoot
  59
  60         fun loop files =
  61             case Posix.FileSys.readdir dir of
  62                 NONE => (Posix.FileSys.closedir dir;
  63                          files)
  64               | SOME fname =>
  65                 if String.isSuffix ".dtl" fname then
  66                     loop (OS.Path.joinDirFile {dir = Config.libRoot,
  67                                                file = fname}
  68                           :: files)
  69                 else
  70                     loop files
  71
  72         val files = loop []
  73         val files = Order.order files
  74     in
  75         if !ErrorMsg.anyErrors then
  76             Env.empty
  77         else
  78             foldl (fn (fname, G) => check' G fname) Env.empty files
  79     end
  80
  81 fun check fname =
  82     let
  83         val _ = ErrorMsg.reset ()
  84         val _ = Env.preTycheck ()
  85
  86         val b = basis ()
  87     in
  88         if !ErrorMsg.anyErrors then
  89             (b, NONE)
  90         else
  91             let
  92                 val _ = ErrorMsg.reset ()
  93                 val prog = Parse.parse fname
  94             in
  95                 if !ErrorMsg.anyErrors then
  96                     (Env.empty, NONE)
  97                 else
  98                     let
  99                         val G' = Tycheck.checkFile b (tInit ()) prog
 100                     in
 101                         (G', #3 prog)
 102                     end
 103             end
 104     end
 105
 106 fun reduce fname =
 107     let
 108         val (G, body) = check fname
 109     in
 110         if !ErrorMsg.anyErrors then
 111             NONE
 112         else
 113             case body of
 114                 SOME body =>
 115                 let
 116                     val body' = Reduce.reduceExp G body
 117                 in
 118                     (*printd (PD.hovBox (PD.PPS.Rel 0,
 119                                          [PD.string "Result:",
 120                                           PD.space 1,
 121                                           p_exp body']))*)
 122                     SOME body'
 123                 end
 124               | _ => NONE
 125     end
 126
 127 fun eval fname =
 128     case reduce fname of
 129         (SOME body') =>
 130         if !ErrorMsg.anyErrors then
 131             ()
 132         else
 133             Eval.exec (SM.map (fn f => f ()) (!defaultV)) body'
 134       | NONE => ()
 135
 136 val dispatcher =
 137     Config.dispatcher ^ ":" ^ Int.toString Config.dispatcherPort
 138
 139 fun ssl_err s =
 140     let
 141         val err = F_OpenSSL_SML_get_error.f ()
 142
 143         val lib = F_OpenSSL_SML_lib_error_string.f err
 144         val func = F_OpenSSL_SML_func_error_string.f err
 145         val reason = F_OpenSSL_SML_reason_error_string.f err
 146     in
 147         print s;
 148         print "\nReason: ";
 149         if C.Ptr.isNull lib then
 150             ()
 151         else
 152             (print (ZString.toML lib);
 153              print ":");
 154         if C.Ptr.isNull func then
 155             ()
 156         else
 157             (print (ZString.toML func);
 158              print ":");
 159         if C.Ptr.isNull reason then
 160             ()
 161         else
 162             print (ZString.toML reason);
 163         print "\n"
 164     end
 165
 166
 167 fun request fname =
 168     let
 169         val context = OpenSSL.context ("/home/adamc/fake/clientcert.pem",
 170                                        "/home/adamc/fake/clientkey.pem",
 171                                        Config.trustStore)
 172
 173         val bio = OpenSSL.connect (context, dispatcher)
 174
 175         val _ = print ("Subject: " ^ OpenSSL.peerCN bio ^ "\n")
 176
 177         val inf = TextIO.openIn fname
 178
 179         fun loop () =
 180             case TextIO.inputLine inf of
 181                 NONE => ()
 182               | SOME line => (OpenSSL.writeAll (bio, line);
 183                               loop ())
 184     in
 185         loop ();
 186         TextIO.closeIn inf;
 187         OpenSSL.close bio
 188     end
 189
 190 fun service () =
 191     let
 192         val context = OpenSSL.context (Config.serverCert,
 193                                        Config.serverKey,
 194                                        Config.trustStore)
 195
 196         val sock = OpenSSL.listen (Config.dispatcherPort, Config.queueSize)
 197
 198         fun loop () =
 199             case OpenSSL.accept (context, sock) of
 200                 NONE => ()
 201               | SOME bio =>
 202                 let
 203                     val _ = print ("Subject: " ^ OpenSSL.peerCN bio ^ "\n")
 204
 205                     fun loop' () =
 206                         case OpenSSL.readOne bio of
 207                             NONE => ()
 208                           | SOME line => (print line;
 209                                           loop' ())
 210                 in
 211                     loop' ();
 212                     OpenSSL.close bio;
 213                     loop ()
 214                 end
 215     in
 216         loop ();
 217         OpenSSL.shutdown sock
 218     end
 219
 220 end