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/ur/basis.urs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'lib/ur/basis.urs') 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 } -- 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(+) (limited to 'lib/ur/basis.urs') 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 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(+) (limited to 'lib/ur/basis.urs') 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 5cc729b48aad084757a049b7e5cdbadae5e9e400 Mon Sep 17 00:00:00 2001 From: fab Date: Fri, 30 Nov 2018 23:29:14 +0000 Subject: reject invalid codepoints. Basis.iscodepoint. fix german char in js --- include/urweb/urweb_cpp.h | 5 +- lib/js/urweb.js | 7 +- lib/ur/basis.urs | 2 + src/c/urweb.c | 265 +++++++++++++++++++++++++++------------------- 4 files changed, 168 insertions(+), 111 deletions(-) (limited to 'lib/ur/basis.urs') diff --git a/include/urweb/urweb_cpp.h b/include/urweb/urweb_cpp.h index 5f1144b8..25f97fb3 100644 --- a/include/urweb/urweb_cpp.h +++ b/include/urweb/urweb_cpp.h @@ -103,7 +103,7 @@ char *uw_Basis_htmlifyFloat(struct uw_context *, uw_Basis_float); char *uw_Basis_htmlifyString(struct uw_context *, uw_Basis_string); char *uw_Basis_htmlifyBool(struct uw_context *, uw_Basis_bool); char *uw_Basis_htmlifyTime(struct uw_context *, uw_Basis_time); -char *uw_Basis_htmlifySpecialChar(struct uw_context *, unsigned char); +char *uw_Basis_htmlifySpecialChar(struct uw_context *, uw_Basis_char); char *uw_Basis_htmlifySource(struct uw_context *, uw_Basis_source); uw_unit uw_Basis_htmlifyInt_w(struct uw_context *, uw_Basis_int); @@ -111,7 +111,7 @@ uw_unit uw_Basis_htmlifyFloat_w(struct uw_context *, uw_Basis_float); uw_unit uw_Basis_htmlifyString_w(struct uw_context *, uw_Basis_string); uw_unit uw_Basis_htmlifyBool_w(struct uw_context *, uw_Basis_bool); uw_unit uw_Basis_htmlifyTime_w(struct uw_context *, uw_Basis_time); -uw_unit uw_Basis_htmlifySpecialChar_w(struct uw_context *, unsigned char); +uw_unit uw_Basis_htmlifySpecialChar_w(struct uw_context *, uw_Basis_char); uw_unit uw_Basis_htmlifySource_w(struct uw_context *, uw_Basis_source); char *uw_Basis_attrifyInt(struct uw_context *, uw_Basis_int); @@ -327,6 +327,7 @@ uw_Basis_bool uw_Basis_isxdigit(struct uw_context *, uw_Basis_char); uw_Basis_char uw_Basis_tolower(struct uw_context *, uw_Basis_char); uw_Basis_char uw_Basis_toupper(struct uw_context *, uw_Basis_char); +uw_Basis_bool uw_Basis_iscodepoint(struct uw_context *, uw_Basis_int); uw_Basis_int uw_Basis_ord(struct uw_context *, uw_Basis_char); uw_Basis_char uw_Basis_chr(struct uw_context *, uw_Basis_int); diff --git a/lib/js/urweb.js b/lib/js/urweb.js index de1a2ad0..c7725e28 100644 --- a/lib/js/urweb.js +++ b/lib/js/urweb.js @@ -38,7 +38,12 @@ function isXdigit(c) { return isDigit(c) || (c >= 'a' && c <= 'f') || (c >= 'A' function ord(c) { return c.charCodeAt(0); } function isPrint(c) { return ord(c) > 31 && ord(c) != 127; } function toLower(c) { return c.toLowerCase(); } -function toUpper(c) { return c.toUpperCase(); } +function toUpper(c) { + if (ord(c) == 223) + return c; + else + return c.toUpperCase(); +} // Lists diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index 878f2793..c9d6556b 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -79,6 +79,8 @@ val toupper : char -> char val ord : char -> int val chr : int -> char +val iscodepoint : int -> bool + (** String operations *) val strlen : string -> int diff --git a/src/c/urweb.c b/src/c/urweb.c index be65afcc..195ddada 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -1559,101 +1559,89 @@ const char *uw_Basis_get_settings(uw_context ctx, uw_unit u) { } } -uw_Basis_string uw_Basis_jsifyString(uw_context ctx, uw_Basis_string s) { - char *r, *s2; - - uw_check_heap(ctx, strlen(s) * 4 + 3); - - r = s2 = ctx->heap.front; - *s2++ = '"'; - - for (; *s; s++) { - unsigned char c = *s; - - switch (c) { - case '"': - strcpy(s2, "\\\""); - s2 += 2; - break; - case '\'': - strcpy(s2, "\\047"); - s2 += 4; - break; - case '\\': - strcpy(s2, "\\\\"); - s2 += 2; - break; - case '<': - strcpy(s2, "\\074"); - s2 += 4; - break; - case '&': - strcpy(s2, "\\046"); - s2 += 4; - break; - default: - if (isprint((int)c) || c >= 128) - *s2++ = c; - else { - sprintf(s2, "\\%03o", c); - s2 += 4; - } - } - } - - strcpy(s2, "\""); - ctx->heap.front = s2 + 2; - return r; -} - uw_Basis_bool uw_Basis_isprint(uw_context ctx, uw_Basis_char ch); - -uw_Basis_string uw_Basis_jsifyChar(uw_context ctx, uw_Basis_char c1) { - char *r, *s2; - - uw_check_heap(ctx, 7); - - r = s2 = ctx->heap.front; - *s2++ = '"'; - +void jsifyChar(char**buffer_ptr, uw_context ctx, uw_Basis_char c1) { + char* buffer = *buffer_ptr; + switch (c1) { case '"': - strcpy(s2, "\\\""); - s2 += 2; + strcpy(buffer, "\\\""); + buffer += 2; break; case '\'': - strcpy(s2, "\\047"); - s2 += 4; + strcpy(buffer, "\\047"); + buffer += 4; break; case '\\': - strcpy(s2, "\\\\"); - s2 += 2; + strcpy(buffer, "\\\\"); + buffer += 2; break; case '<': - strcpy(s2, "\\074"); - s2 += 4; + strcpy(buffer, "\\074"); + buffer += 4; break; case '&': - strcpy(s2, "\\046"); - s2 += 4; + strcpy(buffer, "\\046"); + buffer += 4; break; default: if (uw_Basis_isprint(ctx, c1) == uw_Basis_True) { int offset = 0; - U8_APPEND_UNSAFE(s2, offset, c1); - s2 += offset; + U8_APPEND_UNSAFE(buffer, offset, c1); + buffer += offset; } else { - assert(0777 >= c1); - sprintf(s2, "\\%03o", (unsigned char)c1); - s2 += 4; + assert(65536 > c1); + sprintf(buffer, "\\u%04x", (unsigned char)c1); + buffer += 6; } } + + *buffer_ptr = buffer; +} + +uw_Basis_string uw_Basis_jsifyString(uw_context ctx, uw_Basis_string s) { + char *r, *s2; + uw_Basis_char c; + + uw_check_heap(ctx, strlen(s) * 6 + 3); + + r = s2 = ctx->heap.front; + *s2++ = '"'; + + int offset = 0; + while(s[offset] != 0) + { + U8_NEXT(s, offset, -1, c); + + jsifyChar(&s2, ctx, c); + } + strcpy(s2, "\""); ctx->heap.front = s2 + 2; + + return r; +} + +uw_Basis_int uw_Basis_ord(uw_context ctx, uw_Basis_char c); + +uw_Basis_string uw_Basis_jsifyChar(uw_context ctx, uw_Basis_char c1) { + char *r, *s2; + + uw_check_heap(ctx, 8); + + r = s2 = ctx->heap.front; + + *s2++ = '"'; + + jsifyChar(&s2, ctx, c1); + + strcpy(s2, "\""); + ctx->heap.front = s2 + 2; + return r; } @@ -1697,6 +1685,7 @@ uw_Basis_string uw_Basis_jsifyString_ws(uw_context ctx, uw_Basis_string s) { strcpy(s2, "\""); ctx->script.front = s2 + 1; + return r; } @@ -2262,25 +2251,27 @@ uw_unit uw_Basis_htmlifyInt_w(uw_context ctx, uw_Basis_int n) { return uw_unit_v; } -char *uw_Basis_htmlifySpecialChar(uw_context ctx, unsigned char ch) { +char *uw_Basis_htmlifySpecialChar(uw_context ctx, uw_Basis_char ch) { unsigned int n = ch; int len; char *r; - uw_check_heap(ctx, INTS_MAX+3); + uw_check_heap(ctx, INTS_MAX+3 + 1); r = ctx->heap.front; - sprintf(r, "&#%u;%n", n, &len); + len = sprintf(r, "&#%u;", n); ctx->heap.front += len+1; + return r; } -uw_unit uw_Basis_htmlifySpecialChar_w(uw_context ctx, unsigned char ch) { +uw_unit uw_Basis_htmlifySpecialChar_w(uw_context ctx, uw_Basis_char ch) { unsigned int n = ch; int len; uw_check(ctx, INTS_MAX+3); - sprintf(ctx->page.front, "&#%u;%n", n, &len); + len = sprintf(ctx->page.front, "&#%u;", n); ctx->page.front += len; + return uw_unit_v; } @@ -2328,48 +2319,69 @@ uw_unit uw_Basis_jsifyInt_w(uw_context ctx, uw_Basis_int n) { char *uw_Basis_htmlifyString(uw_context ctx, const char *s) { char *r, *s2; + uw_Basis_char c1; + int offset = 0, len = 0; + + uw_check_heap(ctx, strlen(s) * (INTS_MAX + 3) + 1); - uw_check_heap(ctx, strlen(s) * 5 + 1); - - for (r = s2 = ctx->heap.front; *s; s++) { - unsigned char c = *s; - - switch (c) { - case '<': - strcpy(s2, "<"); - s2 += 4; - break; - case '&': - strcpy(s2, "&"); - s2 += 5; - break; - default: - *s2++ = c; + r = s2 = ctx->heap.front; + + while (s[offset] != 0) { + + U8_NEXT(s, offset, -1, c1); + + + if (U8_IS_SINGLE(c1) && uw_Basis_isprint(ctx, c1)) { + switch (c1) { + case '<': + strcpy(s2, "<"); + s2 += 4; + break; + case '&': + strcpy(s2, "&"); + s2 += 5; + break; + default: + *s2++ = c1; + } + } else { + len = sprintf(s2, "&#%u;", c1); + s2 += len; } } - + *s2++ = 0; ctx->heap.front = s2; + return r; } uw_unit uw_Basis_htmlifyString_w(uw_context ctx, uw_Basis_string s) { uw_check(ctx, strlen(s) * 6); - - for (; *s; s++) { - unsigned char c = *s; - - switch (c) { - case '<': - uw_write_unsafe(ctx, "<"); - break; - case '&': - uw_write_unsafe(ctx, "&"); - break; - default: - uw_writec_unsafe(ctx, c); + int offset = 0; + uw_Basis_char c1; + + while(s[offset] != 0){ + + U8_NEXT(s, offset, -1, c1); + + if (U8_IS_SINGLE(c1) && uw_Basis_isprint(ctx, c1)) { + + switch (c1) { + case '<': + uw_write_unsafe(ctx, "<"); + break; + case '&': + uw_write_unsafe(ctx, "&"); + break; + default: + uw_writec_unsafe(ctx, c1); + } } - } + else { + uw_Basis_htmlifySpecialChar_w(ctx, c1); + } + } return uw_unit_v; } @@ -4474,9 +4486,46 @@ uw_Basis_int uw_Basis_ord(uw_context ctx, uw_Basis_char c) { return (uw_Basis_int)c; } +uw_Basis_bool uw_Basis_iscodepoint (uw_context ctx, uw_Basis_int n) { + (void)ctx; + uw_Basis_char ch = (uw_Basis_char)n; + + if (UCHAR_MIN_VALUE <= ch && UCHAR_MAX_VALUE > ch) { + + if (U8_LENGTH(ch) == 0) { + return uw_Basis_False; + } + + if (u_charType(ch) == U_UNASSIGNED) { + return uw_Basis_False; + } + + } else { + return uw_Basis_False; + } + + return uw_Basis_True; +} + uw_Basis_char uw_Basis_chr(uw_context ctx, uw_Basis_int n) { (void)ctx; - return (uw_Basis_char)n; + uw_Basis_char ch = (uw_Basis_char)n; + + if (UCHAR_MIN_VALUE <= ch && UCHAR_MAX_VALUE > ch) { + + if (U8_LENGTH(ch) == 0) { + uw_error(ctx, FATAL, "The integer %lld cannot be converted to a char", n); + } + + if (u_charType(ch) == U_UNASSIGNED) { + uw_error(ctx, FATAL, "The integer %lld is not a valid char codepoint", n); + } + + } else { + uw_error(ctx, FATAL, "Integer %lld out of range of unicode chars", n); + } + + return ch; } uw_Basis_string uw_Basis_currentUrl(uw_context ctx) { -- cgit v1.2.3 From e452bb052b6c1afbaaa72efb653ea31561333866 Mon Sep 17 00:00:00 2001 From: fab Date: Tue, 11 Dec 2018 22:16:37 +0000 Subject: exhaustive testing brought to selenium. bug fix in isspace. useful function to test if char is <128 --- lib/js/urweb.js | 5 +- lib/ur/basis.urs | 1 + src/c/urweb.c | 5 ++ tests/utf8.py | 79 +++++++++++++++++--- tests/utf8.ur | 217 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 292 insertions(+), 15 deletions(-) (limited to 'lib/ur/basis.urs') diff --git a/lib/js/urweb.js b/lib/js/urweb.js index 00637172..2d39bc69 100644 --- a/lib/js/urweb.js +++ b/lib/js/urweb.js @@ -2122,9 +2122,7 @@ function isBlank(c) { } function isSpace(c) { var cp = ord(c); - if (cp == 10) - return true; - if (cp == 13) + if (cp >= 10 && cp <= 13) return true; if (cp == 133) return true; @@ -2790,6 +2788,7 @@ function isPrint(c) { function toLower(c) { var cp = ord(c); + if (cp == 304) return chr(105); else if (cp >= 7312 && cp <= 7354) diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index c9d6556b..c893e65d 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -80,6 +80,7 @@ val ord : char -> int val chr : int -> char val iscodepoint : int -> bool +val issingle : char -> bool (** String operations *) diff --git a/src/c/urweb.c b/src/c/urweb.c index 96e30cec..78946872 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -4496,6 +4496,11 @@ uw_Basis_bool uw_Basis_iscodepoint (uw_context ctx, uw_Basis_int n) { return !!(n <= 0x10FFFF); } +uw_Basis_bool uw_Basis_issingle (uw_context ctx, uw_Basis_char c) { + (void)ctx; + return !!(c < 128); +} + uw_Basis_char uw_Basis_chr(uw_context ctx, uw_Basis_int n) { (void)ctx; uw_Basis_char ch = (uw_Basis_char)n; diff --git a/tests/utf8.py b/tests/utf8.py index 440bc82a..ac8df5c3 100644 --- a/tests/utf8.py +++ b/tests/utf8.py @@ -2,51 +2,51 @@ import unittest import base class Suite(base.Base): - def test_1(self): + def test_99(self): """Test case: substring (1)""" self.start('Utf8/substrings') - def test_2(self): + def test_98(self): """Test case: strlen (2)""" self.start('Utf8/strlens') - def test_3(self): + def test_97(self): """Test case: strlenGe (3)""" self.start('Utf8/strlenGens') - def test_4(self): + def test_96(self): """Test case: strcat (4)""" self.start('Utf8/strcats') - def test_5(self): + def test_95(self): """Test case: strsub (5)""" self.start('Utf8/strsubs') - def test_6(self): + def test_94(self): """Test case: strsuffix (6)""" self.start('Utf8/strsuffixs') - def test_7(self): + def test_93(self): """Test case: strchr (7)""" self.start('Utf8/strchrs') - def test_8(self): + def test_92(self): """Test case: strindex (8)""" self.start('Utf8/strindexs') - def test_9(self): + def test_91(self): """Test case: strindex (9)""" self.start('Utf8/strsindexs') - def test_10(self): + def test_90(self): """Test case: strcspn (10)""" self.start('Utf8/strcspns') - def test_11(self): + def test_89(self): """Test case: str1 (11)""" self.start('Utf8/str1s') - def test_12(self): + def test_88(self): """Test case: isalnum (12)""" self.start('Utf8/isalnums') @@ -105,3 +105,58 @@ class Suite(base.Base): def test_26 (self): """Test case: test_db (26) """ self.start('Utf8/test_db') + + def full_test (self, name): + + gap = 1000 + i = 0 + while (i + gap < 130000): + self.start('Utf8/' + name + '/' + str(i) + '/' + str(i + gap)) + errors = self.body_text() + self.assertEqual("", errors, errors) + i = i + gap + + + def test_1 (self): + """Test case: ftTolower """ + self.full_test("ftTolower") + + def test_2 (self): + """Test case: ftToupper """ + self.full_test("ftToupper") + + def test_3 (self): + """Test case: ftIsalpha """ + self.full_test("ftIsalpha") + + def test_4 (self): + """Test case: ftIsdigit """ + self.full_test("ftIsdigit") + + def test_5 (self): + """Test case: ftIsalnum """ + self.full_test("ftIsalnum") + + def test_6 (self): + """Test case: ftIsspace """ + self.full_test("ftIsspace") + + def test_7 (self): + """Test case: ftIsblank """ + self.full_test("ftIsblank") + + def test_8 (self): + """Test case: ftIsprint """ + self.full_test("ftIsprint") + + def test_9 (self): + """Test case: ftIsxdigit """ + self.full_test("ftIsxdigit") + + def test_10 (self): + """Test case: ftIsupper """ + self.full_test("ftIsupper") + + def test_11 (self): + """Test case: ftIslower """ + self.full_test("ftIslower") diff --git a/tests/utf8.ur b/tests/utf8.ur index c7aefd79..777bb141 100644 --- a/tests/utf8.ur +++ b/tests/utf8.ur @@ -1,4 +1,13 @@ +fun from_m_upto_n f m n = + if m < n then + + { f m } + { from_m_upto_n f (m + 1) n } + + else + + fun test_fn_both_sides [a ::: Type] (_ : eq a) (_ : show a) (f : unit -> a) (expected : a) (testname : string) : xbody =

Server side test: {[testname]}

@@ -31,6 +40,38 @@ fun test_fn_cside [a ::: Type] (_ : eq a) (_ : show a) (f : unit -> a) (expected + +fun test_fn_cside_ch (f : unit -> char) (expected : char) (testname : string) : xbody = + + + else + return

ERROR {[testname]}: {[msgErr]}

 + end}> + + + +fun test_fn_cside_b (f : unit -> bool) (expected : bool) (testname : string) : xbody = + + + else + return

ERROR {[testname]}: {[msgErr]}

 + end}> + + + + fun highencode () : transaction page = return @@ -553,6 +594,182 @@ fun test_db () : transaction page = end +and ftTolower (minCh : int) (maxCh : int) : transaction page = + let + fun test_chr (n : int) : xbody = + if iscodepoint n then + test_fn_cside_ch (fn _ => tolower (chr n)) (tolower (chr n)) + ("test chr " ^ (show n) ^ " : " ^ (show (chr n))) + else + + in + return + + { from_m_upto_n (fn n => test_chr n) minCh maxCh } + + + end + +and ftToupper (minCh : int) (maxCh : int) : transaction page = + let + fun test_chr (n : int) : xbody = + if iscodepoint n then + test_fn_cside_ch (fn _ => toupper (chr n)) (toupper (chr n)) + ("test chr " ^ (show n) ^ " : " ^ (show (chr n))) + else + + in + return + + { from_m_upto_n (fn n => test_chr n) minCh maxCh } + + + end + +and ftIsalpha (minCh : int) (maxCh : int) : transaction page = + let + fun test_chr (n : int) : xbody = + if iscodepoint n then + test_fn_cside_b (fn _ => isalpha (chr n)) (isalpha (chr n)) + ("test chr " ^ (show n) ^ " : " ^ (show (chr n))) + else + + in + return + + { from_m_upto_n (fn n => test_chr n) minCh maxCh } + + + end + +and ftIsdigit (minCh : int) (maxCh : int) : transaction page = + let + fun test_chr (n : int) : xbody = + if iscodepoint n then + test_fn_cside_b (fn _ => isdigit (chr n)) (isdigit (chr n)) + ("test chr " ^ (show n) ^ " : " ^ (show (chr n))) + else + + in + return + + { from_m_upto_n (fn n => test_chr n) minCh maxCh } + + + end + +and ftIsalnum (minCh : int) (maxCh : int) : transaction page = + let + fun test_chr (n : int) : xbody = + if iscodepoint n then + test_fn_cside_b (fn _ => isalnum (chr n)) (isalnum (chr n)) + ("test chr " ^ (show n) ^ " : " ^ (show (chr n))) + else + + in + return + + { from_m_upto_n (fn n => test_chr n) minCh maxCh } + + + end + +and ftIsspace (minCh : int) (maxCh : int) : transaction page = + let + fun test_chr (n : int) : xbody = + if iscodepoint n then + test_fn_cside_b (fn _ => isspace (chr n)) (isspace (chr n)) + ("test chr " ^ (show n) ^ " : " ^ (show (chr n))) + else + + in + return + + { from_m_upto_n (fn n => test_chr n) minCh maxCh } + + + end + +and ftIsblank (minCh : int) (maxCh : int) : transaction page = + let + fun test_chr (n : int) : xbody = + if iscodepoint n then + test_fn_cside_b (fn _ => isblank (chr n)) (isblank (chr n)) + ("test chr " ^ (show n) ^ " : " ^ (show (chr n))) + else + + in + return + + { from_m_upto_n (fn n => test_chr n) minCh maxCh } + + + end + +and ftIsprint (minCh : int) (maxCh : int) : transaction page = + let + fun test_chr (n : int) : xbody = + if iscodepoint n then + test_fn_cside_b (fn _ => isprint (chr n)) (isprint (chr n)) + ("test chr " ^ (show n) ^ " : " ^ (show (chr n))) + else + + in + return + + { from_m_upto_n (fn n => test_chr n) minCh maxCh } + + + end + +and ftIsxdigit (minCh : int) (maxCh : int) : transaction page = + let + fun test_chr (n : int) : xbody = + if iscodepoint n then + test_fn_cside_b (fn _ => isxdigit (chr n)) (isxdigit (chr n)) + ("test chr " ^ (show n) ^ " : " ^ (show (chr n))) + else + + in + return + + { from_m_upto_n (fn n => test_chr n) minCh maxCh } + + + end + +and ftIsupper (minCh : int) (maxCh : int) : transaction page = + let + fun test_chr (n : int) : xbody = + if iscodepoint n then + test_fn_cside_b (fn _ => isupper (chr n)) (isupper (chr n)) + ("test chr " ^ (show n) ^ " : " ^ (show (chr n))) + else + + in + return + + { from_m_upto_n (fn n => test_chr n) minCh maxCh } + + + end + +and ftIslower (minCh : int) (maxCh : int) : transaction page = + let + fun test_chr (n : int) : xbody = + if iscodepoint n then + test_fn_cside_b (fn _ => islower (chr n)) (islower (chr n)) + ("test chr " ^ (show n) ^ " : " ^ (show (chr n))) + else + + in + return + + { from_m_upto_n (fn n => test_chr n) minCh maxCh } + + + end + fun index () : transaction page = return -- cgit v1.2.3 From 87d2eab53f8e9f81cc459429675123c9ff36f41e Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Mon, 21 Jan 2019 18:09:59 -0500 Subject: Basis.textOfBlob; try creating filecache directory if it doesn't exist --- include/urweb/urweb_cpp.h | 1 + lib/ur/basis.urs | 2 ++ src/c/urweb.c | 16 +++++++++++++++- src/cjr_print.sml | 24 +++++++++++++++++++++++- 4 files changed, 41 insertions(+), 2 deletions(-) (limited to 'lib/ur/basis.urs') diff --git a/include/urweb/urweb_cpp.h b/include/urweb/urweb_cpp.h index 25f97fb3..67312015 100644 --- a/include/urweb/urweb_cpp.h +++ b/include/urweb/urweb_cpp.h @@ -262,6 +262,7 @@ uw_Basis_string uw_Basis_fileMimeType(struct uw_context *, uw_Basis_file); uw_Basis_blob uw_Basis_fileData(struct uw_context *, uw_Basis_file); uw_Basis_int uw_Basis_blobSize(struct uw_context *, uw_Basis_blob); uw_Basis_blob uw_Basis_textBlob(struct uw_context *, uw_Basis_string); +uw_Basis_string uw_Basis_textOfBlob(struct uw_context *, uw_Basis_blob); uw_Basis_string uw_Basis_postType(struct uw_context *, uw_Basis_postBody); uw_Basis_string uw_Basis_postData(struct uw_context *, uw_Basis_postBody); diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index c893e65d..be13c684 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -1019,6 +1019,8 @@ val checkMime : string -> option mimeType val returnBlob : t ::: Type -> blob -> mimeType -> transaction t val blobSize : blob -> int val textBlob : string -> blob +val textOfBlob : blob -> option string +(* Returns [Some] exactly when the blob contains no zero bytes. *) type postBody val postType : postBody -> string diff --git a/src/c/urweb.c b/src/c/urweb.c index ae2fc0a8..c8cfb0c6 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -4075,6 +4075,20 @@ uw_Basis_blob uw_Basis_textBlob(uw_context ctx, uw_Basis_string s) { return b; } +uw_Basis_string uw_Basis_textOfBlob(uw_context ctx, uw_Basis_blob b) { + size_t i; + uw_Basis_string r; + + for (i = 0; i < b.size; ++i) + if (b.data[i] == 0) + return NULL; + + r = uw_malloc(ctx, b.size + 1); + memcpy(r, b.data, b.size); + r[b.size] = 0; + return r; +} + uw_Basis_blob uw_Basis_fileData(uw_context ctx, uw_Basis_file f) { (void)ctx; return f.data; @@ -5207,7 +5221,7 @@ uw_unit uw_Basis_cache_file(uw_context ctx, uw_Basis_blob contents) { fd = mkstemp(tempfile); if (fd < 0) - uw_error(ctx, FATAL, "Error creating temporary file for cache"); + uw_error(ctx, FATAL, "Error creating temporary file %s for cache", tempfile); while (written_so_far < contents.size) { ssize_t written_just_now = write(fd, contents.data + written_so_far, contents.size - written_so_far); diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 31653a74..09cd9c7f 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -3391,6 +3391,14 @@ fun p_file env (ds, ps) = newline, string "#include ", newline, + (case Settings.getFileCache () of + NONE => box [] + | SOME _ => box [string "#include ", + newline, + string "#include ", + newline, + string "#include ", + newline]), if hasDb then box [string ("#include <" ^ #header (Settings.currentDbms ()) ^ ">"), newline] @@ -3655,7 +3663,21 @@ fun p_file env (ds, ps) = newline, string "static void uw_initializer(uw_context ctx) {", newline, - box [string "uw_begin_initializing(ctx);", + box [(case Settings.getFileCache () of + NONE => box [] + | SOME dir => box [newline, + string "struct stat st = {0};", + newline, + newline, + string "if (stat(\"", + string (Prim.toCString dir), + string "\", &st) == -1)", + newline, + box [string "mkdir(\"", + string (Prim.toCString dir), + string "\", 0700);", + newline]]), + string "uw_begin_initializing(ctx);", newline, p_list_sep newline (fn x => x) (rev (!global_initializers)), string "uw_end_initializing(ctx);", -- cgit v1.2.3 From 89526be4ed3328fef9ac9c8668c3611094e45d18 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Fri, 26 Jul 2019 10:09:07 -0400 Subject: Remove a misleading comment (#175) --- lib/ur/basis.urs | 3 --- 1 file changed, 3 deletions(-) (limited to 'lib/ur/basis.urs') diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index be13c684..2a98bf6f 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -571,9 +571,6 @@ val sql_div : t ::: Type -> sql_arith t -> sql_binary t t t val sql_mod : sql_binary int int int val sql_eq : t ::: Type -> sql_binary t t bool -(* Note that the semantics of this operator on nullable types are different than for standard SQL! - * Instead, we do it the sane way, where [NULL = NULL]. *) - val sql_ne : t ::: Type -> sql_binary t t bool val sql_lt : t ::: Type -> sql_binary t t bool val sql_le : t ::: Type -> sql_binary t t bool -- cgit v1.2.3 From 8728f397bee2b567611dcd7a7c359c7e92159c1c Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Wed, 25 Sep 2019 19:54:59 -0400 Subject: Unicode escapes in JSON --- include/urweb/urweb_cpp.h | 1 + lib/ur/basis.urs | 1 + lib/ur/json.ur | 29 +++++++++++++++++++++++++++++ src/c/urweb.c | 12 ++++++++++++ 4 files changed, 43 insertions(+) (limited to 'lib/ur/basis.urs') diff --git a/include/urweb/urweb_cpp.h b/include/urweb/urweb_cpp.h index dcf67fef..e4ad6e61 100644 --- a/include/urweb/urweb_cpp.h +++ b/include/urweb/urweb_cpp.h @@ -166,6 +166,7 @@ uw_Basis_string uw_Basis_strchr(struct uw_context *, const char *, uw_Basis_char uw_Basis_int uw_Basis_strcspn(struct uw_context *, const char *, const char *); uw_Basis_string uw_Basis_substring(struct uw_context *, const char *, uw_Basis_int, uw_Basis_int); uw_Basis_string uw_Basis_str1(struct uw_context *, uw_Basis_char); +uw_Basis_string uw_Basis_ofUnicode(struct uw_context *, uw_Basis_int); uw_Basis_string uw_strdup(struct uw_context *, const char *); uw_Basis_string uw_maybe_strdup(struct uw_context *, const char *); diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index 2a98bf6f..d29bf6e6 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -95,6 +95,7 @@ val strsindex : string -> string -> option int val strcspn : string -> string -> int val substring : string -> int -> int -> string val str1 : char -> string +val ofUnicode : int -> string class show val show : t ::: Type -> show t -> t -> string diff --git a/lib/ur/json.ur b/lib/ur/json.ur index 05406739..70f0c797 100644 --- a/lib/ur/json.ur +++ b/lib/ur/json.ur @@ -59,6 +59,17 @@ fun escape s = "\"" ^ esc s end +fun unhex ch = + if Char.isDigit ch then + Char.toInt ch - Char.toInt #"0" + else if Char.isXdigit ch then + if Char.isUpper ch then + 10 + (Char.toInt ch - Char.toInt #"A") + else + 10 + (Char.toInt ch - Char.toInt #"a") + else + error Invalid hexadecimal digit "{[ch]}" + fun unescape s = let val len = String.length s @@ -75,6 +86,11 @@ fun unescape s = | #"\\" => if i+1 >= len then error JSON unescape: Bad escape sequence: {[s]} + else if String.sub s (i + 1) = #"u" then + if i+5 >= len then + error JSON unescape: Bad escape sequence: {[s]} + else + findEnd (i+6) else findEnd (i+2) | _ => findEnd (i+1) @@ -93,6 +109,19 @@ fun unescape s = #"\\" => if i+1 >= len then error JSON unescape: Bad escape sequence: {[s]} + else if String.sub s (i+1) = #"u" then + if i+5 >= len then + error JSON unescape: Unicode ends early + else + let + val n = + unhex (String.sub s (i+2)) * (256*16) + + unhex (String.sub s (i+3)) * 256 + + unhex (String.sub s (i+4)) * 16 + + unhex (String.sub s (i+5)) + in + ofUnicode n ^ unesc (i+6) + end else (case String.sub s (i+1) of #"n" => "\n" diff --git a/src/c/urweb.c b/src/c/urweb.c index af929269..8c445f39 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -2724,6 +2724,18 @@ uw_Basis_string uw_Basis_str1(uw_context ctx, uw_Basis_char ch) { return r; } +uw_Basis_string uw_Basis_ofUnicode(uw_context ctx, uw_Basis_int n) { + UChar buf16[] = {n}; + uw_Basis_string out = uw_malloc(ctx, 3); + int32_t outLen; + UErrorCode pErrorCode = 0; + + if (u_strToUTF8(out, 3, &outLen, buf16, 1, &pErrorCode) == NULL || outLen == 0) + uw_error(ctx, FATAL, "Bad Unicode string to unescape (error %s)", u_errorName(pErrorCode)); + + return out; +} + uw_Basis_string uw_strdup(uw_context ctx, uw_Basis_string s1) { int len = strlen(s1) + 1; char *s; -- cgit v1.2.3 From 36544aaddd3d904c6b234f39951c9136bf5867ff Mon Sep 17 00:00:00 2001 From: Mark Clements Date: Fri, 4 Oct 2019 14:24:35 +0200 Subject: Add Step attribute to crange; fix tests for cnumber and crange --- lib/ur/basis.urs | 2 +- tests/html5_cforms.ur | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) (limited to 'lib/ur/basis.urs') diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index d29bf6e6..a97c2855 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -1074,7 +1074,7 @@ val ctel : ctext val ccolor : ctext val cnumber : cformTag ([Source = source (option float), Min = float, Max = float, Step = float, Size = int] ++ boxAttrs ++ inputAttrs) [] -val crange : cformTag ([Source = source (option float), Min = float, Max = float, Size = int] ++ boxAttrs ++ inputAttrs) [] +val crange : cformTag ([Source = source (option float), Min = float, Max = float, Size = int, Step = float] ++ boxAttrs ++ inputAttrs) [] val cdate : cformTag ([Source = source string, Min = string, Max = string, Size = int] ++ boxAttrs ++ inputAttrs) [] val cdatetime : cformTag ([Source = source string, Min = string, Max = string, Size = int] ++ boxAttrs ++ inputAttrs) [] val cdatetime_local : cformTag ([Source = source string, Min = string, Max = string, Size = int] ++ boxAttrs ++ inputAttrs) [] diff --git a/tests/html5_cforms.ur b/tests/html5_cforms.ur index be07d07e..317a0638 100644 --- a/tests/html5_cforms.ur +++ b/tests/html5_cforms.ur @@ -9,8 +9,8 @@ fun main () : transaction page = d <- source ""; e <- source ""; f <- source ""; - g <- source 1.0; - h <- source 1.0; + g <- source (Some 1.0); + h <- source (Some 1.0); i <- source "#CCCCCC"; j <- source "2014/11/16"; k <- source "2014/11/16 12:30:45"; -- cgit v1.2.3 From 2bca6e48c0ea8043c5300f4ebdefa5167e6472bf Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Wed, 4 Dec 2019 09:19:55 -0500 Subject: SQL SIMILAR (via pg_trgm) --- lib/ur/basis.urs | 10 ++++++++++ src/cjr.sml | 2 +- src/cjr_print.sml | 21 +++++++++++++++++---- src/mono.sml | 2 +- src/mono_print.sml | 21 +++++++++++---------- src/monoize.sml | 49 +++++++++++++++++++++++++++++++++++++++++++++++-- src/mysql.sml | 3 ++- src/postgres.sml | 5 +++-- src/settings.sig | 3 ++- src/settings.sml | 6 ++++-- src/sqlite.sml | 3 ++- src/urweb.grm | 9 +++++++++ tests/filter.urp | 1 + tests/trgm.ur | 25 +++++++++++++++++++++++++ tests/trgm.urp | 6 ++++++ tests/trgm.urs | 1 + 16 files changed, 142 insertions(+), 25 deletions(-) create mode 100644 tests/trgm.ur create mode 100644 tests/trgm.urp create mode 100644 tests/trgm.urs (limited to 'lib/ur/basis.urs') diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index a97c2855..dda48d2b 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -623,6 +623,16 @@ val sql_known : t ::: Type -> sql_ufunc t bool val sql_lower : sql_ufunc string string val sql_upper : sql_ufunc string string +con sql_bfunc :: Type -> Type -> Type -> Type +val sql_bfunc : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} + -> dom1 ::: Type -> dom2 ::: Type -> ran ::: Type + -> sql_bfunc dom1 dom2 ran + -> sql_exp tables agg exps dom1 + -> sql_exp tables agg exps dom2 + -> sql_exp tables agg exps ran +val sql_similarity : sql_bfunc string string float +(* Only supported by Postgres for now, via the pg_trgm module *) + val sql_nullable : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} -> t ::: Type -> sql_injectable_prim t -> sql_exp tables agg exps t diff --git a/src/cjr.sml b/src/cjr.sml index e582e6ae..9b154428 100644 --- a/src/cjr.sml +++ b/src/cjr.sml @@ -115,7 +115,7 @@ datatype decl' = | DTable of string * (string * typ) list * string * (string * string) list | DSequence of string | DView of string * (string * typ) list * string - | DDatabase of {name : string, expunge : int, initialize : int} + | DDatabase of {name : string, expunge : int, initialize : int, usesSimilar : bool} | DPreparedStatements of (string * int) list | DJavaScript of string diff --git a/src/cjr_print.sml b/src/cjr_print.sml index d7b8017e..70ebdf43 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -3230,10 +3230,11 @@ fun p_file env (ds, ps) = val _ = foldl (fn (d, env) => ((case #1 d of - DDatabase {name = x, expunge = y, initialize = z} => (hasDb := true; - dbstring := x; - expunge := y; - initialize := z) + DDatabase {name = x, expunge = y, initialize = z, ...} => + (hasDb := true; + dbstring := x; + expunge := y; + initialize := z) | DJavaScript _ => hasJs := true | DTable (s, xts, _, _) => tables := (s, map (fn (x, t) => (x, sql_type_in env t)) xts) :: !tables @@ -3753,6 +3754,8 @@ fun declaresAsForeignKey xs s = fun p_sql env (ds, _) = let + val usesSimilar = ref false + val (pps, _) = ListUtil.foldlMap (fn (dAll as (d, _), env) => let @@ -3837,6 +3840,9 @@ fun p_sql env (ds, _) = string ";", newline, newline] + | DDatabase {usesSimilar = s, ...} => + (usesSimilar := s; + box []) | _ => box [] in (pp, E.declBinds env dAll) @@ -3849,6 +3855,13 @@ fun p_sql env (ds, _) = NONE => (ErrorMsg.error "Using file cache with database that doesn't support SHA512"; []) | SOME r => [string (#InitializeDb r), newline, newline]) + @ (if !usesSimilar then + case #supportsSimilar (Settings.currentDbms ()) of + NONE => (ErrorMsg.error "Using SIMILAR with database that doesn't support it"; + []) + | SOME r => [string (#InitializeDb r), newline, newline] + else + []) @ string (#sqlPrefix (Settings.currentDbms ())) :: pps) end diff --git a/src/mono.sml b/src/mono.sml index cdadded5..754fe283 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -142,7 +142,7 @@ datatype decl' = | DTable of string * (string * typ) list * exp * exp | DSequence of string | DView of string * (string * typ) list * exp - | DDatabase of {name : string, expunge : int, initialize : int} + | DDatabase of {name : string, expunge : int, initialize : int, usesSimilar : bool} | DJavaScript of string diff --git a/src/mono_print.sml b/src/mono_print.sml index a3b55ec0..1114a4f0 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -509,16 +509,17 @@ fun p_decl env (dAll as (d, _) : decl) = space, p_exp env e, string "*)"] - | DDatabase {name, expunge, initialize} => box [string "database", - space, - string name, - space, - string "(", - p_enamed env expunge, - string ",", - space, - p_enamed env initialize, - string ")"] + | DDatabase {name, expunge, initialize, ...} => + box [string "database", + space, + string name, + space, + string "(", + p_enamed env expunge, + string ",", + space, + p_enamed env initialize, + string ")"] | DJavaScript s => box [string "JavaScript(", string s, string ")"] diff --git a/src/monoize.sml b/src/monoize.sml index 4aeddcae..22b4e0e7 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -50,11 +50,13 @@ structure RM = BinaryMapFn(struct (L'.TRecord r2, E.dummySpan)) end) +val uses_similar = ref false + local val url_prefixes = ref [] in -fun reset () = url_prefixes := [] +fun reset () = (url_prefixes := []; uses_similar := false) fun addPrefix prefix = let @@ -355,6 +357,8 @@ fun monoType env = (L'.TFfi ("Basis", "string"), loc) | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_ufunc"), _), _), _), _) => (L'.TFfi ("Basis", "string"), loc) + | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_bfunc"), _), _), _), _), _), _) => + (L'.TFfi ("Basis", "string"), loc) | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_partition"), _), _), _), _), _), _) => (L'.TFfi ("Basis", "string"), loc) | L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_window"), _), _), _), _), _), _), _), _) => @@ -2693,6 +2697,40 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | L.ECApp ((L.EFfi ("Basis", "sql_known"), _), _) => ((L'.EFfi ("Basis", "sql_known"), loc), fm) + | L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.EFfi ("Basis", "sql_bfunc"), _), + _), _), + _), _), + _), _), + _), _), + _), _), + _) => + let + val s = (L'.TFfi ("Basis", "string"), loc) + in + ((L'.EAbs ("f", s, (L'.TFun (s, s), loc), + (L'.EAbs ("x1", s, s, + (L'.EAbs ("x2", s, s, + strcat [(L'.ERel 2, loc), + str "(", + (L'.ERel 1, loc), + str ",", + (L'.ERel 0, loc), + str ")"]), loc)), loc)), loc), + fm) + end + | L.EFfi ("Basis", "sql_similarity") => + ((case #supportsSimilar (Settings.currentDbms ()) of + NONE => ErrorMsg.errorAt loc "The DBMS you've selected doesn't support SIMILAR." + | _ => ()); + uses_similar := true; + (str "similarity", fm)) + | (L.ECApp ( (L.ECApp ( (L.ECApp ( @@ -4593,7 +4631,8 @@ fun monoize env file = in (env, Fm.enter fm, (L'.DDatabase {name = s, expunge = nExp, - initialize = nIni}, loc) + initialize = nIni, + usesSimilar = false}, loc) :: (dExp, loc) :: (dIni, loc) :: ds) @@ -4617,6 +4656,12 @@ fun monoize env file = | _ => ds' @ Fm.decls fm @ (L'.DDatatype (!pvarDefs), loc) :: ds))) (env, Fm.empty mname, []) file + val ds = map (fn (L'.DDatabase r, loc) => + (L'.DDatabase {name = #name r, + expunge = #expunge r, + initialize = #initialize r, + usesSimilar = !uses_similar}, loc) + | x => x) ds val monoFile = (rev ds, []) in pvars := RM.empty; diff --git a/src/mysql.sml b/src/mysql.sml index ff1c379d..74954c0f 100644 --- a/src/mysql.sml +++ b/src/mysql.sml @@ -1612,6 +1612,7 @@ val () = addDbms {name = "mysql", requiresTimestampDefaults = true, supportsIsDistinctFrom = true, supportsSHA512 = SOME {InitializeDb = "", - GenerateHash = fn name => "SHA2(" ^ name ^ ", 512)"}} + GenerateHash = fn name => "SHA2(" ^ name ^ ", 512)"}, + supportsSimilar = NONE} end diff --git a/src/postgres.sml b/src/postgres.sml index 94f0e42e..3e53ed77 100644 --- a/src/postgres.sml +++ b/src/postgres.sml @@ -1155,8 +1155,9 @@ val () = addDbms {name = "postgres", windowFunctions = true, requiresTimestampDefaults = false, supportsIsDistinctFrom = true, - supportsSHA512 = SOME {InitializeDb = "CREATE EXTENSION pgcrypto;", - GenerateHash = fn name => "DIGEST(" ^ name ^ ", 'sha512')"}} + supportsSHA512 = SOME {InitializeDb = "CREATE EXTENSION IF NOT EXISTS pgcrypto;", + GenerateHash = fn name => "DIGEST(" ^ name ^ ", 'sha512')"}, + supportsSimilar = SOME {InitializeDb = "CREATE EXTENSION IF NOT EXISTS pg_trgm;"}} val () = setDbms "postgres" diff --git a/src/settings.sig b/src/settings.sig index a2a56407..6a409cdd 100644 --- a/src/settings.sig +++ b/src/settings.sig @@ -224,10 +224,11 @@ signature SETTINGS = sig requiresTimestampDefaults : bool, supportsIsDistinctFrom : bool, supportsSHA512 : {InitializeDb : string, - GenerateHash : string -> string} option + GenerateHash : string -> string} option, (* If supported, give the SQL code to * enable the feature in a particular * database and to compute a hash of a value. *) + supportsSimilar : {InitializeDb : string} option } val addDbms : dbms -> unit diff --git a/src/settings.sml b/src/settings.sml index a85e8053..c8cb049c 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -653,7 +653,8 @@ type dbms = { windowFunctions: bool, requiresTimestampDefaults : bool, supportsIsDistinctFrom : bool, - supportsSHA512 : {InitializeDb : string, GenerateHash : string -> string} option + supportsSHA512 : {InitializeDb : string, GenerateHash : string -> string} option, + supportsSimilar : {InitializeDb : string} option } val dbmses = ref ([] : dbms list) @@ -688,7 +689,8 @@ val curDb = ref ({name = "", windowFunctions = false, requiresTimestampDefaults = false, supportsIsDistinctFrom = false, - supportsSHA512 = NONE} : dbms) + supportsSHA512 = NONE, + supportsSimilar = NONE} : dbms) fun addDbms v = dbmses := v :: !dbmses fun setDbms s = diff --git a/src/sqlite.sml b/src/sqlite.sml index 9bb86ecf..0e97bf69 100644 --- a/src/sqlite.sml +++ b/src/sqlite.sml @@ -857,6 +857,7 @@ val () = addDbms {name = "sqlite", windowFunctions = false, requiresTimestampDefaults = false, supportsIsDistinctFrom = false, - supportsSHA512 = NONE} + supportsSHA512 = NONE, + supportsSimilar = NONE} end diff --git a/src/urweb.grm b/src/urweb.grm index afebff0a..dea7bdf5 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -2276,6 +2276,15 @@ sqlexp : TRUE (sql_inject (EVar (["Basis"], "True", In val e = (EApp (e, fname), loc) in (EApp (e, sqlexp), loc) + end) + | fname LPAREN sqlexp COMMA sqlexp RPAREN (let + val loc = s (fnameleft, RPARENright) + + val e = (EVar (["Basis"], "sql_bfunc", Infer), loc) + val e = (EApp (e, fname), loc) + val e = (EApp (e, sqlexp1), loc) + in + (EApp (e, sqlexp2), loc) end) | LPAREN query RPAREN (let val loc = s (LPARENleft, RPARENright) diff --git a/tests/filter.urp b/tests/filter.urp index 102a1871..ddf1a3df 100644 --- a/tests/filter.urp +++ b/tests/filter.urp @@ -1,4 +1,5 @@ debug database dbname=filter +sql filter.sql filter diff --git a/tests/trgm.ur b/tests/trgm.ur new file mode 100644 index 00000000..45783366 --- /dev/null +++ b/tests/trgm.ur @@ -0,0 +1,25 @@ +table turtles : { Nam : string } + +fun add name = + dml (INSERT INTO turtles(Nam) + VALUES ({[name]})) + +fun closest name = + List.mapQuery (SELECT * + FROM turtles + ORDER BY similarity(turtles.Nam, {[name]}) DESC + LIMIT 5) + (fn r => r.Turtles.Nam) + +val main = + name <- source ""; + results <- source []; + return + Name:
+