Preliminary work supporting channels in databases

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