Simple OpenSSL stuff in SML/NJ
[hcoop/domtool2.git] / src / main.sml
CommitLineData
234b917a
AC
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.
dac62e84 17 *)
234b917a
AC
18
19(* Main interface *)
20
21structure Main :> MAIN = struct
22
492c1cff 23open Ast Print
234b917a 24
6ae327f8
AC
25structure SM = StringMap
26
234b917a
AC
27val dmy = ErrorMsg.dummyLoc
28
559e89e9
AC
29fun 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
33val () = init ()
34
6ae327f8 35val defaultT : record ref = ref SM.empty
8a7c40fa 36val defaultV : (unit -> exp) SM.map ref = ref SM.empty
6ae327f8
AC
37
38fun 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
44fun tInit () = (TAction ((CRoot, dmy),
45 !defaultT,
46 StringMap.empty),
47 dmy)
d189ec0e
AC
48
49
234b917a 50
d189ec0e 51fun check' G fname =
a3698041 52 let
d189ec0e 53 (*val _ = print ("Check " ^ fname ^ "\n")*)
a3698041
AC
54 val prog = Parse.parse fname
55 in
56 if !ErrorMsg.anyErrors then
d189ec0e 57 G
a3698041 58 else
6ae327f8 59 Tycheck.checkFile G (tInit ()) prog
a3698041
AC
60 end
61
d189ec0e 62fun basis () =
234b917a 63 let
d189ec0e
AC
64 val dir = Posix.FileSys.opendir Config.libRoot
65
66 fun loop files =
67 case Posix.FileSys.readdir dir of
d612d62c
AC
68 NONE => (Posix.FileSys.closedir dir;
69 files)
d189ec0e
AC
70 | SOME fname =>
71 if String.isSuffix ".dtl" fname then
d612d62c
AC
72 loop (OS.Path.joinDirFile {dir = Config.libRoot,
73 file = fname}
d189ec0e
AC
74 :: files)
75 else
76 loop files
77
78 val files = loop []
79 val files = Order.order files
80 in
6ae327f8
AC
81 if !ErrorMsg.anyErrors then
82 Env.empty
83 else
84 foldl (fn (fname, G) => check' G fname) Env.empty files
d189ec0e
AC
85 end
86
87fun check fname =
88 let
89 val _ = ErrorMsg.reset ()
12adf55a 90 val _ = Env.preTycheck ()
d189ec0e
AC
91
92 val b = basis ()
234b917a
AC
93 in
94 if !ErrorMsg.anyErrors then
d189ec0e 95 (b, NONE)
234b917a
AC
96 else
97 let
7f012ffd 98 val _ = ErrorMsg.reset ()
d189ec0e 99 val prog = Parse.parse fname
234b917a 100 in
492c1cff 101 if !ErrorMsg.anyErrors then
d189ec0e 102 (Env.empty, NONE)
492c1cff 103 else
d189ec0e 104 let
6ae327f8 105 val G' = Tycheck.checkFile b (tInit ()) prog
d189ec0e
AC
106 in
107 (G', #3 prog)
108 end
234b917a
AC
109 end
110 end
111
d189ec0e 112fun reduce fname =
a3698041 113 let
d189ec0e 114 val (G, body) = check fname
a3698041
AC
115 in
116 if !ErrorMsg.anyErrors then
d189ec0e 117 NONE
a3698041 118 else
d189ec0e
AC
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
a3698041
AC
131 end
132
d189ec0e
AC
133fun eval fname =
134 case reduce fname of
135 (SOME body') =>
136 if !ErrorMsg.anyErrors then
137 ()
138 else
8a7c40fa 139 Eval.exec (SM.map (fn f => f ()) (!defaultV)) body'
d189ec0e
AC
140 | NONE => ()
141
559e89e9
AC
142val dispatcher : C.rw ZString.zstring' = ZString.dupML' Config.dispatcher
143
144fun ssl_err s =
145 let
146 val err = F_OpenSSL_SML_get_error.f ()
147 in
148 print s;
149 print "\nReason: ";
150 print (ZString.toML (F_OpenSSL_SML_lib_error_string.f err));
151 print ":";
152 print (ZString.toML (F_OpenSSL_SML_func_error_string.f err));
153 print ":";
154 print (ZString.toML (F_OpenSSL_SML_reason_error_string.f err));
155 print "\n"
156 end
157
158exception OpenSSL of string
159
160fun writeAll (bio, s) =
161 let
162 val buf = ZString.dupML' s
163
164 fun loop (buf, len) =
165 let
166 val r = F_OpenSSL_SML_write.f' (bio, C.Ptr.inject' buf, len)
167 in
168 if r = len then
169 ()
170 else if r <= 0 then
171 (C.free' buf;
172 raise OpenSSL "BIO_write failed")
173 else
174 loop (C.Ptr.|+! C.S.uchar (buf, Int32.toInt r), Int32.- (len, r))
175 end
176 in
177 loop (buf, Int32.fromInt (size s));
178 C.free' buf
179 end
180
181fun request fname =
182 let
183 val bio = F_OpenSSL_SML_new_connect.f' dispatcher
184 in
185 if C.Ptr.isNull' bio then
186 (ssl_err ("Error initializating connection to dispatcher at " ^ Config.dispatcher);
187 F_OpenSSL_SML_free_all.f' bio)
188 else if F_OpenSSL_SML_do_connect.f' bio <= 0 then
189 (ssl_err ("Error connecting to dispatcher at " ^ Config.dispatcher);
190 F_OpenSSL_SML_free_all.f' bio)
191 else let
192 val inf = TextIO.openIn fname
193
194 fun loop () =
195 case TextIO.inputLine inf of
196 NONE => ()
197 | SOME line => (writeAll (bio, line);
198 loop ())
199 in
200 loop ();
201 TextIO.closeIn inf;
202 F_OpenSSL_SML_free_all.f' bio
203 end
204 end
205
234b917a 206end