summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--include/urweb.h4
-rw-r--r--lib/ur/basis.urs20
-rw-r--r--src/c/urweb.c43
-rw-r--r--src/cjr_print.sml17
-rw-r--r--src/monoize.sml26
-rw-r--r--src/prepare.sml18
-rw-r--r--tests/chat.ur36
-rw-r--r--tests/chat.urp5
8 files changed, 147 insertions, 22 deletions
diff --git a/include/urweb.h b/include/urweb.h
index 6a9a48a6..22fe12ac 100644
--- a/include/urweb.h
+++ b/include/urweb.h
@@ -66,6 +66,7 @@ uw_unit uw_Basis_htmlifyTime_w(uw_context, uw_Basis_time);
char *uw_Basis_attrifyInt(uw_context, uw_Basis_int);
char *uw_Basis_attrifyFloat(uw_context, uw_Basis_float);
char *uw_Basis_attrifyString(uw_context, uw_Basis_string);
+char *uw_Basis_attrifyChannel(uw_context, uw_Basis_channel);
uw_unit uw_Basis_attrifyInt_w(uw_context, uw_Basis_int);
uw_unit uw_Basis_attrifyFloat_w(uw_context, uw_Basis_float);
@@ -98,6 +99,7 @@ uw_Basis_string uw_Basis_sqlifyFloat(uw_context, uw_Basis_float);
uw_Basis_string uw_Basis_sqlifyString(uw_context, uw_Basis_string);
uw_Basis_string uw_Basis_sqlifyBool(uw_context, uw_Basis_bool);
uw_Basis_string uw_Basis_sqlifyTime(uw_context, uw_Basis_time);
+uw_Basis_string uw_Basis_sqlifyChannel(uw_context, uw_Basis_channel);
uw_Basis_string uw_Basis_sqlifyIntN(uw_context, uw_Basis_int*);
uw_Basis_string uw_Basis_sqlifyFloatN(uw_context, uw_Basis_float*);
@@ -118,11 +120,13 @@ uw_Basis_int *uw_Basis_stringToInt(uw_context, uw_Basis_string);
uw_Basis_float *uw_Basis_stringToFloat(uw_context, uw_Basis_string);
uw_Basis_bool *uw_Basis_stringToBool(uw_context, uw_Basis_string);
uw_Basis_time *uw_Basis_stringToTime(uw_context, uw_Basis_string);
+uw_Basis_channel *uw_Basis_stringToChannel(uw_context, uw_Basis_string);
uw_Basis_int uw_Basis_stringToInt_error(uw_context, uw_Basis_string);
uw_Basis_float uw_Basis_stringToFloat_error(uw_context, uw_Basis_string);
uw_Basis_bool uw_Basis_stringToBool_error(uw_context, uw_Basis_string);
uw_Basis_time uw_Basis_stringToTime_error(uw_context, uw_Basis_string);
+uw_Basis_channel uw_Basis_stringToChannel_error(uw_context, uw_Basis_string);
uw_Basis_string uw_Basis_requestHeader(uw_context, uw_Basis_string);
diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index d3d4fe22..23c3fe57 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -107,6 +107,15 @@ val setCookie : t ::: Type -> http_cookie t -> t -> transaction unit
val alert : string -> transaction unit
+(** Channels *)
+
+con channel :: Type -> Type
+val channel : t ::: Type -> transaction (channel t)
+val subscribe : t ::: Type -> channel t -> transaction unit
+val send : t ::: Type -> channel t -> t -> transaction unit
+val recv : t ::: Type -> channel t -> transaction t
+
+
(** SQL *)
con sql_table :: {Type} -> Type
@@ -196,9 +205,13 @@ val sql_float : sql_injectable_prim float
val sql_string : sql_injectable_prim string
val sql_time : sql_injectable_prim time
+class sql_injectable_nullable
+val sql_channel : t ::: Type -> sql_injectable_nullable (channel t)
+
class sql_injectable
val sql_prim : t ::: Type -> sql_injectable_prim t -> sql_injectable t
val sql_option_prim : t ::: Type -> sql_injectable_prim t -> sql_injectable (option t)
+val sql_nullable : t ::: Type -> sql_injectable_nullable t -> sql_injectable (option t)
val sql_inject : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
-> t ::: Type
@@ -454,10 +467,3 @@ val td : other ::: {Unit} -> [other ~ [Body, Tr]] =>
val error : t ::: Type -> xml [Body] [] [] -> t
-(** Channels *)
-
-con channel :: Type -> Type
-val channel : t ::: Type -> transaction (channel t)
-val subscribe : t ::: Type -> channel t -> transaction unit
-val send : t ::: Type -> channel t -> t -> transaction unit
-val recv : t ::: Type -> channel t -> transaction t
diff --git a/src/c/urweb.c b/src/c/urweb.c
index 5fa2af42..75f7675f 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -999,6 +999,16 @@ char *uw_Basis_attrifyInt(uw_context ctx, uw_Basis_int n) {
return result;
}
+char *uw_Basis_attrifyChannel(uw_context ctx, uw_Basis_channel n) {
+ char *result;
+ int len;
+ uw_check_heap(ctx, INTS_MAX);
+ result = ctx->heap.front;
+ sprintf(result, "%lld%n", (long long)n, &len);
+ ctx->heap.front += len+1;
+ return result;
+}
+
char *uw_Basis_attrifyFloat(uw_context ctx, uw_Basis_float n) {
char *result;
int len;
@@ -1502,6 +1512,17 @@ char *uw_Basis_sqlifyInt(uw_context ctx, uw_Basis_int n) {
return r;
}
+char *uw_Basis_sqlifyChannel(uw_context ctx, uw_Basis_channel n) {
+ int len;
+ char *r;
+
+ uw_check_heap(ctx, INTS_MAX + 6);
+ r = ctx->heap.front;
+ sprintf(r, "%lld::int4%n", (long long)n, &len);
+ ctx->heap.front += len+1;
+ return r;
+}
+
char *uw_Basis_sqlifyIntN(uw_context ctx, uw_Basis_int *n) {
if (n == NULL)
return "NULL";
@@ -1673,6 +1694,18 @@ uw_Basis_int *uw_Basis_stringToInt(uw_context ctx, uw_Basis_string s) {
return NULL;
}
+uw_Basis_channel *uw_Basis_stringToChannel(uw_context ctx, uw_Basis_string s) {
+ char *endptr;
+ uw_Basis_channel n = strtoll(s, &endptr, 10);
+
+ if (*s != '\0' && *endptr == '\0') {
+ uw_Basis_channel *r = uw_malloc(ctx, sizeof(uw_Basis_channel));
+ *r = n;
+ return r;
+ } else
+ return NULL;
+}
+
uw_Basis_float *uw_Basis_stringToFloat(uw_context ctx, uw_Basis_string s) {
char *endptr;
uw_Basis_float n = strtod(s, &endptr);
@@ -1740,6 +1773,16 @@ uw_Basis_int uw_Basis_stringToInt_error(uw_context ctx, uw_Basis_string s) {
uw_error(ctx, FATAL, "Can't parse int: %s", s);
}
+uw_Basis_channel uw_Basis_stringToChannel_error(uw_context ctx, uw_Basis_string s) {
+ char *endptr;
+ uw_Basis_channel n = strtoll(s, &endptr, 10);
+
+ if (*s != '\0' && *endptr == '\0')
+ return n;
+ else
+ uw_error(ctx, FATAL, "Can't parse channel int: %s", s);
+}
+
uw_Basis_float uw_Basis_stringToFloat_error(uw_context ctx, uw_Basis_string s) {
char *endptr;
uw_Basis_float n = strtod(s, &endptr);
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 79a43d19..a17a0416 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -403,6 +403,7 @@ fun p_unsql wontLeakStrings env (tAll as (t, loc)) e =
box [string "uw_Basis_strdup(ctx, ", e, string ")"]
| TFfi ("Basis", "bool") => box [string "uw_Basis_stringToBool_error(ctx, ", e, string ")"]
| TFfi ("Basis", "time") => box [string "uw_Basis_stringToTime_error(ctx, ", e, string ")"]
+ | TFfi ("Basis", "channel") => box [string "uw_Basis_stringToChannel_error(ctx, ", e, string ")"]
| _ => (ErrorMsg.errorAt loc "Don't know how to unmarshal type from SQL";
Print.eprefaces' [("Type", p_typ env tAll)];
@@ -445,6 +446,7 @@ datatype sql_type =
| String
| Bool
| Time
+ | Channel
| Nullable of sql_type
fun p_sql_type' t =
@@ -454,6 +456,7 @@ fun p_sql_type' t =
| String => "uw_Basis_string"
| Bool => "uw_Basis_bool"
| Time => "uw_Basis_time"
+ | Channel => "uw_Basis_channel"
| Nullable String => "uw_Basis_string"
| Nullable t => p_sql_type' t ^ "*"
@@ -469,12 +472,14 @@ fun getPargs (e, _) =
| EFfiApp ("Basis", "sqlifyString", [e]) => [(e, String)]
| EFfiApp ("Basis", "sqlifyBool", [e]) => [(e, Bool)]
| EFfiApp ("Basis", "sqlifyTime", [e]) => [(e, Time)]
+ | EFfiApp ("Basis", "sqlifyChannel", [e]) => [(e, Channel)]
- | EFfiApp ("Basis", "sqlifyIntN", [e]) => [(e, Nullable Int)]
- | EFfiApp ("Basis", "sqlifyFloatN", [e]) => [(e, Nullable Float)]
- | EFfiApp ("Basis", "sqlifyStringN", [e]) => [(e, Nullable String)]
- | EFfiApp ("Basis", "sqlifyBoolN", [e]) => [(e, Nullable Bool)]
- | EFfiApp ("Basis", "sqlifyTimeN", [e]) => [(e, Nullable Time)]
+ | ECase (e,
+ [((PNone _, _),
+ (EPrim (Prim.String "NULL"), _)),
+ ((PSome (_, (PVar _, _)), _),
+ (EFfiApp (m, x, [(ERel 0, _)]), _))],
+ _) => map (fn (x, y) => (x, Nullable y)) (getPargs (EFfiApp (m, x, [e]), #2 e))
| ECase (e,
[((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, _), _),
@@ -492,6 +497,7 @@ fun p_ensql t e =
| String => e
| Bool => box [string "(", e, string " ? \"TRUE\" : \"FALSE\")"]
| Time => box [string "uw_Basis_sqlifyTime(ctx, ", e, string ")"]
+ | Channel => box [string "uw_Basis_attrifyChannel(ctx, ", e, string ")"]
| Nullable String => e
| Nullable t => box [string "(",
e,
@@ -2102,6 +2108,7 @@ fun p_sqltype'' env (tAll as (t, loc)) =
| TFfi ("Basis", "string") => "text"
| TFfi ("Basis", "bool") => "bool"
| TFfi ("Basis", "time") => "timestamp"
+ | TFfi ("Basis", "channel") => "int4"
| _ => (ErrorMsg.errorAt loc "Don't know SQL equivalent of type";
Print.eprefaces' [("Type", p_typ env tAll)];
"ERROR")
diff --git a/src/monoize.sml b/src/monoize.sml
index 1860fd19..eb3f81b3 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -165,6 +165,8 @@ fun monoType env =
| L.CApp ((L.CFfi ("Basis", "sql_injectable_prim"), _), t) =>
(L'.TFun (mt env dtmap t, (L'.TFfi ("Basis", "string"), loc)), loc)
+ | L.CApp ((L.CFfi ("Basis", "sql_injectable_nullable"), _), t) =>
+ (L'.TFun (mt env dtmap t, (L'.TFfi ("Basis", "string"), loc)), loc)
| L.CApp ((L.CFfi ("Basis", "sql_injectable"), _), t) =>
(L'.TFun (mt env dtmap t, (L'.TFfi ("Basis", "string"), loc)), loc)
| L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_unary"), _), _), _), _) =>
@@ -1425,6 +1427,10 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
((L'.EAbs ("x", (L'.TFfi ("Basis", "time"), loc), (L'.TFfi ("Basis", "string"), loc),
(L'.EFfiApp ("Basis", "sqlifyTime", [(L'.ERel 0, loc)]), loc)), loc),
fm)
+ | L.ECApp ((L.EFfi ("Basis", "sql_channel"), _), _) =>
+ ((L'.EAbs ("x", (L'.TFfi ("Basis", "channel"), loc), (L'.TFfi ("Basis", "string"), loc),
+ (L'.EFfiApp ("Basis", "sqlifyChannel", [(L'.ERel 0, loc)]), loc)), loc),
+ fm)
| L.ECApp ((L.EFfi ("Basis", "sql_prim"), _), t) =>
let
val t = monoType env t
@@ -1453,6 +1459,26 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
result = s}), loc)), loc)), loc),
fm)
end
+ | L.ECApp ((L.EFfi ("Basis", "sql_nullable"), _), t) =>
+ let
+ val t = monoType env t
+ val s = (L'.TFfi ("Basis", "string"), loc)
+ in
+ ((L'.EAbs ("f",
+ (L'.TFun (t, s), loc),
+ (L'.TFun ((L'.TOption t, loc), s), loc),
+ (L'.EAbs ("x",
+ (L'.TOption t, loc),
+ s,
+ (L'.ECase ((L'.ERel 0, loc),
+ [((L'.PNone t, loc),
+ (L'.EPrim (Prim.String "NULL"), loc)),
+ ((L'.PSome (t, (L'.PVar ("y", t), loc)), loc),
+ (L'.EApp ((L'.ERel 2, loc), (L'.ERel 0, loc)), loc))],
+ {disc = (L'.TOption t, loc),
+ result = s}), loc)), loc)), loc),
+ fm)
+ end
| L.ECApp ((L.EFfi ("Basis", "sql_subset"), _), _) =>
((L'.ERecord [], loc), fm)
diff --git a/src/prepare.sml b/src/prepare.sml
index 110f6f9a..1f3f323a 100644
--- a/src/prepare.sml
+++ b/src/prepare.sml
@@ -47,17 +47,15 @@ fun prepString (e, ss, n) =
SOME ("$" ^ Int.toString (n + 1) ^ "::bool" :: ss, n + 1)
| EFfiApp ("Basis", "sqlifyTime", [e]) =>
SOME ("$" ^ Int.toString (n + 1) ^ "::timestamp" :: ss, n + 1)
+ | EFfiApp ("Basis", "sqlifyChannel", [e]) =>
+ SOME ("$" ^ Int.toString (n + 1) ^ "::int4" :: ss, n + 1)
- | EFfiApp ("Basis", "sqlifyIntN", [e]) =>
- SOME ("$" ^ Int.toString (n + 1) ^ "::int8" :: ss, n + 1)
- | EFfiApp ("Basis", "sqlifyFloatN", [e]) =>
- SOME ("$" ^ Int.toString (n + 1) ^ "::float8" :: ss, n + 1)
- | EFfiApp ("Basis", "sqlifyStringN", [e]) =>
- SOME ("$" ^ Int.toString (n + 1) ^ "::text" :: ss, n + 1)
- | EFfiApp ("Basis", "sqlifyBoolN", [e]) =>
- SOME ("$" ^ Int.toString (n + 1) ^ "::bool" :: ss, n + 1)
- | EFfiApp ("Basis", "sqlifyTimeN", [e]) =>
- SOME ("$" ^ Int.toString (n + 1) ^ "::timestamp" :: ss, n + 1)
+ | ECase (e,
+ [((PNone _, _),
+ (EPrim (Prim.String "NULL"), _)),
+ ((PSome (_, (PVar _, _)), _),
+ (EFfiApp (m, x, [(ERel 0, _)]), _))],
+ _) => prepString ((EFfiApp (m, x, [e]), #2 e), ss, n)
| ECase (e,
[((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, _), _),
diff --git a/tests/chat.ur b/tests/chat.ur
new file mode 100644
index 00000000..710d97d4
--- /dev/null
+++ b/tests/chat.ur
@@ -0,0 +1,36 @@
+sequence s
+table t : { Id : int, Title : string, Chan : option (channel string) }
+
+fun list () =
+ queryX (SELECT * FROM t)
+ (fn r => <xml><tr>
+ <td>{[r.T.Id]}</td> <td>{[r.T.Title]}</td>
+ <td><a link={delete r.T.Id}>[delete]</a></td>
+ </tr></xml>)
+
+and delete id =
+ dml (DELETE FROM t WHERE Id = {[id]});
+ main ()
+
+and main () : transaction page =
+ let
+ fun create r =
+ id <- nextval s;
+ dml (INSERT INTO t (Id, Title, Chan) VALUES ({[id]}, {[r.Title]}, NULL));
+ main ()
+ in
+ ls <- list ();
+ return <xml><body>
+ <table>
+ <tr> <th>ID</th> <th>Title</th> </tr>
+ {ls}
+ </table>
+
+ <h1>New Channel</h1>
+
+ <form>
+ Title: <textbox{#Title}/><br/>
+ <submit action={create}/>
+ </form>
+ </body></xml>
+ end
diff --git a/tests/chat.urp b/tests/chat.urp
new file mode 100644
index 00000000..1c42449d
--- /dev/null
+++ b/tests/chat.urp
@@ -0,0 +1,5 @@
+debug
+database dbname=chat
+sql chat.sql
+
+chat
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-19 05:39:26 +0000