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 request fname =
 140     let
 141         val context = OpenSSL.context ("/home/adamc/fake/clientcert.pem",
 142                                        "/home/adamc/fake/clientkey.pem",
 143                                        Config.trustStore)
 144
 145         val bio = OpenSSL.connect (context, dispatcher)
 146
 147         val _ = print ("Subject: " ^ OpenSSL.peerCN bio ^ "\n")
 148
 149         val inf = TextIO.openIn fname
 150
 151         fun loop () =
 152             case TextIO.inputLine inf of
 153                 NONE => ()
 154               | SOME line => (OpenSSL.writeAll (bio, line);
 155                               loop ())
 156     in
 157         loop ();
 158         TextIO.closeIn inf;
 159         OpenSSL.close bio
 160     end
 161
 162 fun service () =
 163     let
 164         val context = OpenSSL.context (Config.serverCert,
 165                                        Config.serverKey,
 166                                        Config.trustStore)
 167
 168         val sock = OpenSSL.listen (context, Config.dispatcherPort)
 169
 170         fun loop () =
 171             case OpenSSL.accept sock of
 172                 NONE => ()
 173               | SOME bio =>
 174                 let
 175                     (*val _ = print ("Subject: " ^ OpenSSL.peerCN bio ^ "\n")*)
 176
 177                     fun loop' () =
 178                         case OpenSSL.readOne bio of
 179                             NONE => ()
 180                           | SOME line => (print line;
 181                                           loop' ())
 182                 in
 183                     loop' ();
 184                     OpenSSL.close bio;
 185                     loop ()
 186                 end
 187     in
 188         loop ();
 189         OpenSSL.shutdown sock
 190     end
 191
 192 end