Mercurial > urweb
changeset 678:5ff1ff38e2db
Preliminary work supporting channels in databases
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Thu, 26 Mar 2009 16:22:34 -0400 |
| parents | 81573f62d6c3 |
| children | 44f23712020d |
| files | include/urweb.h lib/ur/basis.urs src/c/urweb.c src/cjr_print.sml src/monoize.sml src/prepare.sml tests/chat.ur tests/chat.urp |
| diffstat | 8 files changed, 147 insertions(+), 22 deletions(-) [+] |
line wrap: on
line diff
--- a/include/urweb.h Thu Mar 26 15:54:04 2009 -0400 +++ b/include/urweb.h Thu Mar 26 16:22:34 2009 -0400 @@ -66,6 +66,7 @@ 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_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_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);
--- a/lib/ur/basis.urs Thu Mar 26 15:54:04 2009 -0400 +++ b/lib/ur/basis.urs Thu Mar 26 16:22:34 2009 -0400 @@ -107,6 +107,15 @@ 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_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 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
--- a/src/c/urweb.c Thu Mar 26 15:54:04 2009 -0400 +++ b/src/c/urweb.c Thu Mar 26 16:22:34 2009 -0400 @@ -999,6 +999,16 @@ 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 @@ 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 @@ 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_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);
--- a/src/cjr_print.sml Thu Mar 26 15:54:04 2009 -0400 +++ b/src/cjr_print.sml Thu Mar 26 16:22:34 2009 -0400 @@ -403,6 +403,7 @@ 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 @@ | String | Bool | Time + | Channel | Nullable of sql_type fun p_sql_type' t = @@ -454,6 +456,7 @@ | 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 @@ | 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 @@ | 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 @@ | 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")
--- a/src/monoize.sml Thu Mar 26 15:54:04 2009 -0400 +++ b/src/monoize.sml Thu Mar 26 16:22:34 2009 -0400 @@ -165,6 +165,8 @@ | 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 @@ ((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 @@ 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)
--- a/src/prepare.sml Thu Mar 26 15:54:04 2009 -0400 +++ b/src/prepare.sml Thu Mar 26 16:22:34 2009 -0400 @@ -47,17 +47,15 @@ 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", ...}, _), _),
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/chat.ur Thu Mar 26 16:22:34 2009 -0400 @@ -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