From f7ab07f941b23ad64cdb6db04020fa7c595db8e4 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 5 Jan 2017 17:08:37 -0500 Subject: Return to working version mode --- configure.ac | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/configure.ac b/configure.ac index c87b37ed..5d0cd40f 100644 --- a/configure.ac +++ b/configure.ac @@ -1,5 +1,5 @@ AC_INIT([urweb], [20170105]) -WORKING_VERSION=0 +WORKING_VERSION=1 AC_USE_SYSTEM_EXTENSIONS # automake 1.12 requires this, but automake 1.11 doesn't recognize it -- cgit v1.2.3 From 41cd154483d45c5d2fb0abf392b9bdc63d42b94e Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Wed, 25 Jan 2017 15:55:14 -0500 Subject: List.appi --- lib/ur/list.ur | 12 ++++++++++++ lib/ur/list.urs | 3 +++ 2 files changed, 15 insertions(+) diff --git a/lib/ur/list.ur b/lib/ur/list.ur index 50764e46..cc533676 100644 --- a/lib/ur/list.ur +++ b/lib/ur/list.ur @@ -311,6 +311,18 @@ fun app [m] (_ : monad m) [a] f = app' end +fun appi [m] (_ : monad m) [a] f = + let + fun app' i ls = + case ls of + [] => return () + | x :: ls => + f i x; + app' (i + 1) ls + in + app' 0 + end + fun mapQuery [tables ::: {{Type}}] [exps ::: {Type}] [t ::: Type] [tables ~ exps] (q : sql_query [] [] tables exps) (f : $(exps ++ map (fn fields :: {Type} => $fields) tables) -> t) = diff --git a/lib/ur/list.urs b/lib/ur/list.urs index 432d8c1a..fd56679d 100644 --- a/lib/ur/list.urs +++ b/lib/ur/list.urs @@ -65,6 +65,9 @@ val all : a ::: Type -> (a -> bool) -> t a -> bool val app : m ::: (Type -> Type) -> monad m -> a ::: Type -> (a -> m unit) -> t a -> m unit +val appi : m ::: (Type -> Type) -> monad m -> a ::: Type + -> (int -> a -> m unit) -> t a -> m unit + val tabulateM : m ::: (Type -> Type) -> monad m -> a ::: Type -> (int -> m a) -> int -> m (t a) -- cgit v1.2.3 From 59454c9766685b381603aaf116bb43a9515dbdba Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Wed, 1 Feb 2017 09:24:17 -0500 Subject: Option.app --- lib/ur/option.ur | 5 +++++ lib/ur/option.urs | 1 + 2 files changed, 6 insertions(+) diff --git a/lib/ur/option.ur b/lib/ur/option.ur index 05c50d1f..baa08466 100644 --- a/lib/ur/option.ur +++ b/lib/ur/option.ur @@ -40,6 +40,11 @@ fun mp [a] [b] f x = None => None | Some y => Some (f y) +fun app [m] [a] (_ : monad m) (f : a -> m {}) x = + case x of + None => return () + | Some y => f y + fun bind [a] [b] f x = case x of None => None diff --git a/lib/ur/option.urs b/lib/ur/option.urs index 126999a3..c30c40e7 100644 --- a/lib/ur/option.urs +++ b/lib/ur/option.urs @@ -9,6 +9,7 @@ val isNone : a ::: Type -> t a -> bool val isSome : a ::: Type -> t a -> bool val mp : a ::: Type -> b ::: Type -> (a -> b) -> t a -> t b +val app : m ::: (Type -> Type) -> a ::: Type -> monad m -> (a -> m {}) -> t a -> m {} val bind : a ::: Type -> b ::: Type -> (a -> option b) -> t a -> t b val get : a ::: Type -> a -> option a -> a -- cgit v1.2.3 From e36034c2fba0bf2a6f3fbd1a4e0cee2d796a6cc4 Mon Sep 17 00:00:00 2001 From: Artyom Shalkhakov Date: Thu, 2 Feb 2017 17:31:31 +0000 Subject: Adding: support for Emacs Bg Build mode --- Makefile.am | 7 +++++++ build.bgb | 3 +++ 2 files changed, 10 insertions(+) create mode 100644 build.bgb diff --git a/Makefile.am b/Makefile.am index 83a08171..33bf4e7c 100644 --- a/Makefile.am +++ b/Makefile.am @@ -19,6 +19,7 @@ SUBDIRS = src/c smlnj: src/urweb.cm xml/entities.sml mlton: bin/urweb +mlton-tc: bin/urwebtc clean-local: rm -f bin/urweb src/urweb.mlton.* \ @@ -60,6 +61,12 @@ bin/urweb: src/compiler.mlb xml/entities.sml \ src/urweb.mlton.grm.sig src/urweb.mlton.grm.sml mkdir -p bin $(MLTON) $(MLTONARGS) -mlb-path-var 'SRC $(abs_srcdir)/src' -mlb-path-var 'BUILD $(abs_builddir)/src' -output $@ $< +bin/urwebtc: src/compiler.mlb xml/entities.sml \ + src/urweb.mlb $(srcdir)/src/*.sig $(srcdir)/src/*.sml src/config.sml \ + src/urweb.mlton.lex.sml \ + src/urweb.mlton.grm.sig src/urweb.mlton.grm.sml + mkdir -p bin + $(MLTON) $(MLTONARGS) -prefer-abs-paths true -show-def-use compiler.du -stop tc -mlb-path-var 'SRC $(abs_srcdir)/src' -mlb-path-var 'BUILD $(abs_builddir)/src' -output $@ $< xml/entities.sml: xml/parse xml/xhtml-lat1.ent xml/xhtml-special.ent xml/xhtml-symbol.ent $^ > $@ diff --git a/build.bgb b/build.bgb new file mode 100644 index 00000000..3898ee03 --- /dev/null +++ b/build.bgb @@ -0,0 +1,3 @@ +(bg-build + :name "Compiler" + :shell "nice -n5 make bin/urwebtc") -- cgit v1.2.3 From 773c309baa825ae91a9d86358785f8c3056bad8f Mon Sep 17 00:00:00 2001 From: Artyom Shalkhakov Date: Tue, 21 Feb 2017 16:20:27 +0000 Subject: Button: disabled attribute; allowing number entry using HTML5 widgets --- lib/js/urweb.js | 21 +++++++++++++++++++-- lib/ur/basis.urs | 6 +++--- 2 files changed, 22 insertions(+), 5 deletions(-) diff --git a/lib/js/urweb.js b/lib/js/urweb.js index 222a8322..ebe192ca 100644 --- a/lib/js/urweb.js +++ b/lib/js/urweb.js @@ -1127,6 +1127,23 @@ function inpt(type, s, name) { return x; } +function inpt_float(type, s, name) { + if (suspendScripts) + return; + + var filterFloat = function(value) { + if (/^(\-|\+)?([0-9]+(\.[0-9]+)?|Infinity)$/ + .test(value)) + return Number(value); + return null; + } + var x = input(document.createElement("input"), s, function(x) { return function(v) { if (x.value != v) x.value = v; }; }, type, name); + x.value = s.data; + x.onkeyup = x.oninput = x.onchange = x.onpropertychange = function() { sv(s, filterFloat(x.value)) }; + + return x; +} + function inp(s, name) { return inpt("text", s, name); @@ -1157,11 +1174,11 @@ function color(s, name) { } function number(s, name) { - return inpt("number", s, name); + return inpt_float("number", s, name); } function range(s, name) { - return inpt("range", s, name); + return inpt_float("range", s, name); } function date(s, name) { diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index 23896e27..89a48d59 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -1076,8 +1076,8 @@ val curl : ctext val ctel : ctext val ccolor : ctext -val cnumber : cformTag ([Source = source float, Min = float, Max = float, Step = float, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) [] -val crange : cformTag ([Source = source float, Min = float, Max = float, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) [] +val cnumber : cformTag ([Source = source (option float), Min = float, Max = float, Step = float, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) [] +val crange : cformTag ([Source = source (option float), Min = float, Max = float, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) [] val cdate : cformTag ([Source = source string, Min = string, Max = string, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) [] val cdatetime : cformTag ([Source = source string, Min = string, Max = string, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) [] val cdatetime_local : cformTag ([Source = source string, Min = string, Max = string, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) [] @@ -1085,7 +1085,7 @@ val cmonth : cformTag ([Source = source string, Min = string, Max = string, Size val cweek : cformTag ([Source = source string, Min = string, Max = string, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) [] val ctime : cformTag ([Source = source string, Min = string, Max = string, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) [] -val button : cformTag ([Value = string] ++ boxAttrs) [] +val button : cformTag ([Value = string, Disabled = bool] ++ boxAttrs) [] val ccheckbox : cformTag ([Size = int, Source = source bool, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) [] -- cgit v1.2.3 From 5da5bcf37902fae4b5d443d05c8b096b460759b8 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Fri, 24 Feb 2017 08:39:28 -0500 Subject: Increase size of string buffer for error messages --- include/urweb/types_cpp.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/include/urweb/types_cpp.h b/include/urweb/types_cpp.h index 47086791..2fa473ac 100644 --- a/include/urweb/types_cpp.h +++ b/include/urweb/types_cpp.h @@ -113,7 +113,7 @@ typedef struct { uw_logger log_error, log_debug; } uw_loggers; -#define ERROR_BUF_LEN 1024 +#define ERROR_BUF_LEN 10240 typedef struct { size_t max; -- cgit v1.2.3 From bfc7faaf3b8cdff7ca6baec6b3358aef531eb9e2 Mon Sep 17 00:00:00 2001 From: Artyom Shalkhakov Date: Tue, 7 Mar 2017 13:47:55 +0000 Subject: Adding support for emitting JS to a given file. --- src/cjr_print.sml | 6 +++++- src/main.mlton.sml | 3 +++ src/settings.sig | 2 ++ src/settings.sml | 7 ++++++- 4 files changed, 16 insertions(+), 2 deletions(-) diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 688b3e4d..53587ff7 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -2513,8 +2513,12 @@ fun p_decl env (dAll as (d, loc) : decl) = | DJavaScript s => let + val name = + (case Settings.getOutputJsFile () of + NONE => "app." ^ SHA1.bintohex (SHA1.hash s) ^ ".js" + | SOME s => s) val () = app_js := OS.Path.joinDirFile {dir = Settings.getUrlPrefix (), - file = "app." ^ SHA1.bintohex (SHA1.hash s) ^ ".js"} + file = name} in box [string "static char jslib[] = \"", string (Prim.toCString s), diff --git a/src/main.mlton.sml b/src/main.mlton.sml index fb1a1723..2caa43f8 100644 --- a/src/main.mlton.sml +++ b/src/main.mlton.sml @@ -134,6 +134,9 @@ fun oneRun args = | "-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) diff --git a/src/settings.sig b/src/settings.sig index 05ab5e23..0ae81b13 100644 --- a/src/settings.sig +++ b/src/settings.sig @@ -303,4 +303,6 @@ signature SETTINGS = sig val addJsFile : string (* filename *) -> unit val listJsFiles : unit -> {Filename : string, Content : string} list + val setOutputJsFile : string option (* filename *) -> unit + val getOutputJsFile : unit -> string option end diff --git a/src/settings.sml b/src/settings.sml index 70ea1861..9fdc2232 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -951,6 +951,10 @@ fun addJsFile LoadFromFilename = fun listJsFiles () = SM.listItems (!jsFiles) +val jsOutput = ref (NONE : string option) +fun setOutputJsFile so = jsOutput := so +fun getOutputJsFile () = !jsOutput + fun reset () = (Globals.setResetTime (); urlPrefixFull := "/"; @@ -996,6 +1000,7 @@ fun reset () = mimeTypes := NONE; files := SM.empty; jsFiles := SM.empty; - filePath := ".") + filePath := "."; + jsOutput := NONE) end -- cgit v1.2.3 From 49a5e4d7ed58ae5d8dc437a03a5653d219fb654e Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 7 Mar 2017 12:16:58 -0500 Subject: Update manual for '-js' --- doc/manual.tex | 2 ++ 1 file changed, 2 insertions(+) diff --git a/doc/manual.tex b/doc/manual.tex index b65809d0..f6d67f07 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -275,6 +275,8 @@ sqlite3 path/to/database/file Date: Thu, 9 Mar 2017 14:21:35 +0000 Subject: Minor fix. --- src/sqlite.sml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/sqlite.sml b/src/sqlite.sml index c7694cde..a9b6389d 100644 --- a/src/sqlite.sml +++ b/src/sqlite.sml @@ -850,6 +850,6 @@ val () = addDbms {name = "sqlite", onlyUnion = false, nestedRelops = false, windowFunctions = false, - supportsIsDistinctFrom = true} + supportsIsDistinctFrom = false} end -- cgit v1.2.3 From 3aba065f1d069e033c6993ceac301adc25d865b3 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Fri, 17 Mar 2017 14:27:47 -0400 Subject: Extend license for tutorial code --- doc/LICENSE | 27 +++++++++++++++++++++++++++ doc/intro.ur | 2 +- doc/tlc.ur | 2 +- 3 files changed, 29 insertions(+), 2 deletions(-) create mode 100644 doc/LICENSE diff --git a/doc/LICENSE b/doc/LICENSE new file mode 100644 index 00000000..af0d8487 --- /dev/null +++ b/doc/LICENSE @@ -0,0 +1,27 @@ +The code in the tutorials files (intro.ur and tlc.ur), excluding comments, is additionally released under the following license (same as for Ur/Web itself): + +Copyright (c) 2008-2011, Adam Chlipala +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +- Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. +- Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. +- The names of contributors may not be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/doc/intro.ur b/doc/intro.ur index b08e2395..88b76b38 100644 --- a/doc/intro.ur +++ b/doc/intro.ur @@ -4,7 +4,7 @@ val show_string = mkShow (fn s => "\"" ^ s ^ "\"") (* end *) -(* This tutorial by Adam Chlipala is licensed under a Creative Commons Attribution-Noncommercial-No Derivative Works 3.0 Unported License. *) +(* This tutorial by Adam Chlipala is licensed under a Creative Commons Attribution-Noncommercial-No Derivative Works 3.0 Unported License. The code, but not the accompanying prose, is also released under the same license as Ur/Web itself. *) (* This is a tutorial for the Ur/Web programming language.

diff --git a/doc/tlc.ur b/doc/tlc.ur index 630dcaab..dac3ce3d 100644 --- a/doc/tlc.ur +++ b/doc/tlc.ur @@ -4,7 +4,7 @@ val show_string = mkShow (fn s => "\"" ^ s ^ "\"") (* end *) -(* This tutorial by Adam Chlipala is licensed under a Creative Commons Attribution-Noncommercial-No Derivative Works 3.0 Unported License. *) +(* This tutorial by Adam Chlipala is licensed under a Creative Commons Attribution-Noncommercial-No Derivative Works 3.0 Unported License. The code, but not the accompanying prose, is also released under the same license as Ur/Web itself. *) (* The last chapter reviewed some Ur features imported from ML and Haskell. This chapter explores uncharted territory, introducing the features that make Ur unique. *) -- cgit v1.2.3 From 0790751d4c2c97d85d6ccd7865271da23dee85e7 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Fri, 17 Mar 2017 15:15:58 -0400 Subject: Better error message for .urp files with too many blank lines --- src/compiler.sml | 26 ++++++++++++++++++++++---- tests/malformed.ur | 3 +++ tests/malformed.urp | 5 +++++ 3 files changed, 30 insertions(+), 4 deletions(-) create mode 100644 tests/malformed.ur create mode 100644 tests/malformed.urp diff --git a/src/compiler.sml b/src/compiler.sml index 481f04b6..3e08fcc6 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -543,9 +543,16 @@ fun parseUrp' accLibs fname = acc else let - val fname = String.implode (List.filter (fn x => not (Char.isSpace x)) - (String.explode line)) - val fname = relifyA fname + fun trim s = + let + val s = Substring.full s + val (_, s) = Substring.splitl Char.isSpace s + val (s, _) = Substring.splitr Char.isSpace s + in + Substring.string s + end + + val fname = relifyA (trim line) in fname :: acc end @@ -1005,6 +1012,8 @@ val parse = { val defed = ref SS.empty val fulls = ref SS.empty + val caughtOneThatIsn'tAFile = ref false + fun parseOne fname = let val mname = nameOf fname @@ -1129,7 +1138,16 @@ val parse = { in checkErrors (); d - end handle MissingFile fname => (ErrorMsg.error ("Missing source file: " ^ fname); + end handle MissingFile fname => (if not (!caughtOneThatIsn'tAFile) + andalso CharVector.exists Char.isSpace fname then + (caughtOneThatIsn'tAFile := true; + ErrorMsg.error ("In .urp files, all configuration directives must come before any blank lines.\n" + ^ "However, this .urp file contains at least one suspicious line in a position\n" + ^ "where filenames belong (after the first blank line) but containing a space\n" + ^ "character.")) + else + (); + ErrorMsg.error ("Missing source file: " ^ fname); (Source.DSequence "", ErrorMsg.dummySpan)) val dsFfi = map parseFfi ffi diff --git a/tests/malformed.ur b/tests/malformed.ur new file mode 100644 index 00000000..60e0b9f2 --- /dev/null +++ b/tests/malformed.ur @@ -0,0 +1,3 @@ +fun main () : transaction page = return + FYI, this file isn't the malformed one. That's malformed.urp. + diff --git a/tests/malformed.urp b/tests/malformed.urp new file mode 100644 index 00000000..d065a037 --- /dev/null +++ b/tests/malformed.urp @@ -0,0 +1,5 @@ +rewrite url Malformed/* + +rewrite style Malformed/* + +malformed -- cgit v1.2.3 From a478380e74c658637c90436c4e78c894f7076f4c Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Fri, 17 Mar 2017 15:52:13 -0400 Subject: Option '-m' for HTTP-server binaries --- src/c/http.c | 30 +++++++++++++++++++++++++++++- 1 file changed, 29 insertions(+), 1 deletion(-) diff --git a/src/c/http.c b/src/c/http.c index 1bc58677..b39520cc 100644 --- a/src/c/http.c +++ b/src/c/http.c @@ -75,6 +75,8 @@ static void log_debug(void *data, const char *fmt, ...) { static uw_loggers ls = {NULL, log_error, log_debug}; +static unsigned max_buf_size = 1024 * 1024; // That's 1MB. + static void *worker(void *data) { int me = *(int *)data; uw_context ctx = uw_request_new_context(me, &uw_application, &ls); @@ -100,6 +102,12 @@ static void *worker(void *data) { if (back - buf == buf_size - 1) { char *new_buf; size_t new_buf_size = buf_size*2; + if (new_buf_size > max_buf_size) { + qfprintf(stderr, "HTTP input exceeds buffer-size limit of %u bytes.\n", max_buf_size); + close(sock); + sock = 0; + break; + } new_buf = realloc(buf, new_buf_size); if(!new_buf) { qfprintf(stderr, "Realloc failed while receiving header\n"); @@ -156,6 +164,12 @@ static void *worker(void *data) { if (back - buf == buf_size - 1) { char *new_buf; size_t new_buf_size = buf_size * 2; + if (new_buf_size > max_buf_size) { + qfprintf(stderr, "HTTP input exceeds buffer-size limit of %u bytes.\n", max_buf_size); + close(sock); + sock = 0; + break; + } new_buf = realloc(buf, new_buf_size); if(!new_buf) { qfprintf(stderr, "Realloc failed while receiving content\n"); @@ -314,7 +328,7 @@ static void *worker(void *data) { } static void help(char *cmd) { - printf("Usage: %s [-p ] [-a ] [-A ] [-t ] [-k] [-q] [-T SEC]\nThe '-k' option turns on HTTP keepalive.\nThe '-q' option turns off some chatter on stdout.\nThe '-T' option sets socket recv timeout (0 disables timeout, default is 5 sec).\n", cmd); + printf("Usage: %s [-p ] [-a ] [-A ] [-t ] [-m ] [-k] [-q] [-T SEC]\nThe '-k' option turns on HTTP keepalive.\nThe '-q' option turns off some chatter on stdout.\nThe '-T' option sets socket recv timeout (0 disables timeout, default is 5 sec).\nThe '-m' sets the maximum size (in bytes) for any buffer used to hold HTTP data sent by clients. (The default is 1 MB.)\n", cmd); } static void sigint(int signum) { @@ -409,6 +423,16 @@ int main(int argc, char *argv[]) { quiet = 1; break; + case 'm': + opt = atoi(optarg); + if (opt <= 0) { + fprintf(stderr, "Invalid maximum buffer size\n"); + help(argv[0]); + return 1; + } + max_buf_size = opt; + break; + default: fprintf(stderr, "Unexpected getopt() behavior\n"); return 1; @@ -456,6 +480,10 @@ int main(int argc, char *argv[]) { sin_size = sizeof their_addr; + qprintf("Starting the Ur/Web native HTTP server, which is intended for use\n" + "ONLY DURING DEVELOPMENT. You probably want to use one of the other backends,\n" + "behind a production-quality HTTP server, for a real deployment.\n\n"); + qprintf("Listening on port %d....\n", uw_port); { -- cgit v1.2.3 From 680da1afd0b8d2f4b4a6b4ec0ef3bad48d0babde Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Fri, 31 Mar 2017 17:35:05 -0400 Subject: Fix normalization of signatures that project signatures from other modules with multi-element paths (fixes #72) --- src/elab_env.sig | 3 +- src/elab_env.sml | 93 ++++++++++++++++++++++++++++++++-------------------- src/elab_print.sml | 6 ++-- tests/sigInModule.ur | 8 +++++ 4 files changed, 69 insertions(+), 41 deletions(-) create mode 100644 tests/sigInModule.ur diff --git a/src/elab_env.sig b/src/elab_env.sig index cbc85cdd..47b31c08 100644 --- a/src/elab_env.sig +++ b/src/elab_env.sig @@ -96,6 +96,7 @@ signature ELAB_ENV = sig val pushStrNamed : env -> string -> Elab.sgn -> env * int val pushStrNamedAs : env -> string -> int -> Elab.sgn -> env + val pushStrNamedAs' : bool (* also enrich typeclass instances? *) -> env -> string -> int -> Elab.sgn -> env val lookupStrNamed : env -> int -> string * Elab.sgn val lookupStr : env -> string -> (int * Elab.sgn) option @@ -123,6 +124,4 @@ signature ELAB_ENV = sig val patBinds : env -> Elab.pat -> env val patBindsN : Elab.pat -> int - exception Bad of Elab.con * Elab.con - end diff --git a/src/elab_env.sml b/src/elab_env.sml index cb08f348..8402bcba 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -1097,14 +1097,21 @@ fun sgnS_sgn (str, (sgns, strs, cons)) sgn = end) | _ => sgn -fun sgnSubSgn x = +fun projectStr env {sgn, str, field} = + case #1 (hnormSgn env sgn) of + SgnConst sgis => + (case sgnSeek (fn SgiStr (_, x, _, sgn) => if x = field then SOME sgn else NONE | _ => NONE) sgis of + NONE => NONE + | SOME (sgn, subs) => SOME (sgnSubSgn (str, subs) sgn)) + | SgnError => SOME (SgnError, ErrorMsg.dummySpan) + | _ => NONE + +and sgnSubSgn x = ElabUtil.Sgn.map {kind = id, con = sgnS_con x, sgn_item = id, sgn = sgnS_sgn x} - - and projectSgn env {sgn, str, field} = case #1 (hnormSgn env sgn) of SgnConst sgis => @@ -1123,12 +1130,23 @@ and hnormSgn env (all as (sgn, loc)) = | SgnProj (m, ms, x) => let val (_, sgn) = lookupStrNamed env m + + fun doProjection (m1, NONE) = NONE + | doProjection (m1, SOME (str, sgn)) = + case projectStr env {str = str, + sgn = sgn, + field = m1} of + NONE => NONE + | SOME sgn' => SOME ((StrProj (str, m1), loc), sgn') in - case projectSgn env {str = foldl (fn (m, str) => (StrProj (str, m), loc)) (StrVar m, loc) ms, - sgn = sgn, - field = x} of - NONE => raise Fail "ElabEnv.hnormSgn: projectSgn failed" - | SOME sgn => hnormSgn env sgn + case foldl doProjection (SOME ((StrVar m, loc), sgn)) ms of + NONE => raise Fail "ElabEnv.hnormSgn: pre-projectSgn failed" + | SOME (str, sgn) => + case projectSgn env {str = str, + sgn = sgn, + field = x} of + NONE => raise Fail "ElabEnv.hnormSgn: projectSgn failed" + | SOME sgn => hnormSgn env sgn end | SgnWhere (sgn, ms, x, c) => let @@ -1281,28 +1299,40 @@ fun enrichClasses env classes (m1, ms) sgn = end | _ => classes -fun pushStrNamedAs (env : env) x n sgn = - {renameK = #renameK env, - relK = #relK env, +and pushStrNamedAs' enrich (env : env) x n sgn = + let + val renameStr = SM.insert (#renameStr env, x, (n, sgn)) + val str = IM.insert (#str env, n, (x, sgn)) + fun newEnv classes = + {renameK = #renameK env, + relK = #relK env, - renameC = #renameC env, - relC = #relC env, - namedC = #namedC env, + renameC = #renameC env, + relC = #relC env, + namedC = #namedC env, - datatypes = #datatypes env, - constructors = #constructors env, + datatypes = #datatypes env, + constructors = #constructors env, - classes = enrichClasses env (#classes env) (n, []) sgn, + classes = classes, - renameE = #renameE env, - relE = #relE env, - namedE = #namedE env, + renameE = #renameE env, + relE = #relE env, + namedE = #namedE env, - renameSgn = #renameSgn env, - sgn = #sgn env, + renameSgn = #renameSgn env, + sgn = #sgn env, + + renameStr = renameStr, + str = str} + in + if enrich then + newEnv (enrichClasses (newEnv (#classes env)) (#classes env) (n, []) sgn) + else + newEnv (#classes env) + end - renameStr = SM.insert (#renameStr env, x, (n, sgn)), - str = IM.insert (#str env, n, (x, sgn))} +and pushStrNamedAs env = pushStrNamedAs' true env fun pushStrNamed env x sgn = let @@ -1364,7 +1394,7 @@ fun sgiBinds env (sgi, loc) = env xncs end | SgiVal (x, n, t) => pushENamedAs env x n t - | SgiStr (_, x, n, sgn) => pushStrNamedAs env x n sgn + | SgiStr (_, x, n, sgn) => pushStrNamedAs' false env x n sgn | SgiSgn (x, n, sgn) => pushSgnNamedAs env x n sgn | SgiConstraint _ => env @@ -1375,15 +1405,6 @@ fun sgnSubCon x = ElabUtil.Con.map {kind = id, con = sgnS_con x} -fun projectStr env {sgn, str, field} = - case #1 (hnormSgn env sgn) of - SgnConst sgis => - (case sgnSeek (fn SgiStr (_, x, _, sgn) => if x = field then SOME sgn else NONE | _ => NONE) sgis of - NONE => NONE - | SOME (sgn, subs) => SOME (sgnSubSgn (str, subs) sgn)) - | SgnError => SOME (SgnError, ErrorMsg.dummySpan) - | _ => NONE - fun chaseMpath env (n, ms) = let val (_, sgn) = lookupStrNamed env n @@ -1642,8 +1663,8 @@ fun declBinds env (d, loc) = | DVal (x, n, t, _) => pushENamedAs env x n t | DValRec vis => foldl (fn ((x, n, t, _), env) => pushENamedAs env x n t) env vis | DSgn (x, n, sgn) => pushSgnNamedAs env x n sgn - | DStr (x, n, sgn, _) => pushStrNamedAs env x n sgn - | DFfiStr (x, n, sgn) => pushStrNamedAs env x n sgn + | DStr (x, n, sgn, _) => pushStrNamedAs' false env x n sgn + | DFfiStr (x, n, sgn) => pushStrNamedAs' false env x n sgn | DConstraint _ => env | DExport _ => env | DTable (tn, x, n, c, _, pc, _, cc) => diff --git a/src/elab_print.sml b/src/elab_print.sml index 06ea097f..8a6a651a 100644 --- a/src/elab_print.sml +++ b/src/elab_print.sml @@ -678,7 +678,7 @@ and p_sgn env (sgn, _) = space, string ":", space, - p_sgn (E.pushStrNamedAs env x n sgn) sgn'] + p_sgn (E.pushStrNamedAs' false env x n sgn) sgn'] | SgnWhere (sgn, ms, x, c) => box [p_sgn env sgn, space, string "where", @@ -695,7 +695,7 @@ and p_sgn env (sgn, _) = val m1x = #1 (E.lookupStrNamed env m1) handle E.UnboundNamed _ => "UNBOUND_SGN_" ^ Int.toString m1 - val m1s = if !debug then + val m1x = if !debug then m1x ^ "__" ^ Int.toString m1 else m1x @@ -867,7 +867,7 @@ and p_str env (str, _) = string s] | StrFun (x, n, sgn, sgn', str) => let - val env' = E.pushStrNamedAs env x n sgn + val env' = E.pushStrNamedAs' false env x n sgn in box [string "functor", space, diff --git a/tests/sigInModule.ur b/tests/sigInModule.ur new file mode 100644 index 00000000..efb7b0fc --- /dev/null +++ b/tests/sigInModule.ur @@ -0,0 +1,8 @@ +structure A = struct + signature S = sig + val x : int + end +end +structure B : A.S = struct + val x = 42 +end -- cgit v1.2.3 From ecf1d5aea6bdfe93b24af07f07a925eb477d685d Mon Sep 17 00:00:00 2001 From: Benjamin Barenblat Date: Tue, 2 May 2017 12:25:32 -0400 Subject: Use quiet mode for Ur/Web binaries in tests Reduce chatter on stdout during `make test` (notably, that introduced by a478380e74c658637c90436c4e78c894f7076f4c) by running test binaries with `-q`. --- Makefile.am | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Makefile.am b/Makefile.am index 33bf4e7c..f0392de0 100644 --- a/Makefile.am +++ b/Makefile.am @@ -123,7 +123,7 @@ test: bin/urweb -boot -noEmacs -dbms sqlite -db $(TESTDB) -demo /Demo demo rm -f $(TESTDB) sqlite3 $(TESTDB) < demo/demo.sql - demo/demo.exe -a 127.0.0.1 & echo $$! > $(TESTPID) + demo/demo.exe -q -a 127.0.0.1 & echo $$! > $(TESTPID) sleep 1 (curl -s 'http://localhost:8080/Demo/Hello/main' | diff tests/hello.html -) || (kill `cat $(TESTPID)`; echo "Test 'Hello' failed"; /bin/false) (curl -s 'http://localhost:8080/Demo/Crud1/create?A=1&B=2&C=3&D=4' | diff tests/crud1.html -) || (kill `cat $(TESTPID)`; echo "Test 'Crud1' failed"; /bin/false) @@ -133,7 +133,7 @@ test: echo "Running IPv6 tests."; \ rm -f $(TESTDB); \ sqlite3 $(TESTDB) < demo/demo.sql; \ - demo/demo.exe -A ::1 & echo $$! > $(TESTPID); \ + demo/demo.exe -q -A ::1 & echo $$! > $(TESTPID); \ sleep 1; \ (curl -g -6 -s 'http://[::1]:8080/Demo/Hello/main' | diff tests/hello.html -) || (kill `cat $(TESTPID)`; echo "Test 'Hello' failed"; /bin/false); \ (curl -g -6 -s 'http://[::1]:8080/Demo/Crud1/create?A=1&B=2&C=3&D=4' | diff tests/crud1.html -) || (kill `cat $(TESTPID)`; echo "Test 'Crud1' failed"; /bin/false); \ -- cgit v1.2.3 From 431a0a00148fb0fec21dacedc7665b52a7b0c557 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 14 May 2017 12:25:36 -0400 Subject: Raise an error if we run out of randomness during client initialization --- src/c/urweb.c | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/src/c/urweb.c b/src/c/urweb.c index afe8457b..6f2dde38 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -180,8 +180,11 @@ static uw_Basis_int my_rand() { return -1; } -static client *new_client() { +static client *new_client(uw_context ctx) { client *c; + int pass = my_rand(); + + if (pass < 0) uw_error(ctx, FATAL, "Random number generation failed during client initialization"); pthread_mutex_lock(&clients_mutex); @@ -205,7 +208,7 @@ static client *new_client() { pthread_mutex_lock(&c->lock); c->mode = USED; - c->pass = my_rand(); + c->pass = pass; c->sock = -1; c->last_contact = time(NULL); uw_buffer_reset(&c->msgs); @@ -817,7 +820,7 @@ void uw_login(uw_context ctx) { uw_error(ctx, FATAL, "Wrong client password (%u, %d) in subscription request", id, pass); } } else if (ctx->needs_push) { - client *c = new_client(); + client *c = new_client(ctx); if (c == NULL) uw_error(ctx, FATAL, "Limit exceeded on number of message-passing clients"); -- cgit v1.2.3 From 0ac03b426a139c4ac93fc5365e3aa8f748a90984 Mon Sep 17 00:00:00 2001 From: Vladimir Shabanov Date: Thu, 15 Jun 2017 17:13:22 +0300 Subject: Fixed non-working '-m' runtime option. --- src/c/http.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/c/http.c b/src/c/http.c index b39520cc..21ad809f 100644 --- a/src/c/http.c +++ b/src/c/http.c @@ -359,7 +359,7 @@ int main(int argc, char *argv[]) { my_addr.sa.sa_family = AF_INET; my_addr.ipv4.sin_addr.s_addr = INADDR_ANY; // auto-fill with my IP - while ((opt = getopt(argc, argv, "hp:a:A:t:kqT:")) != -1) { + while ((opt = getopt(argc, argv, "hp:a:A:t:kqT:m:")) != -1) { switch (opt) { case '?': fprintf(stderr, "Unknown command-line option\n"); -- cgit v1.2.3 From ab29028d5fa3aa14e043fa133e481fe2c165eca1 Mon Sep 17 00:00:00 2001 From: Vladimir Shabanov Date: Thu, 15 Jun 2017 18:02:48 +0300 Subject: Option to prefix all user JavaScript FFI functions with a module name (jsModule .urp option). --- src/compiler.sig | 1 + src/compiler.sml | 15 ++++++++++++++- src/demo.sml | 7 ++++--- src/settings.sig | 1 + src/settings.sml | 12 +++++++++--- 5 files changed, 29 insertions(+), 7 deletions(-) diff --git a/src/compiler.sig b/src/compiler.sig index a4b3e562..952c7070 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -48,6 +48,7 @@ signature COMPILER = sig benignEffectful : Settings.ffi list, clientOnly : Settings.ffi list, serverOnly : Settings.ffi list, + jsModule : string option, jsFuncs : (Settings.ffi * string) list, rewrites : Settings.rewrite list, filterUrl : Settings.rule list, diff --git a/src/compiler.sml b/src/compiler.sml index 3e08fcc6..c13de304 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -52,6 +52,7 @@ type job = { benignEffectful : Settings.ffi list, clientOnly : Settings.ffi list, serverOnly : Settings.ffi list, + jsModule : string option, jsFuncs : (Settings.ffi * string) list, rewrites : Settings.rewrite list, filterUrl : Settings.rule list, @@ -273,7 +274,7 @@ val parseUr = { fun p_job ({prefix, database, exe, sql, sources, debug, profile, timeout, ffi, link, headers, scripts, - clientToServer, effectful, benignEffectful, clientOnly, serverOnly, jsFuncs, ...} : job) = + clientToServer, effectful, benignEffectful, clientOnly, serverOnly, jsModule, jsFuncs, ...} : job) = let open Print.PD open Print @@ -312,6 +313,9 @@ fun p_job ({prefix, database, exe, sql, sources, debug, profile, p_ffi "BenignEffectful" benignEffectful, p_ffi "ClientOnly" clientOnly, p_ffi "ServerOnly" serverOnly, + case jsModule of + NONE => string "No JavaScript FFI module" + | SOME m => string ("JavaScript FFI module: " ^ m), p_list_sep (box []) (fn ((m, s), s') => box [string "JsFunc", space, string m, string ".", string s, space, string "=", space, string s', newline]) jsFuncs, @@ -368,6 +372,7 @@ fun institutionalizeJob (job : job) = Settings.setBenignEffectful (#benignEffectful job); Settings.setClientOnly (#clientOnly job); Settings.setServerOnly (#serverOnly job); + Settings.setJsModule (#jsModule job); Settings.setJsFuncs (#jsFuncs job); Settings.setRewriteRules (#rewrites job); Settings.setUrlRules (#filterUrl job); @@ -445,6 +450,7 @@ fun parseUrp' accLibs fname = benignEffectful = [], clientOnly = [], serverOnly = [], + jsModule = NONE, jsFuncs = [], rewrites = [{pkind = Settings.Any, kind = Settings.Prefix, @@ -579,6 +585,7 @@ fun parseUrp' accLibs fname = val benignEffectful = ref [] val clientOnly = ref [] val serverOnly = ref [] + val jsModule = ref NONE val jsFuncs = ref [] val rewrites = ref [] val url = ref [] @@ -616,6 +623,7 @@ fun parseUrp' accLibs fname = benignEffectful = rev (!benignEffectful), clientOnly = rev (!clientOnly), serverOnly = rev (!serverOnly), + jsModule = !jsModule, jsFuncs = rev (!jsFuncs), rewrites = rev (!rewrites), filterUrl = rev (!url), @@ -674,6 +682,7 @@ fun parseUrp' accLibs fname = benignEffectful = #benignEffectful old @ #benignEffectful new, clientOnly = #clientOnly old @ #clientOnly new, serverOnly = #serverOnly old @ #serverOnly new, + jsModule = #jsModule old, jsFuncs = #jsFuncs old @ #jsFuncs new, rewrites = #rewrites old @ #rewrites new, filterUrl = #filterUrl old @ #filterUrl new, @@ -809,6 +818,10 @@ fun parseUrp' accLibs fname = | "benignEffectful" => benignEffectful := ffiS () :: !benignEffectful | "clientOnly" => clientOnly := ffiS () :: !clientOnly | "serverOnly" => serverOnly := ffiS () :: !serverOnly + | "jsModule" => + (case !jsModule of + NONE => jsModule := SOME arg + | SOME _ => ()) | "jsFunc" => jsFuncs := ffiM () :: !jsFuncs | "rewrite" => let diff --git a/src/demo.sml b/src/demo.sml index 47d22395..62b9037a 100644 --- a/src/demo.sml +++ b/src/demo.sml @@ -16,7 +16,7 @@ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE - * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN @@ -111,6 +111,7 @@ fun make' {prefix, dirname, guided} = benignEffectful = [], clientOnly = [], serverOnly = [], + jsModule = NONE, jsFuncs = [], rewrites = #rewrites combined @ #rewrites urp, filterUrl = #filterUrl combined @ #filterUrl urp, @@ -280,7 +281,7 @@ fun make' {prefix, dirname, guided} = val (urpData, out) = startUrp urp in finished (); - + SOME (readUrp (urpData, out)) end @@ -399,7 +400,7 @@ fun make' {prefix, dirname, guided} = case #kind rule of Settings.Exact => () | Settings.Prefix => TextIO.output (outf, "*"); - TextIO.output (outf, "\n"))) + TextIO.output (outf, "\n"))) in Option.app (fn db => (TextIO.output (outf, "database "); TextIO.output (outf, db); diff --git a/src/settings.sig b/src/settings.sig index 0ae81b13..256a12b5 100644 --- a/src/settings.sig +++ b/src/settings.sig @@ -96,6 +96,7 @@ signature SETTINGS = sig val isServerOnly : ffi -> bool (* Which FFI functions may be run in JavaScript? (JavaScript function names included) *) + val setJsModule : string option -> unit val setJsFuncs : (ffi * string) list -> unit val addJsFunc : ffi * string -> unit val jsFunc : ffi -> string option diff --git a/src/settings.sml b/src/settings.sml index 9fdc2232..7ae4bf85 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -346,7 +346,7 @@ val jsFuncsBase = basisM [("alert", "alert"), ("asin", "asin"), ("acos", "acos"), ("atan", "atan"), - ("atan2", "atan2"), + ("atan2", "atan2"), ("abs", "abs"), ("now", "now"), @@ -395,9 +395,15 @@ val jsFuncsBase = basisM [("alert", "alert"), ("htmlifySpecialChar", "htmlifySpecialChar"), ("chr", "chr")] val jsFuncs = ref jsFuncsBase -fun setJsFuncs ls = jsFuncs := foldl (fn ((k, v), m) => M.insert (m, k, v)) jsFuncsBase ls +val jsModule = ref NONE +fun setJsModule m = jsModule := m +fun jsFuncName f = + case !jsModule of + SOME m => m ^ "." ^ f + | NONE => f +fun setJsFuncs ls = jsFuncs := foldl (fn ((k, v), m) => M.insert (m, k, jsFuncName v)) jsFuncsBase ls fun jsFunc x = M.find (!jsFuncs, x) -fun addJsFunc (k, v) = jsFuncs := M.insert (!jsFuncs, k, v) +fun addJsFunc (k, v) = jsFuncs := M.insert (!jsFuncs, k, jsFuncName v) fun allJsFuncs () = M.listItemsi (!jsFuncs) datatype pattern_kind = Exact | Prefix -- cgit v1.2.3 From da41c11a0f85f14558986710d4396ad71b21641f Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Wed, 12 Jul 2017 15:21:31 -0400 Subject: Document new 'jsModule' .urp directive --- doc/manual.tex | 1 + 1 file changed, 1 insertion(+) diff --git a/doc/manual.tex b/doc/manual.tex index f6d67f07..3d73b948 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -155,6 +155,7 @@ Here is the complete list of directive forms. ``FFI'' stands for ``foreign func \item \texttt{include FILENAME} adds \texttt{FILENAME} to the list of files to be \texttt{\#include}d in C sources. This is most useful for interfacing with new FFI modules. \item \texttt{jsFile FILENAME} asks to serve the contents of a file as JavaScript. All such content is concatenated into a single file, included via a \texttt{