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@1744: Elaborate.verbose := false; adam@1733: Elaborate.dumpTypes := false; adam@1745: Elaborate.dumpTypesOnError := 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@1923: fun printCCompiler () = (print (Settings.getCCompiler () ^ "\n"); adam@1923: raise Code OS.Process.success) adam@1923: fun printCInclude () = (print (Config.includ ^ "\n"); adam@1923: raise Code OS.Process.success) adam@1733: adam@1733: fun doArgs args = adam@1733: case args of adam@1733: [] => () adam@1733: | "-version" :: rest => grrwlf@1871: printVersion () adam@1733: | "-numeric-version" :: rest => grrwlf@1871: printNumericVersion () adam@1733: | "-css" :: rest => adam@1733: (css := true; adam@1733: doArgs rest) grrwlf@1872: | "-print-ccompiler" :: rest => grrwlf@1872: printCCompiler () grrwlf@1922: | "-print-cinclude" :: rest => grrwlf@1922: printCInclude () grrwlf@1871: | "-ccompiler" :: ccomp :: rest => grrwlf@1871: (Settings.setCCompiler ccomp; grrwlf@1871: 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@1744: Elaborate.verbose := 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@1745: | "-dumpTypesOnError" :: rest => adam@1745: (Elaborate.dumpTypesOnError := true; adam@1745: 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@1989: | "-dumpVerboseSource" :: rest => adam@1989: (Compiler.dumpSource := true; adam@1989: ElabPrint.debug := true; adam@1989: ExplPrint.debug := true; adam@1989: CorePrint.debug := true; adam@1989: MonoPrint.debug := true; adam@1989: 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@1961: | "-stop" :: phase :: rest => adam@1961: (Compiler.setStop phase; adam@1961: 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@1995: | "-explainEmbed" :: rest => adam@1995: (JsComp.explainEmbed := true; adam@1995: 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@1809: | files => adam@1808: if List.exists (fn s => s <> "-version") args then adam@1809: raise Fail ("Zero or multiple input files specified; only one is allowed.\nFiles: " adam@1809: ^ String.concatWith ", " files) adam@1808: else adam@1808: 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@1744: "" => adam@2192: (case args of adam@2192: ["stop", "daemon"] => adam@2192: (((Socket.close listen; adam@2192: OS.FileSys.remove socket) handle OS.SysErr _ => ()); adam@2192: OS.Process.exit OS.Process.success) adam@2192: | _ => adam@2192: let adam@2192: val success = (oneRun (rev args)) adam@2192: handle ex => (print "unhandled exception:\n"; adam@2192: print (General.exnMessage ex ^ "\n"); adam@2192: OS.Process.failure) adam@2192: in adam@2192: TextIO.flushOut TextIO.stdOut; adam@2192: TextIO.flushOut TextIO.stdErr; adam@2192: send (sock, if OS.Process.isSuccess success then adam@2192: "\001" adam@2192: else adam@2192: "\002") adam@2192: end) adam@1733: | _ => loop' (rest, cmd :: args) adam@1733: end adam@1733: end handle OS.SysErr _ => () adam@1744: adam@1744: fun redirect old = adam@1744: Posix.IO.dup2 {old = valOf (Posix.FileSys.iodToFD (Socket.ioDesc sock)), adam@1744: new = old} adam@1744: adam@1744: val oldStdout = Posix.IO.dup Posix.FileSys.stdout adam@1744: val oldStderr = Posix.IO.dup Posix.FileSys.stderr adam@1733: in adam@1744: (* Redirect the daemon's output to the socket. *) adam@1744: redirect Posix.FileSys.stdout; adam@1744: redirect Posix.FileSys.stderr; adam@1744: adam@1733: loop' ("", []); adam@1733: Socket.close sock; adam@1744: adam@1744: Posix.IO.dup2 {old = oldStdout, new = Posix.FileSys.stdout}; adam@1744: Posix.IO.dup2 {old = oldStderr, new = Posix.FileSys.stderr}; adam@1744: Posix.IO.close oldStdout; adam@1744: Posix.IO.close oldStderr; adam@1744: adam@2192: Settings.reset (); 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: | args => adam@1733: let adam@1733: val sock = UnixSock.Strm.socket () adam@1733: adam@1733: fun wait () = adam@1733: let adam@1744: val v = Socket.recvVec (sock, 1024) adam@1733: in adam@1733: if Vector.length v = 0 then adam@1733: OS.Process.failure adam@1733: else adam@1744: let adam@1744: val s = Vector.map (chr o Word8.toInt) v adam@1744: val last = Vector.sub (v, Vector.length v - 1) adam@1744: val (rc, s) = if last = Word8.fromInt 1 then adam@1744: (SOME OS.Process.success, String.substring (s, 0, size s - 1)) adam@1744: else if last = Word8.fromInt 2 then adam@1744: (SOME OS.Process.failure, String.substring (s, 0, size s - 1)) adam@1744: else adam@1744: (NONE, s) adam@1744: in adam@1744: print s; adam@1744: case rc of adam@1744: NONE => wait () adam@1744: | SOME rc => rc adam@1744: end 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)) mad@1830: end handle OS.SysErr _ => OS.Process.exit (oneRun args)