From 259759d8725f050d6598d3ad4368e5edf124b089 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 16 Jun 2018 12:52:43 -0400 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 44c6873f..54eac40e 100644 --- a/configure.ac +++ b/configure.ac @@ -1,5 +1,5 @@ AC_INIT([urweb], [20180616]) -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 e3ca4ca819a3ac665f10409ed13bf2a14c3c5510 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 16 Jun 2018 13:21:24 -0400 Subject: Slight change to venerable Nested demo, to get proper URL resolution --- demo/nested.ur | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/demo/nested.ur b/demo/nested.ur index 31c9e1e8..13d0fc61 100644 --- a/demo/nested.ur +++ b/demo/nested.ur @@ -59,4 +59,4 @@ and fromA r = pageC None end -val main = pageA +fun main () = pageA () -- cgit v1.2.3 From c98f27c7821f6d8f3add303da692630bba268d1d Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 16 Jun 2018 13:22:43 -0400 Subject: Slight change to venerable Nested demo, to get proper URL resolution --- demo/nested.ur | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/demo/nested.ur b/demo/nested.ur index 13d0fc61..5c9cd3cc 100644 --- a/demo/nested.ur +++ b/demo/nested.ur @@ -45,7 +45,7 @@ and fromA r =

Hello {[forename]}{case surname of - None => + None => | Some s => {[s]}}

{case surname of None => Previous -- cgit v1.2.3 From c2dc15b0a95655110d3b5358ba1b375a70c4eabb Mon Sep 17 00:00:00 2001 From: Benjamin Barenblat Date: Sun, 17 Jun 2018 10:05:31 -0400 Subject: Start using symbol versioning We now have enough users to make ABI compatibility worthwhile. Designate the current ABI as version 1 and begin maintaining `-version-info` for libtool. --- src/c/Makefile.am | 15 ++++++++++----- 1 file changed, 10 insertions(+), 5 deletions(-) diff --git a/src/c/Makefile.am b/src/c/Makefile.am index 58f5153c..027b1458 100644 --- a/src/c/Makefile.am +++ b/src/c/Makefile.am @@ -9,13 +9,18 @@ liburweb_static_la_SOURCES = static.c AM_CPPFLAGS = -I$(srcdir)/../../include/urweb $(OPENSSL_INCLUDES) AM_CFLAGS = -Wall -Wunused-parameter -Werror -Wno-format-security -Wno-deprecated-declarations -U_FORTIFY_SOURCE $(PTHREAD_CFLAGS) liburweb_la_LDFLAGS = $(AM_LDFLAGS) $(OPENSSL_LDFLAGS) \ - -export-symbols-regex '^(client_pruner|pthread_create_big|strcmp_nullsafe|uw_.*)' + -export-symbols-regex '^(client_pruner|pthread_create_big|strcmp_nullsafe|uw_.*)' \ + -version-info 1:0:0 liburweb_la_LIBADD = $(PTHREAD_LIBS) -lm $(OPENSSL_LIBS) liburweb_http_la_LIBADD = liburweb.la -liburweb_http_la_LDFLAGS = -export-symbols-regex '^(main|uw_.*)' +liburweb_http_la_LDFLAGS = -export-symbols-regex '^(main|uw_.*)' \ + -version-info 1:0:0 liburweb_cgi_la_LIBADD = liburweb.la -liburweb_cgi_la_LDFLAGS = -export-symbols-regex '^(main|uw_.*)' +liburweb_cgi_la_LDFLAGS = -export-symbols-regex '^(main|uw_.*)' \ + -version-info 1:0:0 liburweb_fastcgi_la_LIBADD = liburweb.la -liburweb_fastcgi_la_LDFLAGS = -export-symbols-regex '^(main|uw_.*)' +liburweb_fastcgi_la_LDFLAGS = -export-symbols-regex '^(main|uw_.*)' \ + -version-info 1:0:0 liburweb_static_la_LIBADD = liburweb.la -liburweb_static_la_LDFLAGS = -export-symbols-regex '^(main|uw_.*)' +liburweb_static_la_LDFLAGS = -export-symbols-regex '^(main|uw_.*)' \ + -version-info 1:0:0 -- cgit v1.2.3 From b95811e4dab26d770c6d972a456ac0b31b39ca53 Mon Sep 17 00:00:00 2001 From: Fabrice Leal Date: Mon, 9 Jul 2018 22:34:11 +0100 Subject: offsetX, offsetY --- lib/js/urweb.js | 2 ++ lib/ur/basis.urs | 2 +- tests/mouseEvent.ur | 2 ++ 3 files changed, 5 insertions(+), 1 deletion(-) diff --git a/lib/js/urweb.js b/lib/js/urweb.js index 99b45ec9..ff4c7b7e 100644 --- a/lib/js/urweb.js +++ b/lib/js/urweb.js @@ -553,6 +553,8 @@ function uw_mouseEvent() { _ScreenY : firstGood(ev.screenY, 0), _ClientX : firstGood(ev.clientX, 0), _ClientY : firstGood(ev.clientY, 0), + _OffsetX : firstGood(ev.offsetX, 0), + _OffsetY : firstGood(ev.offsetY, 0), _CtrlKey : firstGood(ev.ctrlKey, false), _ShiftKey : firstGood(ev.shiftKey, false), _AltKey : firstGood(ev.altKey, false), diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index 66cc0e50..3b67946f 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -830,7 +830,7 @@ val meta : unit -> tag [Nam = meta, Content = string, Id = id] head [] [] [] datatype mouseButton = Left | Right | Middle -type mouseEvent = { ScreenX : int, ScreenY : int, ClientX : int, ClientY : int, +type mouseEvent = { ScreenX : int, ScreenY : int, ClientX : int, ClientY : int, OffsetX : int, OffsetY : int, CtrlKey : bool, ShiftKey : bool, AltKey : bool, MetaKey : bool, Button : mouseButton } diff --git a/tests/mouseEvent.ur b/tests/mouseEvent.ur index 2192e0b0..32a67806 100644 --- a/tests/mouseEvent.ur +++ b/tests/mouseEvent.ur @@ -8,6 +8,8 @@ fun main () : transaction page = return ^ "\nScreenY = " ^ show ev.ScreenY ^ "\nClientX = " ^ show ev.ClientX ^ "\nClientY = " ^ show ev.ClientY + ^ "\nOffsetX = " ^ show ev.OffsetX + ^ "\nOffsetY = " ^ show ev.OffsetY ^ "\nCtrlKey = " ^ show ev.CtrlKey ^ "\nShiftKey = " ^ show ev.ShiftKey ^ "\nAltKey = " ^ show ev.AltKey -- cgit v1.2.3 From 8bdd29f65c57570776f0c9f90d75f7818b0cdaa6 Mon Sep 17 00:00:00 2001 From: steinuil Date: Sat, 4 Aug 2018 18:04:32 +0200 Subject: removed invalid JSON escape character --- lib/ur/json.ur | 2 -- 1 file changed, 2 deletions(-) diff --git a/lib/ur/json.ur b/lib/ur/json.ur index 817ec16e..589e81b0 100644 --- a/lib/ur/json.ur +++ b/lib/ur/json.ur @@ -51,7 +51,6 @@ fun escape s = | #"\r" => "\\r" | #"\t" => "\\t" | #"\"" => "\\\"" - | #"\'" => "\\\'" | #"\\" => "\\\\" | #"/" => "\\/" | x => String.str ch @@ -101,7 +100,6 @@ fun unescape s = | #"r" => "\r" | #"t" => "\t" | #"\"" => "\"" - | #"\'" => "\'" | #"\\" => "\\" | #"/" => "/" | x => error JSON unescape: Bad escape char: {[x]}) -- cgit v1.2.3 From eb86dffeeec897d17905f3adff84e6acfd018330 Mon Sep 17 00:00:00 2001 From: Denis Redozubov Date: Wed, 22 Aug 2018 15:11:32 +0300 Subject: Rough same page anchors --- include/urweb/urweb_cpp.h | 1 + lib/js/urweb.js | 4 ++++ lib/ur/basis.urs | 1 + src/c/urweb.c | 4 ++++ src/settings.sml | 1 + 5 files changed, 11 insertions(+) diff --git a/include/urweb/urweb_cpp.h b/include/urweb/urweb_cpp.h index 5f1144b8..1351cfbc 100644 --- a/include/urweb/urweb_cpp.h +++ b/include/urweb/urweb_cpp.h @@ -242,6 +242,7 @@ uw_Basis_string uw_Basis_blessEnvVar(struct uw_context *, uw_Basis_string); uw_Basis_string uw_Basis_blessMeta(struct uw_context *, uw_Basis_string); uw_Basis_string uw_Basis_checkUrl(struct uw_context *, uw_Basis_string); +uw_Basis_string uw_Basis_anchorUrl(struct uw_context *, uw_Basis_string); uw_Basis_string uw_Basis_checkMime(struct uw_context *, uw_Basis_string); uw_Basis_string uw_Basis_checkRequestHeader(struct uw_context *, uw_Basis_string); uw_Basis_string uw_Basis_checkResponseHeader(struct uw_context *, uw_Basis_string); diff --git a/lib/js/urweb.js b/lib/js/urweb.js index ff4c7b7e..cd1b7005 100644 --- a/lib/js/urweb.js +++ b/lib/js/urweb.js @@ -2278,5 +2278,9 @@ function giveFocus(id) { er("Tried to give focus to ID not used in document: " + id); } +function anchorUrl(id) { + return "#" + id; +} + // App-specific code diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index 3b67946f..a416ba48 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -803,6 +803,7 @@ type id val fresh : transaction id val giveFocus : id -> transaction unit val show_id : show id +val anchorUrl : id -> url val dyn : ctx ::: {Unit} -> use ::: {Type} -> bind ::: {Type} -> [ctx ~ [Dyn]] => unit -> tag [Signal = signal (xml ([Dyn] ++ ctx) use bind)] ([Dyn] ++ ctx) [] use bind diff --git a/src/c/urweb.c b/src/c/urweb.c index e7efae38..ce6f4dfb 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -4407,6 +4407,10 @@ uw_Basis_string uw_Basis_currentUrl(uw_context ctx) { return ctx->current_url; } +uw_Basis_string uw_Basis_anchorUrl(uw_context ctx, uw_Basis_string s) { + return uw_Basis_strcat(ctx, uw_Basis_strcat(ctx, ctx->current_url, "#"), s); +} + void uw_set_currentUrl(uw_context ctx, char *s) { ctx->current_url = s; } diff --git a/src/settings.sml b/src/settings.sml index cfbe98a5..c023a851 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -321,6 +321,7 @@ val jsFuncsBase = basisM [("alert", "alert"), ("ord", "ord"), ("checkUrl", "checkUrl"), + ("anchorUrl", "anchorUrl"), ("bless", "bless"), ("blessData", "blessData"), -- cgit v1.2.3 From 7eec6f5c0d702323bd735e2184ff74f27ad37d17 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 25 Aug 2018 18:26:33 -0400 Subject: List.allM --- lib/ur/list.ur | 17 ++++++++++++++++- lib/ur/list.urs | 2 ++ 2 files changed, 18 insertions(+), 1 deletion(-) diff --git a/lib/ur/list.ur b/lib/ur/list.ur index 95d6fbc8..d28d2868 100644 --- a/lib/ur/list.ur +++ b/lib/ur/list.ur @@ -319,7 +319,7 @@ fun filterM [m] (_ : monad m) [a] (p : a -> m bool) = filterM' [] end -fun all [m] f = +fun all [a] f = let fun all' ls = case ls of @@ -329,6 +329,21 @@ fun all [m] f = all' end +fun allM [m] (_ : monad m) [a] f = + let + fun all' ls = + case ls of + [] => return True + | x :: ls => + b <- f x; + if b then + all' ls + else + return False + in + all' + end + fun app [m] (_ : monad m) [a] f = let fun app' ls = diff --git a/lib/ur/list.urs b/lib/ur/list.urs index fe730152..f4593dda 100644 --- a/lib/ur/list.urs +++ b/lib/ur/list.urs @@ -66,6 +66,8 @@ val search : a ::: Type -> b ::: Type -> (a -> option b) -> t a -> option b val all : a ::: Type -> (a -> bool) -> t a -> bool +val allM : m ::: (Type -> Type) -> monad m -> a ::: Type -> (a -> m bool) -> t a -> m bool + val app : m ::: (Type -> Type) -> monad m -> a ::: Type -> (a -> m unit) -> t a -> m unit -- cgit v1.2.3 From 1f11b7ba4e2fdf116aaf0f4d8ca7cde55daa410c Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Wed, 29 Aug 2018 21:44:02 -0400 Subject: Detect lambda abstractions over type classes as deserving of implicit-argument status --- src/elab_env.sml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/elab_env.sml b/src/elab_env.sml index 0474bf7c..a2097aa9 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -493,10 +493,11 @@ fun class_name_in (c, _) = case c of CNamed n => SOME (ClNamed n) | CModProj x => SOME (ClProj x) + | CAbs (_, _, c') => class_head_in c' | CUnif (_, _, _, _, ref (Known c)) => class_name_in c | _ => NONE -fun isClass (env : env) c = +and isClass (env : env) c = let fun find NONE = false | find (SOME c) = Option.isSome (CM.find (#classes env, c)) @@ -504,7 +505,7 @@ fun isClass (env : env) c = find (class_name_in c) end -fun class_head_in c = +and class_head_in c = case #1 c of CApp (f, _) => class_head_in f | CUnif (_, _, _, _, ref (Known c)) => class_head_in c -- cgit v1.2.3 From 588ac75ad01487e93899f8d61163551d0fb1dc78 Mon Sep 17 00:00:00 2001 From: Artyom Shalkhakov Date: Fri, 31 Aug 2018 19:36:03 +0600 Subject: FlyCheck integration. Some issues: - since Ur/Web expects to typecheck a project, we "guess" it (which may not be the exact project that you use, maybe we need to improve our heuristics) - lightly tested, but seems to work on my machine --- src/elisp/urweb-flycheck.el | 83 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 83 insertions(+) create mode 100644 src/elisp/urweb-flycheck.el diff --git a/src/elisp/urweb-flycheck.el b/src/elisp/urweb-flycheck.el new file mode 100644 index 00000000..1f10226b --- /dev/null +++ b/src/elisp/urweb-flycheck.el @@ -0,0 +1,83 @@ +;;; urweb-flycheck.el --- Flycheck: Ur/Web support -*- lexical-binding: t; -*- + +;; Copyright (C) 2018 Artyom Shalkhakov + +;; Author: +;; Artyom Shalkhakov +;; David Christiansen +;; +;; Keywords: tools, languages, convenience +;; Version: 0.1 +;; Package-Requires: ((emacs "24.1") (flycheck "0.22")) + +;; This file is not part of GNU Emacs, but it is distributed under the +;; same conditions. + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or (at +;; your option) any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +;;; Commentary: + +;; This Flycheck extension provides an 'urweb' syntax checker. +;; +;; # Setup +;; +;; Put the following into your 'init' file: +;; +;; (with-eval-after-load 'flycheck (urweb-flycheck-setup)) +;; +;; Ensure that the Ur/Web compiler is in your PATH +;; + +;;; Code: + +(require 'flycheck) + +(flycheck-define-checker urweb + "Ur/Web checker" + :command ("urweb" "-tc" + (eval (file-name-sans-extension + (car (flycheck-substitute-argument 'source-inplace + 'urweb))))) + ;; filename:1:0: (to 1:0) syntax error found at SYMBOL + ;; /home/artyom/projects/urweb-test/test.ur:1:0: (to 1:38) Some constructor unification variables are undetermined in declaration + ;; (look for them as "") + ;; Decl: + ;; val rec + ;; help : + ;; {} -> Type> (xml ([])) = + ;; fn $x : {} => + ;; case $x of + ;; {} => + ;; return [ Type>] + ;; [xml ([])] _ + ;; (Basis.cdata [] [] "Hello!") + + :error-patterns + ((error line-start (file-name) ":" line ":" column ":" + " (to " (1+ num) ?: (1+ num) ")" + ;; AS: indebted to David Christiansen for this rx expression! + (message (and (* nonl) (* "\n" (not (any "/" "~")) (* nonl)))))) + :modes (urweb-mode)) + +;;;###autoload +(defun urweb-flycheck-setup () + "Setup Flycheck Ur/Web. + +Add `urweb' to `flycheck-checkers'." + (interactive) + (add-to-list 'flycheck-checkers 'urweb)) + +(provide 'urweb-flycheck) +;;; urweb-flycheck.el ends here -- cgit v1.2.3 From 8c2ce9489b3164534532bddd87ba952ee9b66048 Mon Sep 17 00:00:00 2001 From: Artyom Shalkhakov Date: Fri, 31 Aug 2018 19:53:33 +0600 Subject: Flycheck: improving multi-file support --- src/elisp/urweb-flycheck.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/elisp/urweb-flycheck.el b/src/elisp/urweb-flycheck.el index 1f10226b..96b7cc9b 100644 --- a/src/elisp/urweb-flycheck.el +++ b/src/elisp/urweb-flycheck.el @@ -48,7 +48,7 @@ "Ur/Web checker" :command ("urweb" "-tc" (eval (file-name-sans-extension - (car (flycheck-substitute-argument 'source-inplace + (car (flycheck-substitute-argument 'source-original 'urweb))))) ;; filename:1:0: (to 1:0) syntax error found at SYMBOL ;; /home/artyom/projects/urweb-test/test.ur:1:0: (to 1:38) Some constructor unification variables are undetermined in declaration -- cgit v1.2.3 From d1dcdbad6fa310c83aac551e952d752e7d2921ce Mon Sep 17 00:00:00 2001 From: Artyom Shalkhakov Date: Sat, 1 Sep 2018 14:34:03 +0600 Subject: Multi-file projects should work. --- src/elisp/urweb-flycheck.el | 27 ++++++++++++++++++++++----- 1 file changed, 22 insertions(+), 5 deletions(-) diff --git a/src/elisp/urweb-flycheck.el b/src/elisp/urweb-flycheck.el index 96b7cc9b..31433fbc 100644 --- a/src/elisp/urweb-flycheck.el +++ b/src/elisp/urweb-flycheck.el @@ -7,7 +7,7 @@ ;; David Christiansen ;; ;; Keywords: tools, languages, convenience -;; Version: 0.1 +;; Version: 0.2 ;; Package-Requires: ((emacs "24.1") (flycheck "0.22")) ;; This file is not part of GNU Emacs, but it is distributed under the @@ -44,14 +44,28 @@ (require 'flycheck) +(defun urweb-get-flycheck-project-file () + "Guess the location of the nearest urp file." + (let ((bn (buffer-file-name))) + (if bn + (let + ((x (file-name-sans-extension bn)) + (y (file-name-directory bn))) + (cond + ;; file with .urp extension exists? take it + ((file-exists-p (concat x ".urp")) x) + ;; lib.urp exists in this directory? take it + ((file-exists-p (concat y "/lib.urp")) (concat y "/lib")) + ;; fall back to the first .urp file in this directory + ;; or if that fails, use the current file name + (t (or (car (directory-files y nil "\\.urp$")) x))))))) + (flycheck-define-checker urweb "Ur/Web checker" :command ("urweb" "-tc" - (eval (file-name-sans-extension - (car (flycheck-substitute-argument 'source-original - 'urweb))))) + (eval (urweb-get-flycheck-project-file))) ;; filename:1:0: (to 1:0) syntax error found at SYMBOL - ;; /home/artyom/projects/urweb-test/test.ur:1:0: (to 1:38) Some constructor unification variables are undetermined in declaration + ;; filename:1:0: (to 1:38) Some constructor unification variables are undetermined in declaration ;; (look for them as "") ;; Decl: ;; val rec @@ -69,6 +83,9 @@ " (to " (1+ num) ?: (1+ num) ")" ;; AS: indebted to David Christiansen for this rx expression! (message (and (* nonl) (* "\n" (not (any "/" "~")) (* nonl)))))) + :predicate + (lambda () + (buffer-file-name)) :modes (urweb-mode)) ;;;###autoload -- cgit v1.2.3 From 5eaaa94db962bbc3e42578bce3463ff2f942d602 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Fri, 12 Oct 2018 10:57:26 -0400 Subject: Catch when a cselect has an unavailable value set --- lib/js/urweb.js | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/lib/js/urweb.js b/lib/js/urweb.js index ff4c7b7e..199f5001 100644 --- a/lib/js/urweb.js +++ b/lib/js/urweb.js @@ -1230,11 +1230,14 @@ function selectValue(x) { function setSelectValue(x, v) { for (var i = 0; i < x.options.length; ++i) { - if(x.options[i].value == v) { + if (x.options[i].value == v) { x.selectedIndex = i; return; } } + + if (v != "") + er("Setting " + content + ""; - var x = input(dummy.firstChild, s, function(x) { return function(v) { if (selectValue(x) != v) setSelectValue(x, v); }; }); + var x = dummy.firstChild; for (var i = 0; i < x.options.length; ++i) { if (x.options[i].value == "") x.options[i].value = x.options[i].text; @@ -1252,6 +1255,8 @@ function sel(s, content) { x.options[i].value = x.options[i].value.substring(1); } + x = input(x, s, function(x) { return function(v) { if (selectValue(x) != v) setSelectValue(x, v); }; }); + setSelectValue(x, s.data); if (selectValue(x) != s.data) sv(s, selectValue(x)); -- cgit v1.2.3 From e798117b42c5df30d1b3778d6414467e8e7b1e04 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Fri, 19 Oct 2018 15:38:55 -0400 Subject: unsafeSerialized[To|From]String --- lib/ur/basis.urs | 2 ++ src/monoize.sml | 14 ++++++++++++++ 2 files changed, 16 insertions(+) diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index 3b67946f..878f2793 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -274,6 +274,8 @@ con serialized :: Type -> Type val serialize : t ::: Type -> t -> serialized t val deserialize : t ::: Type -> serialized t -> t val sql_serialized : t ::: Type -> sql_injectable_prim (serialized t) +val unsafeSerializedToString : t ::: Type -> serialized t -> string +val unsafeSerializedFromString : t ::: Type -> string -> serialized t con primary_key :: {Type} -> {{Unit}} -> Type val no_primary_key : fs ::: {Type} -> primary_key fs [] diff --git a/src/monoize.sml b/src/monoize.sml index 11c6ea31..dfa88be3 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -3953,6 +3953,20 @@ fun monoExp (env, st, fm) (all as (e, loc)) = loc)), loc), fm) end + | L.ECApp ((L.EFfi ("Basis", "unsafeSerializedToString"), _), _) => + let + val t = (L'.TFfi ("Basis", "string"), loc) + in + ((L'.EAbs ("v", t, t, (L'.ERel 0, loc)), loc), + fm) + end + | L.ECApp ((L.EFfi ("Basis", "unsafeSerializedFromString"), _), _) => + let + val t = (L'.TFfi ("Basis", "string"), loc) + in + ((L'.EAbs ("v", t, t, (L'.ERel 0, loc)), loc), + fm) + end | L.EFfiApp ("Basis", "url", [(e, _)]) => let -- cgit v1.2.3 From d800556bd50ecb78c21343a288f9475b8b870162 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Fri, 19 Oct 2018 15:55:17 -0400 Subject: Just return None rather than crashing, when trying to read cookies within tasks (closes #143) --- src/c/urweb.c | 5 ++++- tests/task_cookie.ur | 9 +++++++++ 2 files changed, 13 insertions(+), 1 deletion(-) create mode 100644 tests/task_cookie.ur diff --git a/src/c/urweb.c b/src/c/urweb.c index e7efae38..2e3e18bc 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -737,7 +737,10 @@ void uw_close(uw_context ctx) { } uw_Basis_string uw_Basis_requestHeader(uw_context ctx, uw_Basis_string h) { - return ctx->get_header(ctx->get_header_data, h); + if (ctx->get_header) + return ctx->get_header(ctx->get_header_data, h); + else + return NULL; } void uw_set_headers(uw_context ctx, char *(*get_header)(void *, const char *), void *get_header_data) { diff --git a/tests/task_cookie.ur b/tests/task_cookie.ur new file mode 100644 index 00000000..39f49b0a --- /dev/null +++ b/tests/task_cookie.ur @@ -0,0 +1,9 @@ +cookie myCookie: {Value: string} + +fun main (): transaction page = return + +task initialize = fn () => + c <- getCookie myCookie; + case c of + None => debug "No cookie" + | Some {Value = v} => debug ("Cookie value: " ^ v) -- cgit v1.2.3 From 1a4a8b5ab8eb499ee2217c966f7fbb7716adf9e9 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Fri, 19 Oct 2018 16:03:57 -0400 Subject: Client-side escaping of HTML should be prepared for structured HTML trees, not just strings (closes #141) --- lib/js/urweb.js | 2 +- tests/a_case_of_the_splits.ur | 17 +++++++++++++++++ tests/a_case_of_the_splits.urp | 4 ++++ 3 files changed, 22 insertions(+), 1 deletion(-) create mode 100644 tests/a_case_of_the_splits.ur create mode 100644 tests/a_case_of_the_splits.urp diff --git a/lib/js/urweb.js b/lib/js/urweb.js index 199f5001..bf20cfd4 100644 --- a/lib/js/urweb.js +++ b/lib/js/urweb.js @@ -1439,7 +1439,7 @@ function eh(x) { if (x == null) return "NULL"; else - return x.split("&").join("&").split("<").join("<").split(">").join(">"); + return flattenLocal(x).split("&").join("&").split("<").join("<").split(">").join(">"); } function ts(x) { return x.toString() } diff --git a/tests/a_case_of_the_splits.ur b/tests/a_case_of_the_splits.ur new file mode 100644 index 00000000..2029729e --- /dev/null +++ b/tests/a_case_of_the_splits.ur @@ -0,0 +1,17 @@ +fun newCounter () : transaction xbody = + x <- source 0; + return + {[n]}}/> + + +fun main () : transaction page = + ls <- source ([] : list xbody); + return + + + diff --git a/tests/caseMod.py b/tests/caseMod.py new file mode 100644 index 00000000..16e49a5b --- /dev/null +++ b/tests/caseMod.py @@ -0,0 +1,25 @@ +import unittest +import base + +class Suite(base.Base): + def test_1(self): + """Test case 1""" + self.start('main') + l1 = self.xpath('li[1]/a') + l1.click() + + self.assertEqual("C A\n\nAgain!", self.body_text()) + def test_2(self): + """Test case 2""" + self.start('main') + l1 = self.xpath('li[2]/a') + l1.click() + + self.assertEqual("C B\n\nAgain!", self.body_text()) + def test_3(self): + """Test case 3""" + self.start('main') + l1 = self.xpath('li[3]/a') + l1.click() + + self.assertEqual("D\n\nAgain!", self.body_text()) diff --git a/tests/caseMod.ur b/tests/caseMod.ur index 0a870160..15a7e07a 100644 --- a/tests/caseMod.ur +++ b/tests/caseMod.ur @@ -24,15 +24,15 @@ val toString = fn x => | C B => "C B" | D => "D" -val rec page = fn x => +val rec page = fn x => return {cdata (toString x)}

Again! - + -val main : unit -> page = fn () => +val main : unit -> transaction page = fn () => return
  • C A
  • C B
  • D
    • - +     diff --git a/tests/ccheckbox.py b/tests/ccheckbox.py new file mode 100644 index 00000000..f2390368 --- /dev/null +++ b/tests/ccheckbox.py @@ -0,0 +1,15 @@ +import unittest +import base + +class Suite(base.Base): + def test_1(self): + """Test case 1""" + self.start('main') + d = self.xpath('input') + p = self.xpath('span') + self.assertEqual("True 1", p.text) + d.click() + # the elements gets re-created from scratch + # so we must refresh our reference + p = self.xpath('span') + self.assertEqual("False 3", p.text) diff --git a/tests/ccheckbox.ur b/tests/ccheckbox.ur index 09a8ece9..d70c24a5 100644 --- a/tests/ccheckbox.ur +++ b/tests/ccheckbox.ur @@ -1,7 +1,7 @@ fun main () : transaction page = s <- source True; t <- source 1; - return + return set t 3}/> {[s]} {[t]}}/> diff --git a/tests/cdataF.py b/tests/cdataF.py new file mode 100644 index 00000000..8f43176f --- /dev/null +++ b/tests/cdataF.py @@ -0,0 +1,8 @@ +import unittest +import base + +class Suite(base.Base): + def test_1(self): + """Test case 1""" + self.start('main') + self.assertEqual(" +val snippet = fn s =>

    {cdata s}

    - +     -val main = fn () => +val main : unit -> transaction page = fn () => return {snippet " + diff --git a/tests/cdataL.py b/tests/cdataL.py new file mode 100644 index 00000000..67ccd75e --- /dev/null +++ b/tests/cdataL.py @@ -0,0 +1,18 @@ +import unittest +import base + +class Suite(base.Base): + def test_1(self): + """Test case 1""" + self.start('main') + l1 = self.xpath('li[1]/a') + l1.click() + + self.assertEqual(" +val subpage : string -> transaction page = fn s => return

    {cdata s}

    - +     -val main = fn () => +val main : unit -> transaction page = fn () => return
  • Door #1
  • Door #2
    • - +     diff --git a/tests/cffi.py b/tests/cffi.py new file mode 100644 index 00000000..34b31b8c --- /dev/null +++ b/tests/cffi.py @@ -0,0 +1,37 @@ +import unittest +import base + +class Suite(base.Base): + def test_1(self): + """Test case 1""" + self.start('Cffi/main') + l1 = self.xpath('form[1]/input') + l1.click() + + b1 = self.xpath('button[1]') + b1.click() # TODO: check server output somehow + + b2 = self.xpath('button[2]') + b2.click() + alert = self.driver.switch_to.alert + self.assertEqual("<>", alert.text) + alert.accept() + + b3 = self.xpath('button[3]') + b3.click() + alert = self.driver.switch_to.alert + self.assertEqual("Hi there!", alert.text) + def test_2(self): + """Test case 2""" + self.start('Cffi/main') + l1 = self.xpath('form[2]/input') + l1.click() + + self.assertEqual("All good.", self.body_text()) + def test_3(self): + """Test case 3""" + self.start('Cffi/main') + l1 = self.xpath('form[3]/input') + l1.click() + + self.assertRegex(self.body_text(), "^Fatal error: .*$") diff --git a/tests/cffi.sh b/tests/cffi.sh new file mode 100755 index 00000000..1267c3e3 --- /dev/null +++ b/tests/cffi.sh @@ -0,0 +1,6 @@ +#!/bin/bash + +CCOMP=gcc + +$CCOMP -pthread -Wimplicit -Werror -Wno-unused-value -I ..include/urweb -c "test.c" -o "test.o" -g +./driver.sh cffi diff --git a/tests/cffi.ur b/tests/cffi.ur index bcb9944c..89dc9906 100644 --- a/tests/cffi.ur +++ b/tests/cffi.ur @@ -3,9 +3,9 @@ fun printer () = Test.foo fun effect () = Test.print; return -