summaryrefslogtreecommitdiff
path: root/src/main.mlton.sml
diff options
context:
space:
mode:
Diffstat (limited to 'src/main.mlton.sml')
-rw-r--r--src/main.mlton.sml612
1 files changed, 344 insertions, 268 deletions
diff --git a/src/main.mlton.sml b/src/main.mlton.sml
index 2caa43f8..9042307a 100644
--- a/src/main.mlton.sml
+++ b/src/main.mlton.sml
@@ -27,15 +27,92 @@
val socket = ".urweb_daemon"
+exception Code of OS.Process.status
+
+datatype flag_arity =
+ ZERO of (unit -> unit)
+ | ONE of string * (string -> unit)
+ | TWO of string * string * (string * string -> unit)
+
+fun parse_flags flag_info args =
+ let
+ fun search_pred flag0 =
+ (* Remove preceding "-". *)
+ let val flag0 = String.extract (flag0, 1, NONE)
+ in
+ fn (flag1, _, _) => flag0 = flag1
+ end
+
+ fun normalizeArg arg =
+ case arg of
+ "-h" => "-help"
+ | "--h" => "-help"
+ | "--help" => "-help"
+ | _ => arg
+
+ fun loop [] : string list = []
+ | loop (arg :: args) =
+ let
+ val arg = normalizeArg arg
+ in
+ if String.isPrefix "-" arg then
+ case List.find (search_pred arg) flag_info of
+ NONE => raise Fail ("Unknown flag "^arg^", see -help")
+ | SOME x => exec x args
+ else
+ arg :: loop args
+ end
+
+ and exec (_, ZERO f, _) args =
+ (f (); loop args)
+ | exec (_, ONE (_, f), _) (x :: args) =
+ (f x; loop args)
+ | exec (_, TWO (_, _, f), _) (x :: y :: args) =
+ (f (x, y); loop args)
+ | exec (flag, ONE _, _) [] =
+ raise Fail ("Flag "^flag^" is missing an argument, see -help")
+ | exec (flag, TWO _, _) [] =
+ raise Fail ("Flag "^flag^" is missing two arguments, see -help")
+ | exec (flag, TWO _, _) [_] =
+ raise Fail ("Flag "^flag^" is missing an argument, see -help")
+ in
+ loop args
+ end
+
+fun usage flag_info =
+ let
+ val name = CommandLine.name ()
+
+ fun print_desc NONE = print "\n"
+ | print_desc (SOME s) = (print " : "; print s; print "\n")
+
+ fun print_args (ZERO _) = ()
+ | print_args (ONE (x, _)) = print (" " ^ x)
+ | print_args (TWO (x, y, _)) = print (" " ^ x ^ " " ^ y)
+
+ fun print_flag (flag, args, desc) =
+ (print (" -" ^ flag);
+ print_args args;
+ print_desc desc)
+ in
+ print "usage: \n";
+ print (" " ^ name ^ " daemon [stop|start]\n");
+ print (" " ^ name ^ " [flag ...] project-name\n");
+ print "Supported flags are:\n";
+ app print_flag flag_info;
+ raise Code OS.Process.success
+ end
+
+
+
(* Encapsulate main invocation handler in a function, possibly to be called multiple times within a daemon. *)
-exception Code of OS.Process.status
+exception DaemonExit
fun oneRun args =
let
val timing = ref false
val tc = ref false
- val sources = ref ([] : string list)
val demo = ref (NONE : (string * bool) option)
val tutorial = ref false
val css = ref false
@@ -52,162 +129,150 @@ fun oneRun args =
val () = Compiler.beforeC := MLton.GC.pack
- fun printVersion () = (print (Config.versionString ^ "\n");
- raise Code OS.Process.success)
- fun printNumericVersion () = (print (Config.versionNumber ^ "\n");
- raise Code OS.Process.success)
- fun printCCompiler () = (print (Settings.getCCompiler () ^ "\n");
- raise Code OS.Process.success)
- fun printCInclude () = (print (Config.includ ^ "\n");
- raise Code OS.Process.success)
-
- fun doArgs args =
- case args of
- [] => ()
- | "-version" :: rest =>
- printVersion ()
- | "-numeric-version" :: rest =>
- printNumericVersion ()
- | "-css" :: rest =>
- (css := true;
- doArgs rest)
- | "-print-ccompiler" :: rest =>
- printCCompiler ()
- | "-print-cinclude" :: rest =>
- printCInclude ()
- | "-ccompiler" :: ccomp :: rest =>
- (Settings.setCCompiler ccomp;
- doArgs rest)
- | "-demo" :: prefix :: rest =>
- (demo := SOME (prefix, false);
- doArgs rest)
- | "-guided-demo" :: prefix :: rest =>
- (demo := SOME (prefix, true);
- doArgs rest)
- | "-tutorial" :: rest =>
- (tutorial := true;
- doArgs rest)
- | "-protocol" :: name :: rest =>
- (Settings.setProtocol name;
- doArgs rest)
- | "-prefix" :: prefix :: rest =>
- (Settings.setUrlPrefix prefix;
- doArgs rest)
- | "-db" :: s :: rest =>
- (Settings.setDbstring (SOME s);
- doArgs rest)
- | "-dbms" :: name :: rest =>
- (Settings.setDbms name;
- doArgs rest)
- | "-debug" :: rest =>
- (Settings.setDebug true;
- doArgs rest)
- | "-verbose" :: rest =>
- (Compiler.debug := true;
- Elaborate.verbose := true;
- doArgs rest)
- | "-timing" :: rest =>
- (timing := true;
- doArgs rest)
- | "-tc" :: rest =>
- (tc := true;
- doArgs rest)
- | "-dumpTypes" :: rest =>
- (Elaborate.dumpTypes := true;
- doArgs rest)
- | "-dumpTypesOnError" :: rest =>
- (Elaborate.dumpTypesOnError := true;
- doArgs rest)
- | "-unifyMore" :: rest =>
- (Elaborate.unifyMore := true;
- doArgs rest)
- | "-dumpSource" :: rest =>
- (Compiler.dumpSource := true;
- doArgs rest)
- | "-dumpVerboseSource" :: rest =>
- (Compiler.dumpSource := true;
- ElabPrint.debug := true;
- ExplPrint.debug := true;
- CorePrint.debug := true;
- MonoPrint.debug := true;
- doArgs rest)
- | "-output" :: s :: rest =>
- (Settings.setExe (SOME s);
- doArgs rest)
- | "-js" :: s :: rest =>
- (Settings.setOutputJsFile (SOME s);
- doArgs rest)
- | "-sql" :: s :: rest =>
- (Settings.setSql (SOME s);
- doArgs rest)
- | "-static" :: rest =>
- (Settings.setStaticLinking true;
- doArgs rest)
- | "-stop" :: phase :: rest =>
- (Compiler.setStop phase;
- doArgs rest)
- | "-path" :: name :: path :: rest =>
- (Compiler.addPath (name, path);
- doArgs rest)
- | "-root" :: name :: root :: rest =>
- (Compiler.addModuleRoot (root, name);
- doArgs rest)
- | "-boot" :: rest =>
- (Compiler.enableBoot ();
- Settings.setBootLinking true;
- doArgs rest)
- | "-sigfile" :: name :: rest =>
- (Settings.setSigFile (SOME name);
- doArgs rest)
- | "-iflow" :: rest =>
- (Compiler.doIflow := true;
- doArgs rest)
- | "-sqlcache" :: rest =>
- (Settings.setSqlcache true;
- doArgs rest)
- | "-heuristic" :: h :: rest =>
- (Sqlcache.setHeuristic h;
- doArgs rest)
- | "-moduleOf" :: fname :: _ =>
- (print (Compiler.moduleOf fname ^ "\n");
- raise Code OS.Process.success)
- | "-noEmacs" :: rest =>
- (Demo.noEmacs := true;
- doArgs rest)
- | "-limit" :: class :: num :: rest =>
- (case Int.fromString num of
- NONE => raise Fail ("Invalid limit number '" ^ num ^ "'")
- | SOME n =>
- if n < 0 then
- raise Fail ("Invalid limit number '" ^ num ^ "'")
- else
- Settings.addLimit (class, n);
- doArgs rest)
- | "-explainEmbed" :: rest =>
- (JsComp.explainEmbed := true;
- doArgs rest)
- | arg :: rest =>
- (if size arg > 0 andalso String.sub (arg, 0) = #"-" then
- raise Fail ("Unknown flag " ^ arg)
+ fun print_and_exit msg () =
+ (print msg; print "\n";
+ raise Code OS.Process.success)
+
+ val printVersion = print_and_exit Config.versionString
+ val printNumericVersion = print_and_exit Config.versionNumber
+ fun printCCompiler () = print_and_exit (Settings.getCCompiler ()) ()
+ val printCInclude = print_and_exit Config.includ
+
+ fun printModuleOf fname =
+ print_and_exit (Compiler.moduleOf fname) ()
+
+ fun add_class (class, num) =
+ case Int.fromString num of
+ NONE => raise Fail ("Invalid limit number '" ^ num ^ "'")
+ | SOME n =>
+ if n < 0 then
+ raise Fail ("Invalid limit number '" ^ num ^ "'")
else
- sources := arg :: !sources;
- doArgs rest)
+ Settings.addLimit (class, n)
+
+ fun set_true flag = ZERO (fn () => flag := true)
+ fun call_true f = ZERO (fn () => f true)
+
+ (* This is a function, and not simply a value, because it
+ * is recursive in the help-flag. *)
+ fun flag_info () = [
+ ("help", ZERO (fn () => usage (flag_info ())),
+ SOME "print this overview"),
+ ("version", ZERO printVersion,
+ SOME "print version number and exit"),
+ ("numeric-version", ZERO printNumericVersion,
+ SOME "print numeric version number and exit"),
+ ("css", set_true css,
+ SOME "print categories of CSS properties"),
+ ("print-ccompiler", ZERO printCCompiler,
+ SOME "print C compiler and exit"),
+ ("print-cinclude", ZERO printCInclude,
+ SOME "print directory of C headers and exit"),
+ ("ccompiler", ONE ("<program>", Settings.setCCompiler),
+ SOME "set the C compiler to <program>"),
+ ("demo", ONE ("<prefix>", fn prefix =>
+ demo := SOME (prefix, false)),
+ NONE),
+ ("guided-demo", ONE ("<prefix>", fn prefix =>
+ demo := SOME (prefix, true)),
+ NONE),
+ ("tutorial", set_true tutorial,
+ SOME "render HTML tutorials from .ur source files"),
+ ("protocol", ONE ("[http|cgi|fastcgi|static]",
+ Settings.setProtocol),
+ SOME "set server protocol"),
+ ("prefix", ONE ("<prefix>", Settings.setUrlPrefix),
+ SOME "set prefix used before all URI's"),
+ ("db", ONE ("<string>", Settings.setDbstring o SOME),
+ SOME "database connection information"),
+ ("dbms", ONE ("[sqlite|mysql|postgres]", Settings.setDbms),
+ SOME "select database engine"),
+ ("debug", call_true Settings.setDebug,
+ SOME "save some intermediate C files"),
+ ("verbose", ZERO (fn () =>
+ (Compiler.debug := true;
+ Elaborate.verbose := true)),
+ NONE),
+ ("timing", set_true timing,
+ SOME "time compilation phases"),
+ ("tc", set_true tc,
+ SOME "stop after type checking"),
+ ("dumpTypes", set_true Elaborate.dumpTypes,
+ SOME "print kinds and types"),
+ ("dumpTypesOnError", set_true Elaborate.dumpTypesOnError,
+ SOME "print kinds and types if there is an error"),
+ ("unifyMore", set_true Elaborate.unifyMore,
+ SOME "continue unification before reporting type error"),
+ ("dumpSource", set_true Compiler.dumpSource,
+ SOME ("print source code of last intermediate program "^
+ "if there is an error")),
+ ("dumpVerboseSource", ZERO (fn () =>
+ (Compiler.dumpSource := true;
+ ElabPrint.debug := true;
+ ExplPrint.debug := true;
+ CorePrint.debug := true;
+ MonoPrint.debug := true)),
+ NONE),
+ ("output", ONE ("<file>", Settings.setExe o SOME),
+ SOME "output executable as <file>"),
+ ("js", ONE ("<file>", Settings.setOutputJsFile o SOME),
+ SOME "serve JavaScript as <file>"),
+ ("sql", ONE ("<file>", Settings.setSql o SOME),
+ SOME "output sql script as <file>"),
+ ("endpoints", ONE ("<file>", Settings.setEndpoints o SOME),
+ SOME "output exposed URL endpoints in JSON as <file>"),
+ ("static", call_true Settings.setStaticLinking,
+ SOME "enable static linking"),
+ ("stop", ONE ("<phase>", Compiler.setStop),
+ SOME "stop compilation after <phase>"),
+ ("path", TWO ("<name>", "<path>", Compiler.addPath),
+ SOME ("set path variable <name> to <path> for use in "^
+ ".urp files")),
+ ("root", TWO ("<name>", "<path>",
+ (fn (name, path) =>
+ Compiler.addModuleRoot (path, name))),
+ SOME "prefix names of modules found in <path> with <name>"),
+ ("boot", ZERO (fn () =>
+ (Compiler.enableBoot ();
+ Settings.setBootLinking true)),
+ SOME ("run from build tree and generate statically linked "^
+ "executables ")),
+ ("sigfile", ONE ("<file>", Settings.setSigFile o SOME),
+ SOME "search for cryptographic signing keys in <file>"),
+ ("iflow", set_true Compiler.doIflow,
+ NONE),
+ ("sqlcache", call_true Settings.setSqlcache,
+ NONE),
+ ("heuristic", ONE ("<h>", Sqlcache.setHeuristic),
+ NONE),
+ ("moduleOf", ONE ("<file>", printModuleOf),
+ SOME "print module name of <file> and exit"),
+ ("startLspServer", ZERO Lsp.startServer, SOME "Start Language Server Protocol server"),
+ ("noEmacs", set_true Demo.noEmacs,
+ NONE),
+ ("limit", TWO ("<class>", "<num>", add_class),
+ SOME "set resource usage limit for <class> to <num>"),
+ ("explainEmbed", set_true JsComp.explainEmbed,
+ SOME ("explain errors about embedding of server-side "^
+ "values in client code"))
+ ]
val () = case args of
- ["daemon", "stop"] => OS.Process.exit OS.Process.success
+ ["daemon", "stop"] => (OS.FileSys.remove socket handle OS.SysErr _ => ();
+ raise DaemonExit)
| _ => ()
- val () = doArgs args
+ val sources = parse_flags (flag_info ()) args
val job =
- case !sources of
+ case sources of
[file] => file
+ | [] =>
+ raise Fail "No project specified, see -help"
| files =>
- if List.exists (fn s => s <> "-version") args then
- raise Fail ("Zero or multiple input files specified; only one is allowed.\nFiles: "
- ^ String.concatWith ", " files)
- else
- printVersion ()
+ raise Fail ("Multiple projects specified;"^
+ " only one is allowed.\nSpecified projects: "^
+ String.concatWith ", " files)
in
case (!css, !demo, !tutorial) of
(true, _, _) =>
@@ -229,7 +294,7 @@ fun oneRun args =
else
OS.Process.failure
| (_, _, true) => (Tutorial.make job;
- OS.Process.success)
+ OS.Process.success)
| _ =>
if !tc then
(Compiler.check Compiler.toElaborate job;
@@ -257,127 +322,138 @@ fun send (sock, s) =
send (sock, String.extract (s, n, NONE))
end
-val () = (Globals.setResetTime ();
- case CommandLine.arguments () of
- ["daemon", "start"] =>
- (case Posix.Process.fork () of
- SOME _ => ()
- | NONE =>
- let
- val () = Elaborate.incremental := true
- val listen = UnixSock.Strm.socket ()
-
- fun loop () =
- let
- val (sock, _) = Socket.accept listen
-
- fun loop' (buf, args) =
- let
- val s = if CharVector.exists (fn ch => ch = #"\n") buf then
- ""
- else
- MLton.CharVector.fromPoly (Vector.map (chr o Word8.toInt) (MLton.Word8Vector.toPoly (Socket.recvVec (sock, 1024))))
- val s = buf ^ s
- val (befor, after) = Substring.splitl (fn ch => ch <> #"\n") (Substring.full s)
- in
- if Substring.isEmpty after then
- loop' (s, args)
- else
- let
- val cmd = Substring.string befor
- val rest = Substring.string (Substring.slice (after, 1, NONE))
- in
- case cmd of
- "" =>
- (case args of
- ["stop", "daemon"] =>
- (((Socket.close listen;
- OS.FileSys.remove socket) handle OS.SysErr _ => ());
- OS.Process.exit OS.Process.success)
- | _ =>
- let
- val success = (oneRun (rev args))
- handle ex => (print "unhandled exception:\n";
- print (General.exnMessage ex ^ "\n");
- OS.Process.failure)
- in
- TextIO.flushOut TextIO.stdOut;
- TextIO.flushOut TextIO.stdErr;
- send (sock, if OS.Process.isSuccess success then
- "\001"
- else
- "\002")
- end)
- | _ => loop' (rest, cmd :: args)
- end
- end handle OS.SysErr _ => ()
-
- fun redirect old =
- Posix.IO.dup2 {old = valOf (Posix.FileSys.iodToFD (Socket.ioDesc sock)),
- new = old}
-
- val oldStdout = Posix.IO.dup Posix.FileSys.stdout
- val oldStderr = Posix.IO.dup Posix.FileSys.stderr
- in
- (* Redirect the daemon's output to the socket. *)
- redirect Posix.FileSys.stdout;
- redirect Posix.FileSys.stderr;
-
- loop' ("", []);
- Socket.close sock;
-
- Posix.IO.dup2 {old = oldStdout, new = Posix.FileSys.stdout};
- Posix.IO.dup2 {old = oldStderr, new = Posix.FileSys.stderr};
- Posix.IO.close oldStdout;
- Posix.IO.close oldStderr;
-
- Settings.reset ();
- MLton.GC.pack ();
- loop ()
- end
- in
- OS.Process.atExit (fn () => OS.FileSys.remove socket);
- Socket.bind (listen, UnixSock.toAddr socket);
- Socket.listen (listen, 1);
- loop ()
- end)
- | args =>
+fun startDaemon () =
+ if OS.FileSys.access (socket, []) then
+ (print ("It looks like a daemon is already listening in this directory,\n"
+ ^ "though it's possible a daemon died without cleaning up its socket.\n");
+ OS.Process.exit OS.Process.failure)
+ else case Posix.Process.fork () of
+ SOME _ => ()
+ | NONE =>
let
- val sock = UnixSock.Strm.socket ()
+ val () = Elaborate.incremental := true
+ val listen = UnixSock.Strm.socket ()
- fun wait () =
+ fun loop () =
let
- val v = Socket.recvVec (sock, 1024)
- in
- if Word8Vector.length v = 0 then
- OS.Process.failure
- else
+ val (sock, _) = Socket.accept listen
+
+ fun loop' (buf, args) =
let
- val s = MLton.CharVector.fromPoly (Vector.map (chr o Word8.toInt) (MLton.Word8Vector.toPoly v))
- val last = Word8Vector.sub (v, Word8Vector.length v - 1)
- val (rc, s) = if last = Word8.fromInt 1 then
- (SOME OS.Process.success, String.substring (s, 0, size s - 1))
- else if last = Word8.fromInt 2 then
- (SOME OS.Process.failure, String.substring (s, 0, size s - 1))
- else
- (NONE, s)
+ val s = if CharVector.exists (fn ch => ch = #"\n") buf then
+ ""
+ else
+ MLton.CharVector.fromPoly (Vector.map (chr o Word8.toInt) (MLton.Word8Vector.toPoly (Socket.recvVec (sock, 1024))))
+ val s = buf ^ s
+ val (befor, after) = Substring.splitl (fn ch => ch <> #"\n") (Substring.full s)
in
- print s;
- case rc of
- NONE => wait ()
- | SOME rc => rc
- end
- end handle OS.SysErr _ => OS.Process.failure
+ if Substring.isEmpty after then
+ loop' (s, args)
+ else
+ let
+ val cmd = Substring.string befor
+ val rest = Substring.string (Substring.slice (after, 1, NONE))
+ in
+ case cmd of
+ "" =>
+ (case args of
+ ["stop", "daemon"] =>
+ (((Socket.close listen;
+ OS.FileSys.remove socket) handle OS.SysErr _ => ());
+ OS.Process.exit OS.Process.success)
+ | _ =>
+ let
+ val success = (oneRun (rev args) handle DaemonExit => OS.Process.exit OS.Process.success)
+ handle ex => (print "unhandled exception:\n";
+ print (General.exnMessage ex ^ "\n");
+ OS.Process.failure)
+ in
+ TextIO.flushOut TextIO.stdOut;
+ TextIO.flushOut TextIO.stdErr;
+ send (sock, if OS.Process.isSuccess success then
+ "\001"
+ else
+ "\002")
+ end)
+ | _ => loop' (rest, cmd :: args)
+ end
+ end handle OS.SysErr _ => ()
+
+ fun redirect old =
+ Posix.IO.dup2 {old = valOf (Posix.FileSys.iodToFD (Socket.ioDesc sock)),
+ new = old}
+
+ val oldStdout = Posix.IO.dup Posix.FileSys.stdout
+ val oldStderr = Posix.IO.dup Posix.FileSys.stderr
+ in
+ (* Redirect the daemon's output to the socket. *)
+ redirect Posix.FileSys.stdout;
+ redirect Posix.FileSys.stderr;
+
+ loop' ("", []);
+ Socket.close sock;
+
+ Posix.IO.dup2 {old = oldStdout, new = Posix.FileSys.stdout};
+ Posix.IO.dup2 {old = oldStderr, new = Posix.FileSys.stderr};
+ Posix.IO.close oldStdout;
+ Posix.IO.close oldStderr;
+
+ Settings.reset ();
+ MLton.GC.pack ();
+ loop ()
+ end
in
- if Socket.connectNB (sock, UnixSock.toAddr socket)
- orelse not (List.null (#wrs (Socket.select {rds = [],
- wrs = [Socket.sockDesc sock],
- exs = [],
- timeout = SOME (Time.fromSeconds 1)}))) then
- (app (fn arg => send (sock, arg ^ "\n")) args;
- send (sock, "\n");
- OS.Process.exit (wait ()))
- else
- (OS.FileSys.remove socket;
- raise OS.SysErr ("", NONE))
- end handle OS.SysErr _ => OS.Process.exit (oneRun args))
+ OS.Process.atExit (fn () => OS.FileSys.remove socket);
+ Socket.bind (listen, UnixSock.toAddr socket);
+ Socket.listen (listen, 1);
+ loop ()
+ end
+
+fun oneCommandLine args =
+ let
+ val sock = UnixSock.Strm.socket ()
+
+ fun wait () =
+ let
+ val v = Socket.recvVec (sock, 1024)
+ in
+ if Word8Vector.length v = 0 then
+ OS.Process.failure
+ else
+ let
+ val s = MLton.CharVector.fromPoly (Vector.map (chr o Word8.toInt) (MLton.Word8Vector.toPoly v))
+ val last = Word8Vector.sub (v, Word8Vector.length v - 1)
+ val (rc, s) = if last = Word8.fromInt 1 then
+ (SOME OS.Process.success, String.substring (s, 0, size s - 1))
+ else if last = Word8.fromInt 2 then
+ (SOME OS.Process.failure, String.substring (s, 0, size s - 1))
+ else
+ (NONE, s)
+ in
+ print s;
+ case rc of
+ NONE => wait ()
+ | SOME rc => rc
+ end
+ end handle OS.SysErr _ => OS.Process.failure
+ in
+ if Socket.connectNB (sock, UnixSock.toAddr socket)
+ orelse not (List.null (#wrs (Socket.select {rds = [],
+ wrs = [Socket.sockDesc sock],
+ exs = [],
+ timeout = SOME (Time.fromSeconds 1)}))) then
+ (app (fn arg => send (sock, arg ^ "\n")) args;
+ send (sock, "\n");
+ wait ())
+ else
+ (OS.FileSys.remove socket;
+ raise OS.SysErr ("", NONE))
+ end handle OS.SysErr _ => oneRun args handle DaemonExit => OS.Process.success
+
+val () = (Globals.setResetTime ();
+ case CommandLine.arguments () of
+ ["daemon", "start"] => startDaemon ()
+ | ["daemon", "restart"] =>
+ (ignore (oneCommandLine ["daemon", "stop"]);
+ startDaemon ())
+ | args => OS.Process.exit (oneCommandLine args))
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-07 14:56:15 +0000