adam@1677
|
1 (* Copyright (c) 2008-2012, Adam Chlipala
|
adamc@0
|
2 * All rights reserved.
|
adamc@0
|
3 *
|
adamc@0
|
4 * Redistribution and use in source and binary forms, with or without
|
adamc@0
|
5 * modification, are permitted provided that the following conditions are met:
|
adamc@0
|
6 *
|
adamc@0
|
7 * - Redistributions of source code must retain the above copyright notice,
|
adamc@0
|
8 * this list of conditions and the following disclaimer.
|
adamc@0
|
9 * - Redistributions in binary form must reproduce the above copyright notice,
|
adamc@0
|
10 * this list of conditions and the following disclaimer in the documentation
|
adamc@0
|
11 * and/or other materials provided with the distribution.
|
adamc@0
|
12 * - The names of contributors may not be used to endorse or promote products
|
adamc@0
|
13 * derived from this software without specific prior written permission.
|
adamc@0
|
14 *
|
adamc@0
|
15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
|
adamc@0
|
16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
|
adamc@0
|
17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
adamc@0
|
18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
|
adamc@0
|
19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
adamc@0
|
20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
adamc@0
|
21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
adamc@0
|
22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
adamc@0
|
23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
adamc@0
|
24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
adamc@0
|
25 * POSSIBILITY OF SUCH DAMAGE.
|
adamc@0
|
26 *)
|
adamc@0
|
27
|
adam@1733
|
28 val socket = ".urweb_daemon"
|
adamc@857
|
29
|
adam@1733
|
30 (* Encapsulate main invocation handler in a function, possibly to be called multiple times within a daemon. *)
|
adam@1540
|
31
|
adam@1733
|
32 exception Code of OS.Process.status
|
adam@1520
|
33
|
adam@1733
|
34 fun oneRun args =
|
adam@1733
|
35 let
|
adam@1733
|
36 val timing = ref false
|
adam@1733
|
37 val tc = ref false
|
adam@1733
|
38 val sources = ref ([] : string list)
|
adam@1733
|
39 val demo = ref (NONE : (string * bool) option)
|
adam@1733
|
40 val tutorial = ref false
|
adam@1733
|
41 val css = ref false
|
adamc@208
|
42
|
adam@1733
|
43 val () = (Compiler.debug := false;
|
adam@1744
|
44 Elaborate.verbose := false;
|
adam@1733
|
45 Elaborate.dumpTypes := false;
|
adam@1745
|
46 Elaborate.dumpTypesOnError := false;
|
adam@1733
|
47 Elaborate.unifyMore := false;
|
adam@1733
|
48 Compiler.dumpSource := false;
|
adam@1733
|
49 Compiler.doIflow := false;
|
adam@1733
|
50 Demo.noEmacs := false;
|
adam@1733
|
51 Settings.setDebug false)
|
adamc@208
|
52
|
adam@1733
|
53 val () = Compiler.beforeC := MLton.GC.pack
|
adamc@279
|
54
|
adam@1733
|
55 fun printVersion () = (print (Config.versionString ^ "\n");
|
adam@1733
|
56 raise Code OS.Process.success)
|
adam@1733
|
57 fun printNumericVersion () = (print (Config.versionNumber ^ "\n");
|
adam@1733
|
58 raise Code OS.Process.success)
|
adam@1733
|
59
|
adam@1733
|
60 fun doArgs args =
|
adam@1733
|
61 case args of
|
adam@1733
|
62 [] => ()
|
adam@1733
|
63 | "-version" :: rest =>
|
grrwlf@1871
|
64 printVersion ()
|
adam@1733
|
65 | "-numeric-version" :: rest =>
|
grrwlf@1871
|
66 printNumericVersion ()
|
adam@1733
|
67 | "-css" :: rest =>
|
adam@1733
|
68 (css := true;
|
adam@1733
|
69 doArgs rest)
|
grrwlf@1871
|
70 | "-ccompiler" :: ccomp :: rest =>
|
grrwlf@1871
|
71 (Settings.setCCompiler ccomp;
|
grrwlf@1871
|
72 doArgs rest)
|
adam@1733
|
73 | "-demo" :: prefix :: rest =>
|
adam@1733
|
74 (demo := SOME (prefix, false);
|
adam@1733
|
75 doArgs rest)
|
adam@1733
|
76 | "-guided-demo" :: prefix :: rest =>
|
adam@1733
|
77 (demo := SOME (prefix, true);
|
adam@1733
|
78 doArgs rest)
|
adam@1733
|
79 | "-tutorial" :: rest =>
|
adam@1733
|
80 (tutorial := true;
|
adam@1733
|
81 doArgs rest)
|
adam@1733
|
82 | "-protocol" :: name :: rest =>
|
adam@1733
|
83 (Settings.setProtocol name;
|
adam@1733
|
84 doArgs rest)
|
adam@1733
|
85 | "-prefix" :: prefix :: rest =>
|
adam@1733
|
86 (Settings.setUrlPrefix prefix;
|
adam@1733
|
87 doArgs rest)
|
adam@1733
|
88 | "-db" :: s :: rest =>
|
adam@1733
|
89 (Settings.setDbstring (SOME s);
|
adam@1733
|
90 doArgs rest)
|
adam@1733
|
91 | "-dbms" :: name :: rest =>
|
adam@1733
|
92 (Settings.setDbms name;
|
adam@1733
|
93 doArgs rest)
|
adam@1733
|
94 | "-debug" :: rest =>
|
adam@1733
|
95 (Settings.setDebug true;
|
adam@1733
|
96 doArgs rest)
|
adam@1733
|
97 | "-verbose" :: rest =>
|
adam@1733
|
98 (Compiler.debug := true;
|
adam@1744
|
99 Elaborate.verbose := true;
|
adam@1733
|
100 doArgs rest)
|
adam@1733
|
101 | "-timing" :: rest =>
|
adam@1733
|
102 (timing := true;
|
adam@1733
|
103 doArgs rest)
|
adam@1733
|
104 | "-tc" :: rest =>
|
adam@1733
|
105 (tc := true;
|
adam@1733
|
106 doArgs rest)
|
adam@1733
|
107 | "-dumpTypes" :: rest =>
|
adam@1733
|
108 (Elaborate.dumpTypes := true;
|
adam@1733
|
109 doArgs rest)
|
adam@1745
|
110 | "-dumpTypesOnError" :: rest =>
|
adam@1745
|
111 (Elaborate.dumpTypesOnError := true;
|
adam@1745
|
112 doArgs rest)
|
adam@1733
|
113 | "-unifyMore" :: rest =>
|
adam@1733
|
114 (Elaborate.unifyMore := true;
|
adam@1733
|
115 doArgs rest)
|
adam@1733
|
116 | "-dumpSource" :: rest =>
|
adam@1733
|
117 (Compiler.dumpSource := true;
|
adam@1733
|
118 doArgs rest)
|
adam@1733
|
119 | "-output" :: s :: rest =>
|
adam@1733
|
120 (Settings.setExe (SOME s);
|
adam@1733
|
121 doArgs rest)
|
adam@1733
|
122 | "-sql" :: s :: rest =>
|
adam@1733
|
123 (Settings.setSql (SOME s);
|
adam@1733
|
124 doArgs rest)
|
adam@1733
|
125 | "-static" :: rest =>
|
adam@1733
|
126 (Settings.setStaticLinking true;
|
adam@1733
|
127 doArgs rest)
|
adam@1733
|
128 | "-path" :: name :: path :: rest =>
|
adam@1733
|
129 (Compiler.addPath (name, path);
|
adam@1733
|
130 doArgs rest)
|
adam@1733
|
131 | "-root" :: name :: root :: rest =>
|
adam@1733
|
132 (Compiler.addModuleRoot (root, name);
|
adam@1733
|
133 doArgs rest)
|
ezyang@1739
|
134 | "-boot" :: rest =>
|
ezyang@1739
|
135 (Compiler.enableBoot ();
|
ezyang@1739
|
136 Settings.setStaticLinking true;
|
ezyang@1739
|
137 doArgs rest)
|
adam@1733
|
138 | "-sigfile" :: name :: rest =>
|
adam@1733
|
139 (Settings.setSigFile (SOME name);
|
adam@1733
|
140 doArgs rest)
|
adam@1733
|
141 | "-iflow" :: rest =>
|
adam@1733
|
142 (Compiler.doIflow := true;
|
adam@1733
|
143 doArgs rest)
|
adam@1733
|
144 | "-moduleOf" :: fname :: _ =>
|
adam@1733
|
145 (print (Compiler.moduleOf fname ^ "\n");
|
adam@1733
|
146 raise Code OS.Process.success)
|
adam@1733
|
147 | "-noEmacs" :: rest =>
|
adam@1733
|
148 (Demo.noEmacs := true;
|
adam@1733
|
149 doArgs rest)
|
adam@1733
|
150 | "-limit" :: class :: num :: rest =>
|
adam@1733
|
151 (case Int.fromString num of
|
adam@1733
|
152 NONE => raise Fail ("Invalid limit number '" ^ num ^ "'")
|
adam@1733
|
153 | SOME n =>
|
adam@1733
|
154 if n < 0 then
|
adam@1733
|
155 raise Fail ("Invalid limit number '" ^ num ^ "'")
|
adam@1733
|
156 else
|
adam@1733
|
157 Settings.addLimit (class, n);
|
adam@1733
|
158 doArgs rest)
|
adam@1733
|
159 | arg :: rest =>
|
adam@1733
|
160 (if size arg > 0 andalso String.sub (arg, 0) = #"-" then
|
adam@1733
|
161 raise Fail ("Unknown flag " ^ arg)
|
adam@1733
|
162 else
|
adam@1733
|
163 sources := arg :: !sources;
|
adam@1733
|
164 doArgs rest)
|
adam@1733
|
165
|
adam@1733
|
166 val () = case args of
|
adam@1733
|
167 ["daemon", "stop"] => OS.Process.exit OS.Process.success
|
adam@1733
|
168 | _ => ()
|
adam@1733
|
169
|
adam@1733
|
170 val () = doArgs args
|
adam@1733
|
171
|
adam@1733
|
172 val job =
|
adam@1733
|
173 case !sources of
|
adam@1733
|
174 [file] => file
|
adam@1809
|
175 | files =>
|
adam@1808
|
176 if List.exists (fn s => s <> "-version") args then
|
adam@1809
|
177 raise Fail ("Zero or multiple input files specified; only one is allowed.\nFiles: "
|
adam@1809
|
178 ^ String.concatWith ", " files)
|
adam@1808
|
179 else
|
adam@1808
|
180 printVersion ()
|
adam@1733
|
181 in
|
adam@1733
|
182 case (!css, !demo, !tutorial) of
|
adam@1733
|
183 (true, _, _) =>
|
adam@1733
|
184 (case Compiler.run Compiler.toCss job of
|
adam@1733
|
185 NONE => OS.Process.failure
|
adam@1733
|
186 | SOME {Overall = ov, Classes = cl} =>
|
adam@1733
|
187 (app (print o Css.inheritableToString) ov;
|
adam@1733
|
188 print "\n";
|
adam@1733
|
189 app (fn (x, (ins, ots)) =>
|
adam@1733
|
190 (print x;
|
adam@1733
|
191 print " ";
|
adam@1733
|
192 app (print o Css.inheritableToString) ins;
|
adam@1733
|
193 app (print o Css.othersToString) ots;
|
adam@1733
|
194 print "\n")) cl;
|
adam@1733
|
195 OS.Process.success))
|
adam@1733
|
196 | (_, SOME (prefix, guided), _) =>
|
adam@1733
|
197 if Demo.make' {prefix = prefix, dirname = job, guided = guided} then
|
adam@1733
|
198 OS.Process.success
|
adam@1733
|
199 else
|
adam@1733
|
200 OS.Process.failure
|
adam@1733
|
201 | (_, _, true) => (Tutorial.make job;
|
adam@1733
|
202 OS.Process.success)
|
adam@1733
|
203 | _ =>
|
adam@1733
|
204 if !tc then
|
adam@1733
|
205 (Compiler.check Compiler.toElaborate job;
|
adam@1733
|
206 if ErrorMsg.anyErrors () then
|
adam@1733
|
207 OS.Process.failure
|
adam@1733
|
208 else
|
adam@1733
|
209 OS.Process.success)
|
adam@1733
|
210 else if !timing then
|
adam@1733
|
211 (Compiler.time Compiler.toCjrize job;
|
adam@1733
|
212 OS.Process.success)
|
adam@1733
|
213 else
|
adam@1733
|
214 (if Compiler.compile job then
|
adam@1733
|
215 OS.Process.success
|
adam@1733
|
216 else
|
adam@1733
|
217 OS.Process.failure)
|
adam@1733
|
218 end handle Code n => n
|
adam@1733
|
219
|
adam@1733
|
220 fun send (sock, s) =
|
adam@1733
|
221 let
|
adam@1733
|
222 val n = Socket.sendVec (sock, Word8VectorSlice.full (Vector.map (Word8.fromInt o ord) s))
|
adam@1733
|
223 in
|
adam@1733
|
224 if n >= size s then
|
adam@1733
|
225 ()
|
adamc@384
|
226 else
|
adam@1733
|
227 send (sock, String.extract (s, n, NONE))
|
adam@1733
|
228 end
|
adam@1733
|
229
|
adam@1733
|
230 val () = case CommandLine.arguments () of
|
adam@1733
|
231 ["daemon", "start"] =>
|
adam@1733
|
232 (case Posix.Process.fork () of
|
adam@1733
|
233 SOME _ => ()
|
adam@1733
|
234 | NONE =>
|
adam@1733
|
235 let
|
adam@1733
|
236 val () = Elaborate.incremental := true
|
adam@1733
|
237 val listen = UnixSock.Strm.socket ()
|
adam@1733
|
238
|
adam@1733
|
239 fun loop () =
|
adam@1733
|
240 let
|
adam@1733
|
241 val (sock, _) = Socket.accept listen
|
adam@1733
|
242
|
adam@1733
|
243 fun loop' (buf, args) =
|
adam@1733
|
244 let
|
adam@1733
|
245 val s = if CharVector.exists (fn ch => ch = #"\n") buf then
|
adam@1733
|
246 ""
|
adam@1733
|
247 else
|
adam@1733
|
248 Vector.map (chr o Word8.toInt) (Socket.recvVec (sock, 1024))
|
adam@1733
|
249 val s = buf ^ s
|
adam@1733
|
250 val (befor, after) = Substring.splitl (fn ch => ch <> #"\n") (Substring.full s)
|
adam@1733
|
251 in
|
adam@1733
|
252 if Substring.isEmpty after then
|
adam@1733
|
253 loop' (s, args)
|
adam@1733
|
254 else
|
adam@1733
|
255 let
|
adam@1733
|
256 val cmd = Substring.string befor
|
adam@1733
|
257 val rest = Substring.string (Substring.slice (after, 1, NONE))
|
adam@1733
|
258 in
|
adam@1733
|
259 case cmd of
|
adam@1744
|
260 "" =>
|
adam@1744
|
261 let
|
adam@1744
|
262 val success = (oneRun (rev args))
|
adam@1744
|
263 handle ex => (print "unhandled exception:\n";
|
adam@1744
|
264 print (General.exnMessage ex ^ "\n");
|
adam@1744
|
265 OS.Process.failure)
|
adam@1744
|
266 in
|
adam@1744
|
267 TextIO.flushOut TextIO.stdOut;
|
adam@1744
|
268 TextIO.flushOut TextIO.stdErr;
|
adam@1744
|
269 send (sock, if OS.Process.isSuccess success then
|
adam@1744
|
270 "\001"
|
adam@1744
|
271 else
|
adam@1744
|
272 "\002")
|
adam@1744
|
273 end
|
adam@1733
|
274 | _ => loop' (rest, cmd :: args)
|
adam@1733
|
275 end
|
adam@1733
|
276 end handle OS.SysErr _ => ()
|
adam@1744
|
277
|
adam@1744
|
278 fun redirect old =
|
adam@1744
|
279 Posix.IO.dup2 {old = valOf (Posix.FileSys.iodToFD (Socket.ioDesc sock)),
|
adam@1744
|
280 new = old}
|
adam@1744
|
281
|
adam@1744
|
282 val oldStdout = Posix.IO.dup Posix.FileSys.stdout
|
adam@1744
|
283 val oldStderr = Posix.IO.dup Posix.FileSys.stderr
|
adam@1733
|
284 in
|
adam@1744
|
285 (* Redirect the daemon's output to the socket. *)
|
adam@1744
|
286 redirect Posix.FileSys.stdout;
|
adam@1744
|
287 redirect Posix.FileSys.stderr;
|
adam@1744
|
288
|
adam@1733
|
289 loop' ("", []);
|
adam@1733
|
290 Socket.close sock;
|
adam@1744
|
291
|
adam@1744
|
292 Posix.IO.dup2 {old = oldStdout, new = Posix.FileSys.stdout};
|
adam@1744
|
293 Posix.IO.dup2 {old = oldStderr, new = Posix.FileSys.stderr};
|
adam@1744
|
294 Posix.IO.close oldStdout;
|
adam@1744
|
295 Posix.IO.close oldStderr;
|
adam@1744
|
296
|
adam@1733
|
297 MLton.GC.pack ();
|
adam@1733
|
298 loop ()
|
adam@1733
|
299 end
|
adam@1733
|
300 in
|
adam@1733
|
301 OS.Process.atExit (fn () => OS.FileSys.remove socket);
|
adam@1733
|
302 Socket.bind (listen, UnixSock.toAddr socket);
|
adam@1733
|
303 Socket.listen (listen, 1);
|
adam@1733
|
304 loop ()
|
adam@1733
|
305 end)
|
mad@1830
|
306 | ["daemon", "stop"] =>
|
mad@1830
|
307 (OS.FileSys.remove socket handle OS.SysErr _ => OS.Process.exit OS.Process.success)
|
adam@1733
|
308 | args =>
|
adam@1733
|
309 let
|
adam@1733
|
310 val sock = UnixSock.Strm.socket ()
|
adam@1733
|
311
|
adam@1733
|
312 fun wait () =
|
adam@1733
|
313 let
|
adam@1744
|
314 val v = Socket.recvVec (sock, 1024)
|
adam@1733
|
315 in
|
adam@1733
|
316 if Vector.length v = 0 then
|
adam@1733
|
317 OS.Process.failure
|
adam@1733
|
318 else
|
adam@1744
|
319 let
|
adam@1744
|
320 val s = Vector.map (chr o Word8.toInt) v
|
adam@1744
|
321 val last = Vector.sub (v, Vector.length v - 1)
|
adam@1744
|
322 val (rc, s) = if last = Word8.fromInt 1 then
|
adam@1744
|
323 (SOME OS.Process.success, String.substring (s, 0, size s - 1))
|
adam@1744
|
324 else if last = Word8.fromInt 2 then
|
adam@1744
|
325 (SOME OS.Process.failure, String.substring (s, 0, size s - 1))
|
adam@1744
|
326 else
|
adam@1744
|
327 (NONE, s)
|
adam@1744
|
328 in
|
adam@1744
|
329 print s;
|
adam@1744
|
330 case rc of
|
adam@1744
|
331 NONE => wait ()
|
adam@1744
|
332 | SOME rc => rc
|
adam@1744
|
333 end
|
adam@1733
|
334 end handle OS.SysErr _ => OS.Process.failure
|
adam@1733
|
335 in
|
adam@1733
|
336 if Socket.connectNB (sock, UnixSock.toAddr socket)
|
adam@1733
|
337 orelse not (List.null (#wrs (Socket.select {rds = [],
|
adam@1733
|
338 wrs = [Socket.sockDesc sock],
|
adam@1733
|
339 exs = [],
|
adam@1733
|
340 timeout = SOME (Time.fromSeconds 1)}))) then
|
adam@1733
|
341 (app (fn arg => send (sock, arg ^ "\n")) args;
|
adam@1733
|
342 send (sock, "\n");
|
adam@1733
|
343 OS.Process.exit (wait ()))
|
adam@1733
|
344 else
|
adam@1733
|
345 (OS.FileSys.remove socket;
|
adam@1733
|
346 raise OS.SysErr ("", NONE))
|
mad@1830
|
347 end handle OS.SysErr _ => OS.Process.exit (oneRun args)
|