Mercurial > urweb
comparison src/main.mlton.sml @ 1733:ab24a7cb2a64
'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) |