Basic client/server thing going on with unencrypted OpenSSL
[hcoop/domtool2.git] / 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 fun init () = (F_OpenSSL_SML_add_all_algorithms.f' ();
30 F_OpenSSL_SML_load_error_strings.f' ();
31 F_OpenSSL_SML_load_BIO_strings.f' ())
32
33 val () = init ()
34
35 val defaultT : record ref = ref SM.empty
36 val defaultV : (unit -> exp) SM.map ref = ref SM.empty
37
38 fun registerDefault (name, t, v) =
39 case SM.find (!defaultT, name) of
40 NONE => (defaultT := SM.insert (!defaultT, name, t);
41 defaultV := SM.insert (!defaultV, name, v))
42 | SOME _ => raise Fail "Duplicate default environment variable"
43
44 fun tInit () = (TAction ((CRoot, dmy),
45 !defaultT,
46 StringMap.empty),
47 dmy)
48
49
50
51 fun check' G fname =
52 let
53 (*val _ = print ("Check " ^ fname ^ "\n")*)
54 val prog = Parse.parse fname
55 in
56 if !ErrorMsg.anyErrors then
57 G
58 else
59 Tycheck.checkFile G (tInit ()) prog
60 end
61
62 fun basis () =
63 let
64 val dir = Posix.FileSys.opendir Config.libRoot
65
66 fun loop files =
67 case Posix.FileSys.readdir dir of
68 NONE => (Posix.FileSys.closedir dir;
69 files)
70 | SOME fname =>
71 if String.isSuffix ".dtl" fname then
72 loop (OS.Path.joinDirFile {dir = Config.libRoot,
73 file = fname}
74 :: files)
75 else
76 loop files
77
78 val files = loop []
79 val files = Order.order files
80 in
81 if !ErrorMsg.anyErrors then
82 Env.empty
83 else
84 foldl (fn (fname, G) => check' G fname) Env.empty files
85 end
86
87 fun check fname =
88 let
89 val _ = ErrorMsg.reset ()
90 val _ = Env.preTycheck ()
91
92 val b = basis ()
93 in
94 if !ErrorMsg.anyErrors then
95 (b, NONE)
96 else
97 let
98 val _ = ErrorMsg.reset ()
99 val prog = Parse.parse fname
100 in
101 if !ErrorMsg.anyErrors then
102 (Env.empty, NONE)
103 else
104 let
105 val G' = Tycheck.checkFile b (tInit ()) prog
106 in
107 (G', #3 prog)
108 end
109 end
110 end
111
112 fun reduce fname =
113 let
114 val (G, body) = check fname
115 in
116 if !ErrorMsg.anyErrors then
117 NONE
118 else
119 case body of
120 SOME body =>
121 let
122 val body' = Reduce.reduceExp G body
123 in
124 (*printd (PD.hovBox (PD.PPS.Rel 0,
125 [PD.string "Result:",
126 PD.space 1,
127 p_exp body']))*)
128 SOME body'
129 end
130 | _ => NONE
131 end
132
133 fun eval fname =
134 case reduce fname of
135 (SOME body') =>
136 if !ErrorMsg.anyErrors then
137 ()
138 else
139 Eval.exec (SM.map (fn f => f ()) (!defaultV)) body'
140 | NONE => ()
141
142 val dispatcher : C.rw ZString.zstring' =
143 ZString.dupML' (Config.dispatcher ^ ":" ^ Int.toString Config.dispatcherPort)
144
145 val listenOn : C.rw ZString.zstring' =
146 ZString.dupML' ("localhost:" ^ Int.toString Config.dispatcherPort)
147
148 fun ssl_err s =
149 let
150 val err = F_OpenSSL_SML_get_error.f ()
151 in
152 print s;
153 print "\nReason: ";
154 print (ZString.toML (F_OpenSSL_SML_lib_error_string.f err));
155 print ":";
156 print (ZString.toML (F_OpenSSL_SML_func_error_string.f err));
157 print ":";
158 print (ZString.toML (F_OpenSSL_SML_reason_error_string.f err));
159 print "\n"
160 end
161
162 exception OpenSSL of string
163
164 val readBuf : (C.uchar, C.rw) C.obj C.ptr' = C.alloc' C.S.uchar (Word.fromInt Config.bufSize)
165 val bufSize = Int32.fromInt Config.bufSize
166
167 fun readOne bio =
168 let
169 val r = F_OpenSSL_SML_read.f' (bio, C.Ptr.inject' readBuf, bufSize)
170 in
171 if r = 0 then
172 NONE
173 else if r < 0 then
174 raise OpenSSL "BIO_read failed"
175 else
176 SOME (CharVector.tabulate (Int32.toInt r,
177 fn i => chr (Word32.toInt (C.Get.uchar'
178 (C.Ptr.sub' C.S.uchar (readBuf, i))))))
179 end
180
181 fun writeAll (bio, s) =
182 let
183 val buf = ZString.dupML' s
184
185 fun loop (buf, len) =
186 let
187 val r = F_OpenSSL_SML_write.f' (bio, C.Ptr.inject' buf, len)
188 in
189 if r = len then
190 ()
191 else if r <= 0 then
192 (C.free' buf;
193 raise OpenSSL "BIO_write failed")
194 else
195 loop (C.Ptr.|+! C.S.uchar (buf, Int32.toInt r), Int32.- (len, r))
196 end
197 in
198 loop (buf, Int32.fromInt (size s));
199 C.free' buf
200 end
201
202 fun request fname =
203 let
204 val bio = F_OpenSSL_SML_new_connect.f' dispatcher
205 in
206 if C.Ptr.isNull' bio then
207 (ssl_err ("Error initializating connection to dispatcher at " ^ Config.dispatcher);
208 F_OpenSSL_SML_free_all.f' bio)
209 else if F_OpenSSL_SML_do_connect.f' bio <= 0 then
210 (ssl_err ("Error connecting to dispatcher at " ^ Config.dispatcher);
211 F_OpenSSL_SML_free_all.f' bio)
212 else let
213 val inf = TextIO.openIn fname
214
215 fun loop () =
216 case TextIO.inputLine inf of
217 NONE => ()
218 | SOME line => (writeAll (bio, line);
219 loop ())
220 in
221 loop ();
222 TextIO.closeIn inf;
223 F_OpenSSL_SML_free_all.f' bio
224 end
225 end
226
227 fun serviceOne () =
228 let
229 val bio = F_OpenSSL_SML_new_accept.f' listenOn
230 in
231 if C.Ptr.isNull' bio then
232 (ssl_err "Error initializating listener";
233 F_OpenSSL_SML_free_all.f' bio)
234 else if F_OpenSSL_SML_do_accept.f' bio <= 0 then
235 (ssl_err "Error accepting connection";
236 F_OpenSSL_SML_free_all.f' bio)
237 else let
238 fun loop () =
239 case readOne bio of
240 NONE => ()
241 | SOME line => (print line;
242 loop ())
243 in
244 loop ();
245 F_OpenSSL_SML_free_all.f' bio
246 end
247 end
248
249 end