Mercurial > urweb

annotate src/main.mlton.sml @ 2209:0ca11d57c175

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Cleans up interface (it's now a command line option) and renames project to "sqlcache" in the all-one-word style. Still has issues to do with concurrency, retrying transactions, and foreign function calls that either rely on state or have side effects.
author Ziv Scully <ziv@mit.edu>
date Sat, 31 May 2014 03:08:16 -0400
parents 057b08253a75
children 639e62ca2530
rev   line source
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
ziv@2209 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;
ziv@2209 50 Compiler.doSqlcache := false;
adam@1733 51 Demo.noEmacs := false;
adam@1733 52 Settings.setDebug false)
adamc@208 53
adam@1733 54 val () = Compiler.beforeC := MLton.GC.pack
adamc@279 55
adam@1733 56 fun printVersion () = (print (Config.versionString ^ "\n");
adam@1733 57 raise Code OS.Process.success)
adam@1733 58 fun printNumericVersion () = (print (Config.versionNumber ^ "\n");
adam@1733 59 raise Code OS.Process.success)
adam@1923 60 fun printCCompiler () = (print (Settings.getCCompiler () ^ "\n");
adam@1923 61 raise Code OS.Process.success)
adam@1923 62 fun printCInclude () = (print (Config.includ ^ "\n");
adam@1923 63 raise Code OS.Process.success)
adam@1733 64
adam@1733 65 fun doArgs args =
adam@1733 66 case args of
adam@1733 67 [] => ()
ziv@2209 68 | "-version" :: rest =>
grrwlf@1871 69 printVersion ()
adam@1733 70 | "-numeric-version" :: rest =>
grrwlf@1871 71 printNumericVersion ()
adam@1733 72 | "-css" :: rest =>
adam@1733 73 (css := true;
adam@1733 74 doArgs rest)
grrwlf@1872 75 | "-print-ccompiler" :: rest =>
grrwlf@1872 76 printCCompiler ()
grrwlf@1922 77 | "-print-cinclude" :: rest =>
grrwlf@1922 78 printCInclude ()
grrwlf@1871 79 | "-ccompiler" :: ccomp :: rest =>
grrwlf@1871 80 (Settings.setCCompiler ccomp;
grrwlf@1871 81 doArgs rest)
adam@1733 82 | "-demo" :: prefix :: rest =>
adam@1733 83 (demo := SOME (prefix, false);
adam@1733 84 doArgs rest)
adam@1733 85 | "-guided-demo" :: prefix :: rest =>
adam@1733 86 (demo := SOME (prefix, true);
adam@1733 87 doArgs rest)
adam@1733 88 | "-tutorial" :: rest =>
adam@1733 89 (tutorial := true;
adam@1733 90 doArgs rest)
adam@1733 91 | "-protocol" :: name :: rest =>
adam@1733 92 (Settings.setProtocol name;
adam@1733 93 doArgs rest)
adam@1733 94 | "-prefix" :: prefix :: rest =>
adam@1733 95 (Settings.setUrlPrefix prefix;
adam@1733 96 doArgs rest)
adam@1733 97 | "-db" :: s :: rest =>
adam@1733 98 (Settings.setDbstring (SOME s);
adam@1733 99 doArgs rest)
adam@1733 100 | "-dbms" :: name :: rest =>
adam@1733 101 (Settings.setDbms name;
adam@1733 102 doArgs rest)
adam@1733 103 | "-debug" :: rest =>
adam@1733 104 (Settings.setDebug true;
adam@1733 105 doArgs rest)
adam@1733 106 | "-verbose" :: rest =>
adam@1733 107 (Compiler.debug := true;
adam@1744 108 Elaborate.verbose := true;
adam@1733 109 doArgs rest)
adam@1733 110 | "-timing" :: rest =>
adam@1733 111 (timing := true;
adam@1733 112 doArgs rest)
adam@1733 113 | "-tc" :: rest =>
adam@1733 114 (tc := true;
adam@1733 115 doArgs rest)
adam@1733 116 | "-dumpTypes" :: rest =>
adam@1733 117 (Elaborate.dumpTypes := true;
adam@1733 118 doArgs rest)
adam@1745 119 | "-dumpTypesOnError" :: rest =>
adam@1745 120 (Elaborate.dumpTypesOnError := true;
adam@1745 121 doArgs rest)
adam@1733 122 | "-unifyMore" :: rest =>
adam@1733 123 (Elaborate.unifyMore := true;
adam@1733 124 doArgs rest)
adam@1733 125 | "-dumpSource" :: rest =>
adam@1733 126 (Compiler.dumpSource := true;
adam@1733 127 doArgs rest)
adam@1989 128 | "-dumpVerboseSource" :: rest =>
adam@1989 129 (Compiler.dumpSource := true;
adam@1989 130 ElabPrint.debug := true;
adam@1989 131 ExplPrint.debug := true;
adam@1989 132 CorePrint.debug := true;
adam@1989 133 MonoPrint.debug := true;
adam@1989 134 doArgs rest)
adam@1733 135 | "-output" :: s :: rest =>
adam@1733 136 (Settings.setExe (SOME s);
adam@1733 137 doArgs rest)
adam@1733 138 | "-sql" :: s :: rest =>
adam@1733 139 (Settings.setSql (SOME s);
adam@1733 140 doArgs rest)
adam@1733 141 | "-static" :: rest =>
adam@1733 142 (Settings.setStaticLinking true;
adam@1733 143 doArgs rest)
adam@1961 144 | "-stop" :: phase :: rest =>
adam@1961 145 (Compiler.setStop phase;
adam@1961 146 doArgs rest)
adam@1733 147 | "-path" :: name :: path :: rest =>
adam@1733 148 (Compiler.addPath (name, path);
adam@1733 149 doArgs rest)
adam@1733 150 | "-root" :: name :: root :: rest =>
adam@1733 151 (Compiler.addModuleRoot (root, name);
adam@1733 152 doArgs rest)
ezyang@1739 153 | "-boot" :: rest =>
ezyang@1739 154 (Compiler.enableBoot ();
ezyang@1739 155 Settings.setStaticLinking true;
ezyang@1739 156 doArgs rest)
adam@1733 157 | "-sigfile" :: name :: rest =>
adam@1733 158 (Settings.setSigFile (SOME name);
adam@1733 159 doArgs rest)
adam@1733 160 | "-iflow" :: rest =>
adam@1733 161 (Compiler.doIflow := true;
adam@1733 162 doArgs rest)
ziv@2209 163 | "-sqlcache" :: rest =>
ziv@2209 164 (Compiler.doSqlcache := true;
ziv@2209 165 doArgs rest)
adam@1733 166 | "-moduleOf" :: fname :: _ =>
adam@1733 167 (print (Compiler.moduleOf fname ^ "\n");
adam@1733 168 raise Code OS.Process.success)
adam@1733 169 | "-noEmacs" :: rest =>
adam@1733 170 (Demo.noEmacs := true;
adam@1733 171 doArgs rest)
adam@1733 172 | "-limit" :: class :: num :: rest =>
adam@1733 173 (case Int.fromString num of
adam@1733 174 NONE => raise Fail ("Invalid limit number '" ^ num ^ "'")
adam@1733 175 | SOME n =>
adam@1733 176 if n < 0 then
adam@1733 177 raise Fail ("Invalid limit number '" ^ num ^ "'")
adam@1733 178 else
adam@1733 179 Settings.addLimit (class, n);
adam@1733 180 doArgs rest)
adam@1995 181 | "-explainEmbed" :: rest =>
adam@1995 182 (JsComp.explainEmbed := true;
adam@1995 183 doArgs rest)
adam@1733 184 | arg :: rest =>
adam@1733 185 (if size arg > 0 andalso String.sub (arg, 0) = #"-" then
adam@1733 186 raise Fail ("Unknown flag " ^ arg)
adam@1733 187 else
adam@1733 188 sources := arg :: !sources;
adam@1733 189 doArgs rest)
adam@1733 190
adam@1733 191 val () = case args of
adam@1733 192 ["daemon", "stop"] => OS.Process.exit OS.Process.success
adam@1733 193 | _ => ()
adam@1733 194
adam@1733 195 val () = doArgs args
adam@1733 196
adam@1733 197 val job =
adam@1733 198 case !sources of
adam@1733 199 [file] => file
adam@1809 200 | files =>
adam@1808 201 if List.exists (fn s => s <> "-version") args then
adam@1809 202 raise Fail ("Zero or multiple input files specified; only one is allowed.\nFiles: "
adam@1809 203 ^ String.concatWith ", " files)
adam@1808 204 else
adam@1808 205 printVersion ()
adam@1733 206 in
adam@1733 207 case (!css, !demo, !tutorial) of
adam@1733 208 (true, _, _) =>
adam@1733 209 (case Compiler.run Compiler.toCss job of
adam@1733 210 NONE => OS.Process.failure
adam@1733 211 | SOME {Overall = ov, Classes = cl} =>
adam@1733 212 (app (print o Css.inheritableToString) ov;
adam@1733 213 print "\n";
adam@1733 214 app (fn (x, (ins, ots)) =>
adam@1733 215 (print x;
adam@1733 216 print " ";
adam@1733 217 app (print o Css.inheritableToString) ins;
adam@1733 218 app (print o Css.othersToString) ots;
adam@1733 219 print "\n")) cl;
adam@1733 220 OS.Process.success))
adam@1733 221 | (_, SOME (prefix, guided), _) =>
adam@1733 222 if Demo.make' {prefix = prefix, dirname = job, guided = guided} then
adam@1733 223 OS.Process.success
adam@1733 224 else
adam@1733 225 OS.Process.failure
adam@1733 226 | (_, _, true) => (Tutorial.make job;
adam@1733 227 OS.Process.success)
adam@1733 228 | _ =>
adam@1733 229 if !tc then
adam@1733 230 (Compiler.check Compiler.toElaborate job;
adam@1733 231 if ErrorMsg.anyErrors () then
adam@1733 232 OS.Process.failure
adam@1733 233 else
adam@1733 234 OS.Process.success)
adam@1733 235 else if !timing then
adam@1733 236 (Compiler.time Compiler.toCjrize job;
adam@1733 237 OS.Process.success)
adam@1733 238 else
adam@1733 239 (if Compiler.compile job then
adam@1733 240 OS.Process.success
adam@1733 241 else
adam@1733 242 OS.Process.failure)
adam@1733 243 end handle Code n => n
adam@1733 244
adam@1733 245 fun send (sock, s) =
adam@1733 246 let
adam@1733 247 val n = Socket.sendVec (sock, Word8VectorSlice.full (Vector.map (Word8.fromInt o ord) s))
adam@1733 248 in
adam@1733 249 if n >= size s then
adam@1733 250 ()
adamc@384 251 else
adam@1733 252 send (sock, String.extract (s, n, NONE))
adam@1733 253 end
adam@1733 254
adam@1733 255 val () = case CommandLine.arguments () of
adam@1733 256 ["daemon", "start"] =>
adam@1733 257 (case Posix.Process.fork () of
adam@1733 258 SOME _ => ()
adam@1733 259 | NONE =>
adam@1733 260 let
adam@1733 261 val () = Elaborate.incremental := true
adam@1733 262 val listen = UnixSock.Strm.socket ()
adam@1733 263
adam@1733 264 fun loop () =
adam@1733 265 let
adam@1733 266 val (sock, _) = Socket.accept listen
adam@1733 267
adam@1733 268 fun loop' (buf, args) =
adam@1733 269 let
adam@1733 270 val s = if CharVector.exists (fn ch => ch = #"\n") buf then
adam@1733 271 ""
adam@1733 272 else
adam@1733 273 Vector.map (chr o Word8.toInt) (Socket.recvVec (sock, 1024))
adam@1733 274 val s = buf ^ s
adam@1733 275 val (befor, after) = Substring.splitl (fn ch => ch <> #"\n") (Substring.full s)
adam@1733 276 in
adam@1733 277 if Substring.isEmpty after then
adam@1733 278 loop' (s, args)
adam@1733 279 else
adam@1733 280 let
adam@1733 281 val cmd = Substring.string befor
adam@1733 282 val rest = Substring.string (Substring.slice (after, 1, NONE))
adam@1733 283 in
adam@1733 284 case cmd of
adam@1744 285 "" =>
adam@1744 286 let
adam@1744 287 val success = (oneRun (rev args))
adam@1744 288 handle ex => (print "unhandled exception:\n";
adam@1744 289 print (General.exnMessage ex ^ "\n");
adam@1744 290 OS.Process.failure)
adam@1744 291 in
adam@1744 292 TextIO.flushOut TextIO.stdOut;
adam@1744 293 TextIO.flushOut TextIO.stdErr;
adam@1744 294 send (sock, if OS.Process.isSuccess success then
adam@1744 295 "\001"
adam@1744 296 else
adam@1744 297 "\002")
adam@1744 298 end
adam@1733 299 | _ => loop' (rest, cmd :: args)
adam@1733 300 end
adam@1733 301 end handle OS.SysErr _ => ()
adam@1744 302
adam@1744 303 fun redirect old =
adam@1744 304 Posix.IO.dup2 {old = valOf (Posix.FileSys.iodToFD (Socket.ioDesc sock)),
adam@1744 305 new = old}
adam@1744 306
adam@1744 307 val oldStdout = Posix.IO.dup Posix.FileSys.stdout
adam@1744 308 val oldStderr = Posix.IO.dup Posix.FileSys.stderr
adam@1733 309 in
adam@1744 310 (* Redirect the daemon's output to the socket. *)
adam@1744 311 redirect Posix.FileSys.stdout;
adam@1744 312 redirect Posix.FileSys.stderr;
ziv@2209 313
adam@1733 314 loop' ("", []);
adam@1733 315 Socket.close sock;
adam@1744 316
adam@1744 317 Posix.IO.dup2 {old = oldStdout, new = Posix.FileSys.stdout};
adam@1744 318 Posix.IO.dup2 {old = oldStderr, new = Posix.FileSys.stderr};
adam@1744 319 Posix.IO.close oldStdout;
adam@1744 320 Posix.IO.close oldStderr;
adam@1744 321
adam@1733 322 MLton.GC.pack ();
adam@1733 323 loop ()
adam@1733 324 end
adam@1733 325 in
adam@1733 326 OS.Process.atExit (fn () => OS.FileSys.remove socket);
adam@1733 327 Socket.bind (listen, UnixSock.toAddr socket);
adam@1733 328 Socket.listen (listen, 1);
adam@1733 329 loop ()
adam@1733 330 end)
mad@1830 331 | ["daemon", "stop"] =>
ziv@2209 332 (OS.FileSys.remove socket handle OS.SysErr _ => OS.Process.exit OS.Process.success)
adam@1733 333 | args =>
adam@1733 334 let
adam@1733 335 val sock = UnixSock.Strm.socket ()
adam@1733 336
adam@1733 337 fun wait () =
adam@1733 338 let
adam@1744 339 val v = Socket.recvVec (sock, 1024)
adam@1733 340 in
adam@1733 341 if Vector.length v = 0 then
adam@1733 342 OS.Process.failure
adam@1733 343 else
adam@1744 344 let
adam@1744 345 val s = Vector.map (chr o Word8.toInt) v
adam@1744 346 val last = Vector.sub (v, Vector.length v - 1)
adam@1744 347 val (rc, s) = if last = Word8.fromInt 1 then
adam@1744 348 (SOME OS.Process.success, String.substring (s, 0, size s - 1))
adam@1744 349 else if last = Word8.fromInt 2 then
adam@1744 350 (SOME OS.Process.failure, String.substring (s, 0, size s - 1))
adam@1744 351 else
adam@1744 352 (NONE, s)
adam@1744 353 in
adam@1744 354 print s;
adam@1744 355 case rc of
adam@1744 356 NONE => wait ()
adam@1744 357 | SOME rc => rc
adam@1744 358 end
adam@1733 359 end handle OS.SysErr _ => OS.Process.failure
adam@1733 360 in
adam@1733 361 if Socket.connectNB (sock, UnixSock.toAddr socket)
adam@1733 362 orelse not (List.null (#wrs (Socket.select {rds = [],
adam@1733 363 wrs = [Socket.sockDesc sock],
adam@1733 364 exs = [],
adam@1733 365 timeout = SOME (Time.fromSeconds 1)}))) then
adam@1733 366 (app (fn arg => send (sock, arg ^ "\n")) args;
adam@1733 367 send (sock, "\n");
adam@1733 368 OS.Process.exit (wait ()))
adam@1733 369 else
adam@1733 370 (OS.FileSys.remove socket;
adam@1733 371 raise OS.SysErr ("", NONE))
mad@1830 372 end handle OS.SysErr _ => OS.Process.exit (oneRun args)