Mercurial > urweb

annotate src/main.mlton.sml @ 1739:c414850f206f

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Add support for -boot flag, which allows in-tree execution of Ur/Web The boot flag rewrites most hardcoded paths to point to the build directory, and also forces static compilation. This is convenient for developing Ur/Web, or if you cannot 'sudo make install' Ur/Web. The following changes were made: * Header files were moved to include/urweb instead of include; this lets FFI users point their C_INCLUDE_PATH at this directory at write <urweb/urweb.h>. For internal Ur/Web executables, we simply pass -I$PATH/include/urweb as normal. * Differentiate between LIB and SRCLIB; SRCLIB is Ur and JavaScript source files, while LIB is compiled products from libtool. For in-tree compilation these live in different places. * No longer reference Config for paths; instead use Settings; these settings can be changed dynamically by Compiler.enableBoot () (TODO: add a disableBoot function.) * config.h is now generated directly in include/urweb/config.h, for consistency's sake (especially since it gets installed along with the rest of the headers!) * All of the autotools build products got updated. * The linkStatic field in protocols now only contains the name of the build product, and not the absolute path. Future users have to be careful not to reference the Settings files to early, lest they get an old version (this was the source of two bugs during development of this patch.)
author Edward Z. Yang <ezyang@mit.edu>
date Wed, 02 May 2012 17:17:57 -0400
parents ab24a7cb2a64
children 6fcce0592178
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
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@1733 44 Elaborate.dumpTypes := false;
adam@1733 45 Elaborate.unifyMore := false;
adam@1733 46 Compiler.dumpSource := false;
adam@1733 47 Compiler.doIflow := false;
adam@1733 48 Demo.noEmacs := false;
adam@1733 49 Settings.setDebug false)
adamc@208 50
adam@1733 51 val () = Compiler.beforeC := MLton.GC.pack
adamc@279 52
adam@1733 53 fun printVersion () = (print (Config.versionString ^ "\n");
adam@1733 54 raise Code OS.Process.success)
adam@1733 55 fun printNumericVersion () = (print (Config.versionNumber ^ "\n");
adam@1733 56 raise Code OS.Process.success)
adam@1733 57
adam@1733 58 fun doArgs args =
adam@1733 59 case args of
adam@1733 60 [] => ()
adam@1733 61 | "-version" :: rest =>
adam@1733 62 printVersion ()
adam@1733 63 | "-numeric-version" :: rest =>
adam@1733 64 printNumericVersion ()
adam@1733 65 | "-css" :: rest =>
adam@1733 66 (css := true;
adam@1733 67 doArgs rest)
adam@1733 68 | "-demo" :: prefix :: rest =>
adam@1733 69 (demo := SOME (prefix, false);
adam@1733 70 doArgs rest)
adam@1733 71 | "-guided-demo" :: prefix :: rest =>
adam@1733 72 (demo := SOME (prefix, true);
adam@1733 73 doArgs rest)
adam@1733 74 | "-tutorial" :: rest =>
adam@1733 75 (tutorial := true;
adam@1733 76 doArgs rest)
adam@1733 77 | "-protocol" :: name :: rest =>
adam@1733 78 (Settings.setProtocol name;
adam@1733 79 doArgs rest)
adam@1733 80 | "-prefix" :: prefix :: rest =>
adam@1733 81 (Settings.setUrlPrefix prefix;
adam@1733 82 doArgs rest)
adam@1733 83 | "-db" :: s :: rest =>
adam@1733 84 (Settings.setDbstring (SOME s);
adam@1733 85 doArgs rest)
adam@1733 86 | "-dbms" :: name :: rest =>
adam@1733 87 (Settings.setDbms name;
adam@1733 88 doArgs rest)
adam@1733 89 | "-debug" :: rest =>
adam@1733 90 (Settings.setDebug true;
adam@1733 91 doArgs rest)
adam@1733 92 | "-verbose" :: rest =>
adam@1733 93 (Compiler.debug := true;
adam@1733 94 doArgs rest)
adam@1733 95 | "-timing" :: rest =>
adam@1733 96 (timing := true;
adam@1733 97 doArgs rest)
adam@1733 98 | "-tc" :: rest =>
adam@1733 99 (tc := true;
adam@1733 100 doArgs rest)
adam@1733 101 | "-dumpTypes" :: rest =>
adam@1733 102 (Elaborate.dumpTypes := true;
adam@1733 103 doArgs rest)
adam@1733 104 | "-unifyMore" :: rest =>
adam@1733 105 (Elaborate.unifyMore := true;
adam@1733 106 doArgs rest)
adam@1733 107 | "-dumpSource" :: rest =>
adam@1733 108 (Compiler.dumpSource := true;
adam@1733 109 doArgs rest)
adam@1733 110 | "-output" :: s :: rest =>
adam@1733 111 (Settings.setExe (SOME s);
adam@1733 112 doArgs rest)
adam@1733 113 | "-sql" :: s :: rest =>
adam@1733 114 (Settings.setSql (SOME s);
adam@1733 115 doArgs rest)
adam@1733 116 | "-static" :: rest =>
adam@1733 117 (Settings.setStaticLinking true;
adam@1733 118 doArgs rest)
adam@1733 119 | "-path" :: name :: path :: rest =>
adam@1733 120 (Compiler.addPath (name, path);
adam@1733 121 doArgs rest)
adam@1733 122 | "-root" :: name :: root :: rest =>
adam@1733 123 (Compiler.addModuleRoot (root, name);
adam@1733 124 doArgs rest)
ezyang@1739 125 | "-boot" :: rest =>
ezyang@1739 126 (Compiler.enableBoot ();
ezyang@1739 127 Settings.setStaticLinking true;
ezyang@1739 128 doArgs rest)
adam@1733 129 | "-sigfile" :: name :: rest =>
adam@1733 130 (Settings.setSigFile (SOME name);
adam@1733 131 doArgs rest)
adam@1733 132 | "-iflow" :: rest =>
adam@1733 133 (Compiler.doIflow := true;
adam@1733 134 doArgs rest)
adam@1733 135 | "-moduleOf" :: fname :: _ =>
adam@1733 136 (print (Compiler.moduleOf fname ^ "\n");
adam@1733 137 raise Code OS.Process.success)
adam@1733 138 | "-noEmacs" :: rest =>
adam@1733 139 (Demo.noEmacs := true;
adam@1733 140 doArgs rest)
adam@1733 141 | "-limit" :: class :: num :: rest =>
adam@1733 142 (case Int.fromString num of
adam@1733 143 NONE => raise Fail ("Invalid limit number '" ^ num ^ "'")
adam@1733 144 | SOME n =>
adam@1733 145 if n < 0 then
adam@1733 146 raise Fail ("Invalid limit number '" ^ num ^ "'")
adam@1733 147 else
adam@1733 148 Settings.addLimit (class, n);
adam@1733 149 doArgs rest)
adam@1733 150 | arg :: rest =>
adam@1733 151 (if size arg > 0 andalso String.sub (arg, 0) = #"-" then
adam@1733 152 raise Fail ("Unknown flag " ^ arg)
adam@1733 153 else
adam@1733 154 sources := arg :: !sources;
adam@1733 155 doArgs rest)
adam@1733 156
adam@1733 157 val () = case args of
adam@1733 158 ["daemon", "stop"] => OS.Process.exit OS.Process.success
adam@1733 159 | _ => ()
adam@1733 160
adam@1733 161 val () = doArgs args
adam@1733 162
adam@1733 163 val job =
adam@1733 164 case !sources of
adam@1733 165 [file] => file
adam@1733 166 | _ => printVersion ()
adam@1733 167 in
adam@1733 168 case (!css, !demo, !tutorial) of
adam@1733 169 (true, _, _) =>
adam@1733 170 (case Compiler.run Compiler.toCss job of
adam@1733 171 NONE => OS.Process.failure
adam@1733 172 | SOME {Overall = ov, Classes = cl} =>
adam@1733 173 (app (print o Css.inheritableToString) ov;
adam@1733 174 print "\n";
adam@1733 175 app (fn (x, (ins, ots)) =>
adam@1733 176 (print x;
adam@1733 177 print " ";
adam@1733 178 app (print o Css.inheritableToString) ins;
adam@1733 179 app (print o Css.othersToString) ots;
adam@1733 180 print "\n")) cl;
adam@1733 181 OS.Process.success))
adam@1733 182 | (_, SOME (prefix, guided), _) =>
adam@1733 183 if Demo.make' {prefix = prefix, dirname = job, guided = guided} then
adam@1733 184 OS.Process.success
adam@1733 185 else
adam@1733 186 OS.Process.failure
adam@1733 187 | (_, _, true) => (Tutorial.make job;
adam@1733 188 OS.Process.success)
adam@1733 189 | _ =>
adam@1733 190 if !tc then
adam@1733 191 (Compiler.check Compiler.toElaborate job;
adam@1733 192 if ErrorMsg.anyErrors () then
adam@1733 193 OS.Process.failure
adam@1733 194 else
adam@1733 195 OS.Process.success)
adam@1733 196 else if !timing then
adam@1733 197 (Compiler.time Compiler.toCjrize job;
adam@1733 198 OS.Process.success)
adam@1733 199 else
adam@1733 200 (if Compiler.compile job then
adam@1733 201 OS.Process.success
adam@1733 202 else
adam@1733 203 OS.Process.failure)
adam@1733 204 end handle Code n => n
adam@1733 205
adam@1733 206 fun send (sock, s) =
adam@1733 207 let
adam@1733 208 val n = Socket.sendVec (sock, Word8VectorSlice.full (Vector.map (Word8.fromInt o ord) s))
adam@1733 209 in
adam@1733 210 if n >= size s then
adam@1733 211 ()
adamc@384 212 else
adam@1733 213 send (sock, String.extract (s, n, NONE))
adam@1733 214 end
adam@1733 215
adam@1733 216 val () = case CommandLine.arguments () of
adam@1733 217 ["daemon", "start"] =>
adam@1733 218 (case Posix.Process.fork () of
adam@1733 219 SOME _ => ()
adam@1733 220 | NONE =>
adam@1733 221 let
adam@1733 222 val () = Elaborate.incremental := true
adam@1733 223 val listen = UnixSock.Strm.socket ()
adam@1733 224
adam@1733 225 fun loop () =
adam@1733 226 let
adam@1733 227 val (sock, _) = Socket.accept listen
adam@1733 228
adam@1733 229 fun loop' (buf, args) =
adam@1733 230 let
adam@1733 231 val s = if CharVector.exists (fn ch => ch = #"\n") buf then
adam@1733 232 ""
adam@1733 233 else
adam@1733 234 Vector.map (chr o Word8.toInt) (Socket.recvVec (sock, 1024))
adam@1733 235 val s = buf ^ s
adam@1733 236 val (befor, after) = Substring.splitl (fn ch => ch <> #"\n") (Substring.full s)
adam@1733 237 in
adam@1733 238 if Substring.isEmpty after then
adam@1733 239 loop' (s, args)
adam@1733 240 else
adam@1733 241 let
adam@1733 242 val cmd = Substring.string befor
adam@1733 243 val rest = Substring.string (Substring.slice (after, 1, NONE))
adam@1733 244 in
adam@1733 245 case cmd of
adam@1733 246 "" => send (sock, if OS.Process.isSuccess ((oneRun (rev args))
adam@1733 247 handle ex => (print "unhandled exception:\n";
adam@1733 248 print (General.exnMessage ex ^ "\n");
adam@1733 249 OS.Process.failure)) then
adam@1733 250 "0"
adam@1733 251 else
adam@1733 252 "1")
adam@1733 253 | _ => loop' (rest, cmd :: args)
adam@1733 254 end
adam@1733 255 end handle OS.SysErr _ => ()
adam@1733 256 in
adam@1733 257 loop' ("", []);
adam@1733 258 Socket.close sock;
adam@1733 259 MLton.GC.pack ();
adam@1733 260 loop ()
adam@1733 261 end
adam@1733 262 in
adam@1733 263 OS.Process.atExit (fn () => OS.FileSys.remove socket);
adam@1733 264 Socket.bind (listen, UnixSock.toAddr socket);
adam@1733 265 Socket.listen (listen, 1);
adam@1733 266 loop ()
adam@1733 267 end)
adam@1733 268
adam@1733 269 | args =>
adam@1733 270 let
adam@1733 271 val sock = UnixSock.Strm.socket ()
adam@1733 272
adam@1733 273 fun wait () =
adam@1733 274 let
adam@1733 275 val v = Socket.recvVec (sock, 1)
adam@1733 276 in
adam@1733 277 if Vector.length v = 0 then
adam@1733 278 OS.Process.failure
adam@1733 279 else
adam@1733 280 case chr (Word8.toInt (Vector.sub (v, 0))) of
adam@1733 281 #"0" => OS.Process.success
adam@1733 282 | #"1" => OS.Process.failure
adam@1733 283 | _ => raise Fail "Weird return code from daemon"
adam@1733 284 end handle OS.SysErr _ => OS.Process.failure
adam@1733 285 in
adam@1733 286 if Socket.connectNB (sock, UnixSock.toAddr socket)
adam@1733 287 orelse not (List.null (#wrs (Socket.select {rds = [],
adam@1733 288 wrs = [Socket.sockDesc sock],
adam@1733 289 exs = [],
adam@1733 290 timeout = SOME (Time.fromSeconds 1)}))) then
adam@1733 291 (app (fn arg => send (sock, arg ^ "\n")) args;
adam@1733 292 send (sock, "\n");
adam@1733 293 OS.Process.exit (wait ()))
adam@1733 294 else
adam@1733 295 (OS.FileSys.remove socket;
adam@1733 296 raise OS.SysErr ("", NONE))
adam@1733 297 end handle OS.SysErr _ => case args of
adam@1733 298 ["daemon", "stop"] => (OS.FileSys.remove socket handle OS.SysErr _ => ())
adam@1733 299 | _ => OS.Process.exit (oneRun args)