Mercurial > urweb

comparison src/main.mlton.sml @ 1733:ab24a7cb2a64

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
'urweb daemon start' and 'urweb daemon stop'
author Adam Chlipala <adam@chlipala.net>
date Sun, 29 Apr 2012 16:23:03 -0400
parents 5ecf67553da8
children c414850f206f
comparison
equal deleted inserted replaced
1732:4a03aa3251cb 1733:ab24a7cb2a64
23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
25 * POSSIBILITY OF SUCH DAMAGE. 25 * POSSIBILITY OF SUCH DAMAGE.
26 *) 26 *)
27 27
28 val timing = ref false 28 val socket = ".urweb_daemon"
29 val tc = ref false 29
30 val sources = ref ([] : string list) 30 (* Encapsulate main invocation handler in a function, possibly to be called multiple times within a daemon. *)
31 val demo = ref (NONE : (string * bool) option) 31
32 val tutorial = ref false 32 exception Code of OS.Process.status
33 val css = ref false 33
34 34 fun oneRun args =
35 val () = Compiler.beforeC := MLton.GC.pack 35 let
36 36 val timing = ref false
37 fun printVersion () = (print (Config.versionString ^ "\n"); 37 val tc = ref false
38 OS.Process.exit OS.Process.success) 38 val sources = ref ([] : string list)
39 fun printNumericVersion () = (print (Config.versionNumber ^ "\n"); 39 val demo = ref (NONE : (string * bool) option)
40 OS.Process.exit OS.Process.success) 40 val tutorial = ref false
41 41 val css = ref false
42 fun doArgs args = 42
43 case args of 43 val () = (Compiler.debug := false;
44 [] => () 44 Elaborate.dumpTypes := false;
45 | "-version" :: rest => 45 Elaborate.unifyMore := false;
46 printVersion () 46 Compiler.dumpSource := false;
47 | "-numeric-version" :: rest => 47 Compiler.doIflow := false;
48 printNumericVersion () 48 Demo.noEmacs := false;
49 | "-css" :: rest => 49 Settings.setDebug false)
50 (css := true; 50
51 doArgs rest) 51 val () = Compiler.beforeC := MLton.GC.pack
52 | "-demo" :: prefix :: rest => 52
53 (demo := SOME (prefix, false); 53 fun printVersion () = (print (Config.versionString ^ "\n");
54 doArgs rest) 54 raise Code OS.Process.success)
55 | "-guided-demo" :: prefix :: rest => 55 fun printNumericVersion () = (print (Config.versionNumber ^ "\n");
56 (demo := SOME (prefix, true); 56 raise Code OS.Process.success)
57 doArgs rest) 57
58 | "-tutorial" :: rest => 58 fun doArgs args =
59 (tutorial := true; 59 case args of
60 doArgs rest) 60 [] => ()
61 | "-protocol" :: name :: rest => 61 | "-version" :: rest =>
62 (Settings.setProtocol name; 62 printVersion ()
63 doArgs rest) 63 | "-numeric-version" :: rest =>
64 | "-prefix" :: prefix :: rest => 64 printNumericVersion ()
65 (Settings.setUrlPrefix prefix; 65 | "-css" :: rest =>
66 doArgs rest) 66 (css := true;
67 | "-db" :: s :: rest => 67 doArgs rest)
68 (Settings.setDbstring (SOME s); 68 | "-demo" :: prefix :: rest =>
69 doArgs rest) 69 (demo := SOME (prefix, false);
70 | "-dbms" :: name :: rest => 70 doArgs rest)
71 (Settings.setDbms name; 71 | "-guided-demo" :: prefix :: rest =>
72 doArgs rest) 72 (demo := SOME (prefix, true);
73 | "-debug" :: rest => 73 doArgs rest)
74 (Settings.setDebug true; 74 | "-tutorial" :: rest =>
75 doArgs rest) 75 (tutorial := true;
76 | "-verbose" :: rest => 76 doArgs rest)
77 (Compiler.debug := true; 77 | "-protocol" :: name :: rest =>
78 doArgs rest) 78 (Settings.setProtocol name;
79 | "-timing" :: rest => 79 doArgs rest)
80 (timing := true; 80 | "-prefix" :: prefix :: rest =>
81 doArgs rest) 81 (Settings.setUrlPrefix prefix;
82 | "-tc" :: rest => 82 doArgs rest)
83 (tc := true; 83 | "-db" :: s :: rest =>
84 doArgs rest) 84 (Settings.setDbstring (SOME s);
85 | "-dumpTypes" :: rest => 85 doArgs rest)
86 (Elaborate.dumpTypes := true; 86 | "-dbms" :: name :: rest =>
87 doArgs rest) 87 (Settings.setDbms name;
88 | "-unifyMore" :: rest => 88 doArgs rest)
89 (Elaborate.unifyMore := true; 89 | "-debug" :: rest =>
90 doArgs rest) 90 (Settings.setDebug true;
91 | "-dumpSource" :: rest => 91 doArgs rest)
92 (Compiler.dumpSource := true; 92 | "-verbose" :: rest =>
93 doArgs rest) 93 (Compiler.debug := true;
94 | "-output" :: s :: rest => 94 doArgs rest)
95 (Settings.setExe (SOME s); 95 | "-timing" :: rest =>
96 doArgs rest) 96 (timing := true;
97 | "-sql" :: s :: rest => 97 doArgs rest)
98 (Settings.setSql (SOME s); 98 | "-tc" :: rest =>
99 doArgs rest) 99 (tc := true;
100 | "-static" :: rest => 100 doArgs rest)
101 (Settings.setStaticLinking true; 101 | "-dumpTypes" :: rest =>
102 doArgs rest) 102 (Elaborate.dumpTypes := true;
103 | "-path" :: name :: path :: rest => 103 doArgs rest)
104 (Compiler.addPath (name, path); 104 | "-unifyMore" :: rest =>
105 doArgs rest) 105 (Elaborate.unifyMore := true;
106 | "-root" :: name :: root :: rest => 106 doArgs rest)
107 (Compiler.addModuleRoot (root, name); 107 | "-dumpSource" :: rest =>
108 doArgs rest) 108 (Compiler.dumpSource := true;
109 | "-sigfile" :: name :: rest => 109 doArgs rest)
110 (Settings.setSigFile (SOME name); 110 | "-output" :: s :: rest =>
111 doArgs rest) 111 (Settings.setExe (SOME s);
112 | "-iflow" :: rest => 112 doArgs rest)
113 (Compiler.doIflow := true; 113 | "-sql" :: s :: rest =>
114 doArgs rest) 114 (Settings.setSql (SOME s);
115 | "-moduleOf" :: fname :: _ => 115 doArgs rest)
116 (print (Compiler.moduleOf fname ^ "\n"); 116 | "-static" :: rest =>
117 OS.Process.exit OS.Process.success) 117 (Settings.setStaticLinking true;
118 | "-noEmacs" :: rest => 118 doArgs rest)
119 (Demo.noEmacs := true; 119 | "-path" :: name :: path :: rest =>
120 doArgs rest) 120 (Compiler.addPath (name, path);
121 | "-limit" :: class :: num :: rest => 121 doArgs rest)
122 (case Int.fromString num of 122 | "-root" :: name :: root :: rest =>
123 NONE => raise Fail ("Invalid limit number '" ^ num ^ "'") 123 (Compiler.addModuleRoot (root, name);
124 | SOME n => 124 doArgs rest)
125 if n < 0 then 125 | "-sigfile" :: name :: rest =>
126 raise Fail ("Invalid limit number '" ^ num ^ "'") 126 (Settings.setSigFile (SOME name);
127 else 127 doArgs rest)
128 Settings.addLimit (class, n); 128 | "-iflow" :: rest =>
129 doArgs rest) 129 (Compiler.doIflow := true;
130 | arg :: rest => 130 doArgs rest)
131 (if size arg > 0 andalso String.sub (arg, 0) = #"-" then 131 | "-moduleOf" :: fname :: _ =>
132 raise Fail ("Unknown flag " ^ arg) 132 (print (Compiler.moduleOf fname ^ "\n");
133 else 133 raise Code OS.Process.success)
134 sources := arg :: !sources; 134 | "-noEmacs" :: rest =>
135 doArgs rest) 135 (Demo.noEmacs := true;
136 136 doArgs rest)
137 val () = doArgs (CommandLine.arguments ()) 137 | "-limit" :: class :: num :: rest =>
138 138 (case Int.fromString num of
139 val job = 139 NONE => raise Fail ("Invalid limit number '" ^ num ^ "'")
140 case !sources of 140 | SOME n =>
141 [file] => file 141 if n < 0 then
142 | _ => printVersion () 142 raise Fail ("Invalid limit number '" ^ num ^ "'")
143 143 else
144 val () = 144 Settings.addLimit (class, n);
145 case (!css, !demo, !tutorial) of 145 doArgs rest)
146 (true, _, _) => 146 | arg :: rest =>
147 (case Compiler.run Compiler.toCss job of 147 (if size arg > 0 andalso String.sub (arg, 0) = #"-" then
148 NONE => OS.Process.exit OS.Process.failure 148 raise Fail ("Unknown flag " ^ arg)
149 | SOME {Overall = ov, Classes = cl} => 149 else
150 (app (print o Css.inheritableToString) ov; 150 sources := arg :: !sources;
151 print "\n"; 151 doArgs rest)
152 app (fn (x, (ins, ots)) => 152
153 (print x; 153 val () = case args of
154 print " "; 154 ["daemon", "stop"] => OS.Process.exit OS.Process.success
155 app (print o Css.inheritableToString) ins; 155 | _ => ()
156 app (print o Css.othersToString) ots; 156
157 print "\n")) cl)) 157 val () = doArgs args
158 | (_, SOME (prefix, guided), _) => 158
159 Demo.make {prefix = prefix, dirname = job, guided = guided} 159 val job =
160 | (_, _, true) => Tutorial.make job 160 case !sources of
161 | _ => 161 [file] => file
162 if !tc then 162 | _ => printVersion ()
163 (Compiler.check Compiler.toElaborate job; 163 in
164 if ErrorMsg.anyErrors () then 164 case (!css, !demo, !tutorial) of
165 OS.Process.exit OS.Process.failure 165 (true, _, _) =>
166 else 166 (case Compiler.run Compiler.toCss job of
167 ()) 167 NONE => OS.Process.failure
168 else if !timing then 168 | SOME {Overall = ov, Classes = cl} =>
169 Compiler.time Compiler.toCjrize job 169 (app (print o Css.inheritableToString) ov;
170 print "\n";
171 app (fn (x, (ins, ots)) =>
172 (print x;
173 print " ";
174 app (print o Css.inheritableToString) ins;
175 app (print o Css.othersToString) ots;
176 print "\n")) cl;
177 OS.Process.success))
178 | (_, SOME (prefix, guided), _) =>
179 if Demo.make' {prefix = prefix, dirname = job, guided = guided} then
180 OS.Process.success
181 else
182 OS.Process.failure
183 | (_, _, true) => (Tutorial.make job;
184 OS.Process.success)
185 | _ =>
186 if !tc then
187 (Compiler.check Compiler.toElaborate job;
188 if ErrorMsg.anyErrors () then
189 OS.Process.failure
190 else
191 OS.Process.success)
192 else if !timing then
193 (Compiler.time Compiler.toCjrize job;
194 OS.Process.success)
195 else
196 (if Compiler.compile job then
197 OS.Process.success
198 else
199 OS.Process.failure)
200 end handle Code n => n
201
202 fun send (sock, s) =
203 let
204 val n = Socket.sendVec (sock, Word8VectorSlice.full (Vector.map (Word8.fromInt o ord) s))
205 in
206 if n >= size s then
207 ()
170 else 208 else
171 Compiler.compiler job 209 send (sock, String.extract (s, n, NONE))
210 end
211
212 val () = case CommandLine.arguments () of
213 ["daemon", "start"] =>
214 (case Posix.Process.fork () of
215 SOME _ => ()
216 | NONE =>
217 let
218 val () = Elaborate.incremental := true
219 val listen = UnixSock.Strm.socket ()
220
221 fun loop () =
222 let
223 val (sock, _) = Socket.accept listen
224
225 fun loop' (buf, args) =
226 let
227 val s = if CharVector.exists (fn ch => ch = #"\n") buf then
228 ""
229 else
230 Vector.map (chr o Word8.toInt) (Socket.recvVec (sock, 1024))
231 val s = buf ^ s
232 val (befor, after) = Substring.splitl (fn ch => ch <> #"\n") (Substring.full s)
233 in
234 if Substring.isEmpty after then
235 loop' (s, args)
236 else
237 let
238 val cmd = Substring.string befor
239 val rest = Substring.string (Substring.slice (after, 1, NONE))
240 in
241 case cmd of
242 "" => send (sock, if OS.Process.isSuccess ((oneRun (rev args))
243 handle ex => (print "unhandled exception:\n";
244 print (General.exnMessage ex ^ "\n");
245 OS.Process.failure)) then
246 "0"
247 else
248 "1")
249 | _ => loop' (rest, cmd :: args)
250 end
251 end handle OS.SysErr _ => ()
252 in
253 loop' ("", []);
254 Socket.close sock;
255 MLton.GC.pack ();
256 loop ()
257 end
258 in
259 OS.Process.atExit (fn () => OS.FileSys.remove socket);
260 Socket.bind (listen, UnixSock.toAddr socket);
261 Socket.listen (listen, 1);
262 loop ()
263 end)
264
265 | args =>
266 let
267 val sock = UnixSock.Strm.socket ()
268
269 fun wait () =
270 let
271 val v = Socket.recvVec (sock, 1)
272 in
273 if Vector.length v = 0 then
274 OS.Process.failure
275 else
276 case chr (Word8.toInt (Vector.sub (v, 0))) of
277 #"0" => OS.Process.success
278 | #"1" => OS.Process.failure
279 | _ => raise Fail "Weird return code from daemon"
280 end handle OS.SysErr _ => OS.Process.failure
281 in
282 if Socket.connectNB (sock, UnixSock.toAddr socket)
283 orelse not (List.null (#wrs (Socket.select {rds = [],
284 wrs = [Socket.sockDesc sock],
285 exs = [],
286 timeout = SOME (Time.fromSeconds 1)}))) then
287 (app (fn arg => send (sock, arg ^ "\n")) args;
288 send (sock, "\n");
289 OS.Process.exit (wait ()))
290 else
291 (OS.FileSys.remove socket;
292 raise OS.SysErr ("", NONE))
293 end handle OS.SysErr _ => case args of
294 ["daemon", "stop"] => (OS.FileSys.remove socket handle OS.SysErr _ => ())
295 | _ => OS.Process.exit (oneRun args)