e680130a |
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. |
ae3a5b8c |
17 | *) |
e680130a |
18 | |
19 | (* Main interface *) |
20 | |
21 | structure Main :> MAIN = struct |
22 | |
d330d9b8 |
23 | open Ast MsgTypes Print |
e680130a |
24 | |
85af7d3e |
25 | structure SM = StringMap |
26 | |
53d222a3 |
27 | fun init () = Acl.read Config.aclFile |
e680130a |
28 | |
17ef447e |
29 | fun check' G fname = |
a11c0ff3 |
30 | let |
31 | val prog = Parse.parse fname |
32 | in |
33 | if !ErrorMsg.anyErrors then |
17ef447e |
34 | G |
a11c0ff3 |
35 | else |
53d222a3 |
36 | Tycheck.checkFile G (Defaults.tInit ()) prog |
a11c0ff3 |
37 | end |
38 | |
17ef447e |
39 | fun basis () = |
e680130a |
40 | let |
17ef447e |
41 | val dir = Posix.FileSys.opendir Config.libRoot |
42 | |
43 | fun loop files = |
44 | case Posix.FileSys.readdir dir of |
c12828f2 |
45 | NONE => (Posix.FileSys.closedir dir; |
46 | files) |
17ef447e |
47 | | SOME fname => |
48 | if String.isSuffix ".dtl" fname then |
c12828f2 |
49 | loop (OS.Path.joinDirFile {dir = Config.libRoot, |
50 | file = fname} |
17ef447e |
51 | :: files) |
52 | else |
53 | loop files |
54 | |
55 | val files = loop [] |
91c5a390 |
56 | val (_, files) = Order.order files |
17ef447e |
57 | in |
85af7d3e |
58 | if !ErrorMsg.anyErrors then |
59 | Env.empty |
60 | else |
61 | foldl (fn (fname, G) => check' G fname) Env.empty files |
17ef447e |
62 | end |
63 | |
64 | fun check fname = |
65 | let |
66 | val _ = ErrorMsg.reset () |
4e8a3f2b |
67 | val _ = Env.preTycheck () |
17ef447e |
68 | |
69 | val b = basis () |
e680130a |
70 | in |
71 | if !ErrorMsg.anyErrors then |
d330d9b8 |
72 | raise ErrorMsg.Error |
e680130a |
73 | else |
74 | let |
4cc63b03 |
75 | val _ = ErrorMsg.reset () |
17ef447e |
76 | val prog = Parse.parse fname |
e680130a |
77 | in |
add6f172 |
78 | if !ErrorMsg.anyErrors then |
d330d9b8 |
79 | raise ErrorMsg.Error |
add6f172 |
80 | else |
17ef447e |
81 | let |
53d222a3 |
82 | val G' = Tycheck.checkFile b (Defaults.tInit ()) prog |
17ef447e |
83 | in |
d330d9b8 |
84 | if !ErrorMsg.anyErrors then |
85 | raise ErrorMsg.Error |
86 | else |
87 | (G', #3 prog) |
17ef447e |
88 | end |
e680130a |
89 | end |
90 | end |
91 | |
17ef447e |
92 | fun reduce fname = |
a11c0ff3 |
93 | let |
17ef447e |
94 | val (G, body) = check fname |
a11c0ff3 |
95 | in |
96 | if !ErrorMsg.anyErrors then |
17ef447e |
97 | NONE |
a11c0ff3 |
98 | else |
17ef447e |
99 | case body of |
100 | SOME body => |
101 | let |
102 | val body' = Reduce.reduceExp G body |
103 | in |
104 | (*printd (PD.hovBox (PD.PPS.Rel 0, |
105 | [PD.string "Result:", |
106 | PD.space 1, |
107 | p_exp body']))*) |
108 | SOME body' |
109 | end |
110 | | _ => NONE |
a11c0ff3 |
111 | end |
112 | |
17ef447e |
113 | fun eval fname = |
114 | case reduce fname of |
115 | (SOME body') => |
116 | if !ErrorMsg.anyErrors then |
d330d9b8 |
117 | raise ErrorMsg.Error |
17ef447e |
118 | else |
53d222a3 |
119 | Eval.exec (Defaults.eInit ()) body' |
d330d9b8 |
120 | | NONE => raise ErrorMsg.Error |
17ef447e |
121 | |
2569e66d |
122 | val dispatcher = |
123 | Config.dispatcher ^ ":" ^ Int.toString Config.dispatcherPort |
1f8889bd |
124 | |
d330d9b8 |
125 | fun hostname () = |
126 | let |
127 | val inf = TextIO.openIn "/etc/hostname" |
128 | in |
129 | case TextIO.inputLine inf of |
130 | NONE => (TextIO.closeIn inf; raise Fail "No line in /etc/hostname") |
131 | | SOME line => (TextIO.closeIn inf; String.substring (line, 0, size line - 1)) |
132 | end |
133 | |
2569e66d |
134 | fun request fname = |
904eb905 |
135 | let |
3ff08fe1 |
136 | val uid = Posix.ProcEnv.getuid () |
137 | val user = Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid uid) |
138 | |
139 | val () = Acl.read Config.aclFile |
140 | val () = Domain.setUser user |
141 | |
bf9b0bc3 |
142 | val _ = check fname |
143 | |
53d222a3 |
144 | val uid = Posix.ProcEnv.getuid () |
145 | val user = Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid uid) |
146 | |
53d222a3 |
147 | val context = OpenSSL.context (Config.certDir ^ "/" ^ user ^ ".pem", |
514b7936 |
148 | Config.keyDir ^ "/" ^ user ^ "/key.pem", |
2569e66d |
149 | Config.trustStore) |
904eb905 |
150 | |
2569e66d |
151 | val bio = OpenSSL.connect (context, dispatcher) |
1f8889bd |
152 | |
2569e66d |
153 | val inf = TextIO.openIn fname |
154 | |
d330d9b8 |
155 | fun loop lines = |
2569e66d |
156 | case TextIO.inputLine inf of |
d330d9b8 |
157 | NONE => String.concat (List.rev lines) |
158 | | SOME line => loop (line :: lines) |
159 | |
160 | val code = loop [] |
1f8889bd |
161 | in |
2569e66d |
162 | TextIO.closeIn inf; |
d330d9b8 |
163 | Msg.send (bio, MsgConfig code); |
164 | case Msg.recv bio of |
165 | NONE => print "Server closed connection unexpectedly.\n" |
166 | | SOME m => |
167 | case m of |
168 | MsgOk => print "Configuration succeeded.\n" |
169 | | MsgError s => print ("Configuration failed: " ^ s ^ "\n") |
170 | | _ => print "Unexpected server reply.\n"; |
2569e66d |
171 | OpenSSL.close bio |
1f8889bd |
172 | end |
53d222a3 |
173 | handle ErrorMsg.Error => () |
1f8889bd |
174 | |
2569e66d |
175 | fun service () = |
904eb905 |
176 | let |
53d222a3 |
177 | val () = Acl.read Config.aclFile |
178 | |
2569e66d |
179 | val context = OpenSSL.context (Config.serverCert, |
180 | Config.serverKey, |
181 | Config.trustStore) |
d330d9b8 |
182 | val _ = Domain.set_context context |
2569e66d |
183 | |
cbb8f260 |
184 | val sock = OpenSSL.listen (context, Config.dispatcherPort) |
2569e66d |
185 | |
186 | fun loop () = |
cbb8f260 |
187 | case OpenSSL.accept sock of |
2569e66d |
188 | NONE => () |
189 | | SOME bio => |
190 | let |
53d222a3 |
191 | val user = OpenSSL.peerCN bio |
192 | val () = print ("\nConnection from " ^ user ^ "\n") |
193 | val () = Domain.setUser user |
194 | |
d330d9b8 |
195 | fun cmdLoop () = |
196 | case Msg.recv bio of |
197 | NONE => (OpenSSL.close bio |
198 | handle OpenSSL.OpenSSL _ => (); |
199 | loop ()) |
200 | | SOME m => |
201 | case m of |
202 | MsgConfig code => |
203 | let |
204 | val _ = print "Configuration:\n" |
205 | val _ = print code |
206 | val _ = print "\n" |
2569e66d |
207 | |
d330d9b8 |
208 | val outname = OS.FileSys.tmpName () |
209 | val outf = TextIO.openOut outname |
210 | in |
211 | TextIO.output (outf, code); |
212 | TextIO.closeOut outf; |
213 | (eval outname; |
214 | Msg.send (bio, MsgOk)) |
7e90e261 |
215 | handle ErrorMsg.Error => |
216 | (print "Compilation error\n"; |
217 | Msg.send (bio, |
218 | MsgError "Error during configuration evaluation")) |
219 | | OpenSSL.OpenSSL s => |
220 | (print "OpenSSL error\n"; |
221 | Msg.send (bio, |
222 | MsgError |
223 | ("Error during configuration evaluation: " |
224 | ^ s))); |
225 | OS.FileSys.remove outname; |
226 | (ignore (OpenSSL.readChar bio); |
227 | OpenSSL.close bio) |
228 | handle OpenSSL.OpenSSL _ => (); |
229 | loop () |
d330d9b8 |
230 | end |
231 | | _ => |
232 | (Msg.send (bio, MsgError "Unexpected command") |
233 | handle OpenSSL.OpenSSL _ => (); |
234 | OpenSSL.close bio |
235 | handle OpenSSL.OpenSSL _ => (); |
236 | loop ()) |
237 | in |
238 | cmdLoop () |
239 | end |
7e90e261 |
240 | handle OpenSSL.OpenSSL s => |
241 | (print ("OpenSSL error: " ^ s ^ "\n"); |
242 | OpenSSL.close bio |
243 | handle OpenSSL.OpenSSL _ => (); |
244 | loop ()) |
245 | | OS.SysErr (s, _) => |
246 | (print ("System error: " ^ s ^ "\n"); |
247 | OpenSSL.close bio |
248 | handle OpenSSL.OpenSSL _ => (); |
249 | loop ()) |
d330d9b8 |
250 | in |
0cfb3669 |
251 | print "Listening for connections....\n"; |
d330d9b8 |
252 | loop (); |
253 | OpenSSL.shutdown sock |
254 | end |
255 | |
256 | fun slave () = |
257 | let |
258 | val host = hostname () |
259 | |
260 | val context = OpenSSL.context (Config.certDir ^ "/" ^ host ^ ".pem", |
514b7936 |
261 | Config.keyDir ^ "/" ^ host ^ "/key.pem", |
d330d9b8 |
262 | Config.trustStore) |
263 | |
264 | val sock = OpenSSL.listen (context, Config.slavePort) |
265 | |
266 | fun loop () = |
267 | case OpenSSL.accept sock of |
268 | NONE => () |
269 | | SOME bio => |
270 | let |
271 | val peer = OpenSSL.peerCN bio |
272 | val () = print ("\nConnection from " ^ peer ^ "\n") |
2569e66d |
273 | in |
d330d9b8 |
274 | if peer <> Config.dispatcherName then |
275 | (print "Not authorized!\n"; |
276 | OpenSSL.close bio; |
277 | loop ()) |
278 | else let |
279 | fun loop' files = |
280 | case Msg.recv bio of |
281 | NONE => print "Dispatcher closed connection unexpectedly\n" |
282 | | SOME m => |
283 | case m of |
284 | MsgFile file => loop' (file :: files) |
285 | | MsgDoFiles => (Slave.handleChanges files; |
286 | Msg.send (bio, MsgOk)) |
287 | | _ => (print "Dispatcher sent unexpected command\n"; |
288 | Msg.send (bio, MsgError "Unexpected command")) |
289 | in |
290 | loop' []; |
291 | ignore (OpenSSL.readChar bio); |
292 | OpenSSL.close bio; |
293 | loop () |
294 | end |
91c5a390 |
295 | end handle OpenSSL.OpenSSL s => |
296 | (print ("OpenSSL error: "^ s ^ "\n"); |
297 | OpenSSL.close bio |
298 | handle OpenSSL.OpenSSL _ => (); |
299 | loop ()) |
1d2fd26b |
300 | | OS.SysErr (s, _) => |
301 | (print ("System error: "^ s ^ "\n"); |
302 | OpenSSL.close bio |
303 | handle OpenSSL.OpenSSL _ => (); |
304 | loop ()) |
904eb905 |
305 | in |
2569e66d |
306 | loop (); |
307 | OpenSSL.shutdown sock |
904eb905 |
308 | end |
309 | |
91c5a390 |
310 | fun autodocBasis outdir = |
311 | let |
312 | val dir = Posix.FileSys.opendir Config.libRoot |
313 | |
314 | fun loop files = |
315 | case Posix.FileSys.readdir dir of |
316 | NONE => (Posix.FileSys.closedir dir; |
317 | files) |
318 | | SOME fname => |
319 | if String.isSuffix ".dtl" fname then |
320 | loop (OS.Path.joinDirFile {dir = Config.libRoot, |
321 | file = fname} |
322 | :: files) |
323 | else |
324 | loop files |
325 | |
326 | val files = loop [] |
327 | in |
328 | Autodoc.autodoc {outdir = outdir, infiles = files} |
329 | end |
330 | |
e680130a |
331 | end |