adam@1677: (* Copyright (c) 2008-2012, Adam Chlipala adamc@0: * All rights reserved. adamc@0: * adamc@0: * Redistribution and use in source and binary forms, with or without adamc@0: * modification, are permitted provided that the following conditions are met: adamc@0: * adamc@0: * - Redistributions of source code must retain the above copyright notice, adamc@0: * this list of conditions and the following disclaimer. adamc@0: * - Redistributions in binary form must reproduce the above copyright notice, adamc@0: * this list of conditions and the following disclaimer in the documentation adamc@0: * and/or other materials provided with the distribution. adamc@0: * - The names of contributors may not be used to endorse or promote products adamc@0: * derived from this software without specific prior written permission. adamc@0: * adamc@0: * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" adamc@0: * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE adamc@0: * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE adamc@0: * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE adamc@0: * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR adamc@0: * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF adamc@0: * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS adamc@0: * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN adamc@0: * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) adamc@0: * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE adamc@0: * POSSIBILITY OF SUCH DAMAGE. adamc@0: *) adamc@0: adam@1733: val socket = ".urweb_daemon" adamc@857: adam@1733: (* Encapsulate main invocation handler in a function, possibly to be called multiple times within a daemon. *) adam@1540: adam@1733: exception Code of OS.Process.status adam@1520: adam@1733: fun oneRun args = adam@1733: let adam@1733: val timing = ref false adam@1733: val tc = ref false adam@1733: val sources = ref ([] : string list) adam@1733: val demo = ref (NONE : (string * bool) option) adam@1733: val tutorial = ref false adam@1733: val css = ref false adamc@208: adam@1733: val () = (Compiler.debug := false; adam@1733: Elaborate.dumpTypes := false; adam@1733: Elaborate.unifyMore := false; adam@1733: Compiler.dumpSource := false; adam@1733: Compiler.doIflow := false; adam@1733: Demo.noEmacs := false; adam@1733: Settings.setDebug false) adamc@208: adam@1733: val () = Compiler.beforeC := MLton.GC.pack adamc@279: adam@1733: fun printVersion () = (print (Config.versionString ^ "\n"); adam@1733: raise Code OS.Process.success) adam@1733: fun printNumericVersion () = (print (Config.versionNumber ^ "\n"); adam@1733: raise Code OS.Process.success) adam@1733: adam@1733: fun doArgs args = adam@1733: case args of adam@1733: [] => () adam@1733: | "-version" :: rest => adam@1733: printVersion () adam@1733: | "-numeric-version" :: rest => adam@1733: printNumericVersion () adam@1733: | "-css" :: rest => adam@1733: (css := true; adam@1733: doArgs rest) adam@1733: | "-demo" :: prefix :: rest => adam@1733: (demo := SOME (prefix, false); adam@1733: doArgs rest) adam@1733: | "-guided-demo" :: prefix :: rest => adam@1733: (demo := SOME (prefix, true); adam@1733: doArgs rest) adam@1733: | "-tutorial" :: rest => adam@1733: (tutorial := true; adam@1733: doArgs rest) adam@1733: | "-protocol" :: name :: rest => adam@1733: (Settings.setProtocol name; adam@1733: doArgs rest) adam@1733: | "-prefix" :: prefix :: rest => adam@1733: (Settings.setUrlPrefix prefix; adam@1733: doArgs rest) adam@1733: | "-db" :: s :: rest => adam@1733: (Settings.setDbstring (SOME s); adam@1733: doArgs rest) adam@1733: | "-dbms" :: name :: rest => adam@1733: (Settings.setDbms name; adam@1733: doArgs rest) adam@1733: | "-debug" :: rest => adam@1733: (Settings.setDebug true; adam@1733: doArgs rest) adam@1733: | "-verbose" :: rest => adam@1733: (Compiler.debug := true; adam@1733: doArgs rest) adam@1733: | "-timing" :: rest => adam@1733: (timing := true; adam@1733: doArgs rest) adam@1733: | "-tc" :: rest => adam@1733: (tc := true; adam@1733: doArgs rest) adam@1733: | "-dumpTypes" :: rest => adam@1733: (Elaborate.dumpTypes := true; adam@1733: doArgs rest) adam@1733: | "-unifyMore" :: rest => adam@1733: (Elaborate.unifyMore := true; adam@1733: doArgs rest) adam@1733: | "-dumpSource" :: rest => adam@1733: (Compiler.dumpSource := true; adam@1733: doArgs rest) adam@1733: | "-output" :: s :: rest => adam@1733: (Settings.setExe (SOME s); adam@1733: doArgs rest) adam@1733: | "-sql" :: s :: rest => adam@1733: (Settings.setSql (SOME s); adam@1733: doArgs rest) adam@1733: | "-static" :: rest => adam@1733: (Settings.setStaticLinking true; adam@1733: doArgs rest) adam@1733: | "-path" :: name :: path :: rest => adam@1733: (Compiler.addPath (name, path); adam@1733: doArgs rest) adam@1733: | "-root" :: name :: root :: rest => adam@1733: (Compiler.addModuleRoot (root, name); adam@1733: doArgs rest) ezyang@1739: | "-boot" :: rest => ezyang@1739: (Compiler.enableBoot (); ezyang@1739: Settings.setStaticLinking true; ezyang@1739: doArgs rest) adam@1733: | "-sigfile" :: name :: rest => adam@1733: (Settings.setSigFile (SOME name); adam@1733: doArgs rest) adam@1733: | "-iflow" :: rest => adam@1733: (Compiler.doIflow := true; adam@1733: doArgs rest) adam@1733: | "-moduleOf" :: fname :: _ => adam@1733: (print (Compiler.moduleOf fname ^ "\n"); adam@1733: raise Code OS.Process.success) adam@1733: | "-noEmacs" :: rest => adam@1733: (Demo.noEmacs := true; adam@1733: doArgs rest) adam@1733: | "-limit" :: class :: num :: rest => adam@1733: (case Int.fromString num of adam@1733: NONE => raise Fail ("Invalid limit number '" ^ num ^ "'") adam@1733: | SOME n => adam@1733: if n < 0 then adam@1733: raise Fail ("Invalid limit number '" ^ num ^ "'") adam@1733: else adam@1733: Settings.addLimit (class, n); adam@1733: doArgs rest) adam@1733: | arg :: rest => adam@1733: (if size arg > 0 andalso String.sub (arg, 0) = #"-" then adam@1733: raise Fail ("Unknown flag " ^ arg) adam@1733: else adam@1733: sources := arg :: !sources; adam@1733: doArgs rest) adam@1733: adam@1733: val () = case args of adam@1733: ["daemon", "stop"] => OS.Process.exit OS.Process.success adam@1733: | _ => () adam@1733: adam@1733: val () = doArgs args adam@1733: adam@1733: val job = adam@1733: case !sources of adam@1733: [file] => file adam@1733: | _ => printVersion () adam@1733: in adam@1733: case (!css, !demo, !tutorial) of adam@1733: (true, _, _) => adam@1733: (case Compiler.run Compiler.toCss job of adam@1733: NONE => OS.Process.failure adam@1733: | SOME {Overall = ov, Classes = cl} => adam@1733: (app (print o Css.inheritableToString) ov; adam@1733: print "\n"; adam@1733: app (fn (x, (ins, ots)) => adam@1733: (print x; adam@1733: print " "; adam@1733: app (print o Css.inheritableToString) ins; adam@1733: app (print o Css.othersToString) ots; adam@1733: print "\n")) cl; adam@1733: OS.Process.success)) adam@1733: | (_, SOME (prefix, guided), _) => adam@1733: if Demo.make' {prefix = prefix, dirname = job, guided = guided} then adam@1733: OS.Process.success adam@1733: else adam@1733: OS.Process.failure adam@1733: | (_, _, true) => (Tutorial.make job; adam@1733: OS.Process.success) adam@1733: | _ => adam@1733: if !tc then adam@1733: (Compiler.check Compiler.toElaborate job; adam@1733: if ErrorMsg.anyErrors () then adam@1733: OS.Process.failure adam@1733: else adam@1733: OS.Process.success) adam@1733: else if !timing then adam@1733: (Compiler.time Compiler.toCjrize job; adam@1733: OS.Process.success) adam@1733: else adam@1733: (if Compiler.compile job then adam@1733: OS.Process.success adam@1733: else adam@1733: OS.Process.failure) adam@1733: end handle Code n => n adam@1733: adam@1733: fun send (sock, s) = adam@1733: let adam@1733: val n = Socket.sendVec (sock, Word8VectorSlice.full (Vector.map (Word8.fromInt o ord) s)) adam@1733: in adam@1733: if n >= size s then adam@1733: () adamc@384: else adam@1733: send (sock, String.extract (s, n, NONE)) adam@1733: end adam@1733: adam@1733: val () = case CommandLine.arguments () of adam@1733: ["daemon", "start"] => adam@1733: (case Posix.Process.fork () of adam@1733: SOME _ => () adam@1733: | NONE => adam@1733: let adam@1733: val () = Elaborate.incremental := true adam@1733: val listen = UnixSock.Strm.socket () adam@1733: adam@1733: fun loop () = adam@1733: let adam@1733: val (sock, _) = Socket.accept listen adam@1733: adam@1733: fun loop' (buf, args) = adam@1733: let adam@1733: val s = if CharVector.exists (fn ch => ch = #"\n") buf then adam@1733: "" adam@1733: else adam@1733: Vector.map (chr o Word8.toInt) (Socket.recvVec (sock, 1024)) adam@1733: val s = buf ^ s adam@1733: val (befor, after) = Substring.splitl (fn ch => ch <> #"\n") (Substring.full s) adam@1733: in adam@1733: if Substring.isEmpty after then adam@1733: loop' (s, args) adam@1733: else adam@1733: let adam@1733: val cmd = Substring.string befor adam@1733: val rest = Substring.string (Substring.slice (after, 1, NONE)) adam@1733: in adam@1733: case cmd of adam@1733: "" => send (sock, if OS.Process.isSuccess ((oneRun (rev args)) adam@1733: handle ex => (print "unhandled exception:\n"; adam@1733: print (General.exnMessage ex ^ "\n"); adam@1733: OS.Process.failure)) then adam@1733: "0" adam@1733: else adam@1733: "1") adam@1733: | _ => loop' (rest, cmd :: args) adam@1733: end adam@1733: end handle OS.SysErr _ => () adam@1733: in adam@1733: loop' ("", []); adam@1733: Socket.close sock; adam@1733: MLton.GC.pack (); adam@1733: loop () adam@1733: end adam@1733: in adam@1733: OS.Process.atExit (fn () => OS.FileSys.remove socket); adam@1733: Socket.bind (listen, UnixSock.toAddr socket); adam@1733: Socket.listen (listen, 1); adam@1733: loop () adam@1733: end) adam@1733: adam@1733: | args => adam@1733: let adam@1733: val sock = UnixSock.Strm.socket () adam@1733: adam@1733: fun wait () = adam@1733: let adam@1733: val v = Socket.recvVec (sock, 1) adam@1733: in adam@1733: if Vector.length v = 0 then adam@1733: OS.Process.failure adam@1733: else adam@1733: case chr (Word8.toInt (Vector.sub (v, 0))) of adam@1733: #"0" => OS.Process.success adam@1733: | #"1" => OS.Process.failure adam@1733: | _ => raise Fail "Weird return code from daemon" adam@1733: end handle OS.SysErr _ => OS.Process.failure adam@1733: in adam@1733: if Socket.connectNB (sock, UnixSock.toAddr socket) adam@1733: orelse not (List.null (#wrs (Socket.select {rds = [], adam@1733: wrs = [Socket.sockDesc sock], adam@1733: exs = [], adam@1733: timeout = SOME (Time.fromSeconds 1)}))) then adam@1733: (app (fn arg => send (sock, arg ^ "\n")) args; adam@1733: send (sock, "\n"); adam@1733: OS.Process.exit (wait ())) adam@1733: else adam@1733: (OS.FileSys.remove socket; adam@1733: raise OS.SysErr ("", NONE)) adam@1733: end handle OS.SysErr _ => case args of adam@1733: ["daemon", "stop"] => (OS.FileSys.remove socket handle OS.SysErr _ => ()) adam@1733: | _ => OS.Process.exit (oneRun args)