Mercurial > urweb
changeset 1011:16f7cb0891b6
Initial support for char in SQL
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Thu, 22 Oct 2009 16:15:56 -0400 |
| parents | 6b0f3853cc81 |
| children | 32dbb5636ae7 |
| files | demo/more/conference.ur demo/more/conference.urp demo/more/conference.urs demo/more/conference1.ur demo/more/conferenceFields.ur demo/more/conferenceFields.urs demo/more/meta.ur demo/more/meta.urs include/urweb.h lib/ur/basis.urs src/c/urweb.c src/cjr_print.sml src/mono_opt.sml src/monoize.sml src/mysql.sml src/postgres.sml src/settings.sig src/settings.sml src/sqlite.sml |
| diffstat | 19 files changed, 206 insertions(+), 22 deletions(-) [+] |
line wrap: on
line diff
--- a/demo/more/conference.ur Thu Oct 22 14:05:48 2009 -0400 +++ b/demo/more/conference.ur Thu Oct 22 16:15:56 2009 -0400 @@ -9,6 +9,7 @@ con review :: {(Type * Type)} constraint [Paper, User] ~ review val review : $(map meta review) + val reviewFolder : folder review val submissionDeadline : time val summarizePaper : $(map fst paper) -> xbody @@ -26,7 +27,7 @@ table authorship : {Paper : int, User : int} PRIMARY KEY (Paper, User), - CONSTRAINT Paper FOREIGN KEY Paper REFERENCES paper(Id), + CONSTRAINT Paper FOREIGN KEY Paper REFERENCES paper(Id) ON DELETE CASCADE, CONSTRAINT User FOREIGN KEY User REFERENCES user(Id) con review = [Paper = int, User = int] ++ map fst M.review @@ -249,6 +250,7 @@ </body></xml> and one id = + me <- getLogin; checkPaper id; ro <- oneOrNoRows (SELECT paper.{{map fst M.paper}}, octet_length(paper.Document) AS N FROM paper @@ -258,6 +260,10 @@ JOIN user ON authorship.User = user.Id WHERE authorship.Paper = {[id]}) (fn r => <xml><li>{[r.User.Nam]}</li></xml>); + myReview <- oneOrNoRows1 (SELECT review.{{map fst M.review}} + FROM review + WHERE review.User = {[me.Id]} + AND review.Paper = {[id]}); case ro of None => error <xml>Paper not found!</xml> | Some r => return <xml><body> @@ -274,6 +280,24 @@ <xml><div>No paper uploaded yet.</div></xml> else <xml><a link={download id}>Download paper</a> ({[r.N]} bytes)</xml>} + + <hr/> + + {case myReview of + None => <xml> + <h2>Add Your Review</h2> + + <form> + {allWidgets M.review M.reviewFolder} + </form> + </xml> + | Some myReview => <xml> + <h2>Edit Your Review</h2> + + <form> + {allPopulated M.review myReview M.reviewFolder} + </form> + </xml>} </body></xml> and download id =
--- a/demo/more/conference.urp Thu Oct 22 14:05:48 2009 -0400 +++ b/demo/more/conference.urp Thu Oct 22 16:15:56 2009 -0400 @@ -1,5 +1,6 @@ allow mime application/pdf +$/string $/option $/list meta
--- a/demo/more/conference.urs Thu Oct 22 14:05:48 2009 -0400 +++ b/demo/more/conference.urs Thu Oct 22 16:15:56 2009 -0400 @@ -7,6 +7,7 @@ con review :: {(Type * Type)} constraint [Paper, User] ~ review val review : $(map Meta.meta review) + val reviewFolder : folder review val submissionDeadline : time val summarizePaper : $(map fst paper) -> xbody
--- a/demo/more/conference1.ur Thu Oct 22 14:05:48 2009 -0400 +++ b/demo/more/conference1.ur Thu Oct 22 16:15:56 2009 -0400 @@ -3,7 +3,7 @@ open Conference.Make(struct val paper = {Title = title, Abstract = abstract} - val review = {} + val review = {Rating = dropdown "Rating" (#"A" :: #"B" :: #"C" :: #"D" :: [])} val submissionDeadline = readError "2009-10-22 23:59:59"
--- a/demo/more/conferenceFields.ur Thu Oct 22 14:05:48 2009 -0400 +++ b/demo/more/conferenceFields.ur Thu Oct 22 16:15:56 2009 -0400 @@ -2,3 +2,22 @@ val title = string "Title" val abstract = textarea "Abstract" + +fun charIn s = + if String.length s = 0 then + error <xml>Impossible: Empty option value</xml> + else + String.sub s 0 + +con dropdown = (char, string) +fun dropdown name opts = {Nam = name, + Show = txt, + Widget = fn [nm :: Name] => <xml><select{nm}> + {List.mapX (fn x => <xml><option>{[x]}</option></xml>) opts} + </select></xml>, + WidgetPopulated = fn [nm :: Name] v => <xml><select{nm}> + {List.mapX (fn x => <xml><option selected={x = v}>{[x]}</option></xml>) opts} + </select></xml>, + Parse = charIn, + Inject = _} +
--- a/demo/more/conferenceFields.urs Thu Oct 22 14:05:48 2009 -0400 +++ b/demo/more/conferenceFields.urs Thu Oct 22 16:15:56 2009 -0400 @@ -1,2 +1,5 @@ val title : Meta.meta (string, string) val abstract : Meta.meta (string, string) + +con dropdown :: (Type * Type) +val dropdown : string -> list char -> Meta.meta dropdown
--- a/demo/more/meta.ur Thu Oct 22 14:05:48 2009 -0400 +++ b/demo/more/meta.ur Thu Oct 22 16:15:56 2009 -0400 @@ -52,6 +52,18 @@ <xml/> [_] fl r +fun allPopulated [ts ::: {(Type * Type)}] (r : $(map meta ts)) (vs : $(map fst ts)) (fl : folder ts) = + foldR2 [meta] [fst] [fn cols :: {(Type * Type)} => + xml form [] (map snd cols)] + (fn [nm :: Name] [p :: (Type * Type)] [rest :: {(Type * Type)}] [[nm] ~ rest] + (m : meta p) v (acc : xml form [] (map snd rest)) => + <xml> + {[m.Nam]}: {m.WidgetPopulated [nm] v}<br/> + {useMore acc} + </xml>) + <xml/> + [_] fl r vs + fun allPopulatedTr [ts ::: {(Type * Type)}] (r : $(map meta ts)) (vs : $(map fst ts)) (fl : folder ts) = foldR2 [meta] [fst] [fn cols :: {(Type * Type)} => xml [Body, Form, Tr] [] (map snd cols)]
--- a/demo/more/meta.urs Thu Oct 22 14:05:48 2009 -0400 +++ b/demo/more/meta.urs Thu Oct 22 16:15:56 2009 -0400 @@ -18,6 +18,9 @@ val allWidgets : ts ::: {(Type * Type)} -> $(map meta ts) -> folder ts -> xml form [] (map snd ts) +val allPopulated : ts ::: {(Type * Type)} -> $(map meta ts) -> $(map fst ts) -> folder ts + -> xml form [] (map snd ts) + val allPopulatedTr : ts ::: {(Type * Type)} -> $(map meta ts) -> $(map fst ts) -> folder ts -> xml ([Tr] ++ form) [] (map snd ts)
--- a/include/urweb.h Thu Oct 22 14:05:48 2009 -0400 +++ b/include/urweb.h Thu Oct 22 16:15:56 2009 -0400 @@ -88,6 +88,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_attrifyChar(uw_context, uw_Basis_char); char *uw_Basis_attrifyTime(uw_context, uw_Basis_time); char *uw_Basis_attrifyChannel(uw_context, uw_Basis_channel); char *uw_Basis_attrifyClient(uw_context, uw_Basis_client); @@ -96,6 +97,7 @@ uw_unit uw_Basis_attrifyInt_w(uw_context, uw_Basis_int); uw_unit uw_Basis_attrifyFloat_w(uw_context, uw_Basis_float); uw_unit uw_Basis_attrifyString_w(uw_context, uw_Basis_string); +uw_unit uw_Basis_attrifyChar_w(uw_context, uw_Basis_char); char *uw_Basis_urlifyInt(uw_context, uw_Basis_int); char *uw_Basis_urlifyFloat(uw_context, uw_Basis_float); @@ -133,6 +135,7 @@ uw_Basis_string uw_Basis_sqlifyInt(uw_context, uw_Basis_int); 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_sqlifyChar(uw_context, uw_Basis_char); 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_sqlifyBlob(uw_context, uw_Basis_blob); @@ -216,6 +219,7 @@ extern char *uw_sqlfmtFloat; extern int uw_Estrings; extern char *uw_sqlsuffixString; +extern char *uw_sqlsuffixChar; extern char *uw_sqlsuffixBlob; extern char *uw_sqlfmtUint4;
--- a/lib/ur/basis.urs Thu Oct 22 14:05:48 2009 -0400 +++ b/lib/ur/basis.urs Thu Oct 22 16:15:56 2009 -0400 @@ -165,6 +165,7 @@ val sql_int : sql_injectable_prim int val sql_float : sql_injectable_prim float val sql_string : sql_injectable_prim string +val sql_char : sql_injectable_prim char val sql_time : sql_injectable_prim time val sql_blob : sql_injectable_prim blob val sql_channel : t ::: Type -> sql_injectable_prim (channel t)
--- a/src/c/urweb.c Thu Oct 22 14:05:48 2009 -0400 +++ b/src/c/urweb.c Thu Oct 22 16:15:56 2009 -0400 @@ -1388,6 +1388,32 @@ return result; } +char *uw_Basis_attrifyChar(uw_context ctx, uw_Basis_char c) { + char *result, *p; + uw_check_heap(ctx, 7); + + result = p = ctx->heap.front; + + if (c == '"') { + strcpy(p, """); + p += 6; + } else if (c == '&') { + strcpy(p, "&"); + p += 5; + } + else if (isprint(c)) + *p++ = c; + else { + int len2; + sprintf(p, "&#%d;%n", c, &len2); + p += len2; + } + + *p++ = 0; + ctx->heap.front = p; + return result; +} + char *uw_Basis_attrifyCss_class(uw_context ctx, uw_Basis_css_class s) { return s; } @@ -1438,6 +1464,24 @@ return uw_unit_v; } +uw_unit uw_Basis_attrifyChar_w(uw_context ctx, uw_Basis_char c) { + uw_check(ctx, 6); + + if (c == '"') + uw_write_unsafe(ctx, """); + else if (c == '&') + uw_write_unsafe(ctx, "&"); + else if (isprint(c)) + uw_writec_unsafe(ctx, c); + else { + uw_write_unsafe(ctx, "&#"); + uw_Basis_attrifyInt_w_unsafe(ctx, c); + uw_writec_unsafe(ctx, ';'); + } + + return uw_unit_v; +} + char *uw_Basis_urlifyInt(uw_context ctx, uw_Basis_int n) { int len; @@ -1988,6 +2032,7 @@ int uw_Estrings = 1; char *uw_sqlsuffixString = "::text"; +char *uw_sqlsuffixChar = "::char"; uw_Basis_string uw_Basis_sqlifyString(uw_context ctx, uw_Basis_string s) { char *r, *s2; @@ -2035,6 +2080,48 @@ return r; } +uw_Basis_string uw_Basis_sqlifyChar(uw_context ctx, uw_Basis_char c) { + char *r, *s2; + + uw_check_heap(ctx, 5 + uw_Estrings + strlen(uw_sqlsuffixChar)); + + r = s2 = ctx->heap.front; + if (uw_Estrings) + *s2++ = 'E'; + *s2++ = '\''; + + switch (c) { + case '\'': + if (uw_Estrings) + strcpy(s2, "\\'"); + else + strcpy(s2, "''"); + s2 += 2; + break; + case '\\': + if (uw_Estrings) { + strcpy(s2, "\\\\"); + s2 += 2; + } else + *s2++ = '\\'; + break; + default: + if (isprint(c)) + *s2++ = c; + else if (uw_Estrings) { + sprintf(s2, "\\%03o", c); + s2 += 4; + } + else + uw_error(ctx, FATAL, "Non-printable character %u in char to SQLify", c); + } + + *s2++ = '\''; + strcpy(s2, uw_sqlsuffixChar); + ctx->heap.front = s2 + 1 + strlen(uw_sqlsuffixChar); + return r; +} + char *uw_sqlsuffixBlob = "::bytea"; uw_Basis_string uw_Basis_sqlifyBlob(uw_context ctx, uw_Basis_blob b) {
--- a/src/cjr_print.sml Thu Oct 22 14:05:48 2009 -0400 +++ b/src/cjr_print.sml Thu Oct 22 16:15:56 2009 -0400 @@ -491,20 +491,7 @@ TFfi ("Basis", "file") => true | _ => false -fun p_sql_type' t = - case t of - Int => "uw_Basis_int" - | Float => "uw_Basis_float" - | String => "uw_Basis_string" - | Bool => "uw_Basis_bool" - | Time => "uw_Basis_time" - | Blob => "uw_Basis_blob" - | Channel => "uw_Basis_channel" - | Client => "uw_Basis_client" - | Nullable String => "uw_Basis_string" - | Nullable t => p_sql_type' t ^ "*" - -fun p_sql_type t = string (p_sql_type' t) +fun p_sql_type t = string (Settings.p_sql_ctype t) fun getPargs (e, _) = case e of @@ -1308,6 +1295,7 @@ TFfi ("Basis", "int") => Int | TFfi ("Basis", "float") => Float | TFfi ("Basis", "string") => String + | TFfi ("Basis", "char") => Char | TFfi ("Basis", "bool") => Bool | TFfi ("Basis", "time") => Time | TFfi ("Basis", "blob") => Blob
--- a/src/mono_opt.sml Thu Oct 22 14:05:48 2009 -0400 +++ b/src/mono_opt.sml Thu Oct 22 16:15:56 2009 -0400 @@ -45,12 +45,16 @@ else Real.toString n -val attrifyString = String.translate (fn #"\"" => """ - | #"&" => "&" - | ch => if Char.isPrint ch then - str ch - else - "&#" ^ Int.toString (ord ch) ^ ";") +fun attrifyChar ch = + case ch of + #"\"" => """ + | #"&" => "&" + | ch => if Char.isPrint ch then + str ch + else + "&#" ^ Int.toString (ord ch) ^ ";" + +val attrifyString = String.translate attrifyChar val urlifyInt = attrifyInt val urlifyFloat = attrifyFloat @@ -95,6 +99,7 @@ fun sqlifyFloat n = #p_cast (Settings.currentDbms ()) (attrifyFloat n, Settings.Float) fun sqlifyString s = #sqlifyString (Settings.currentDbms ()) s +fun sqlifyChar ch = #sqlifyString (Settings.currentDbms ()) (str ch) fun unAs s = let @@ -260,6 +265,13 @@ | EWrite (EFfiApp ("Basis", "attrifyString", [e]), _) => EFfiApp ("Basis", "attrifyString_w", [e]) + | EFfiApp ("Basis", "attrifyChar", [(EPrim (Prim.Char s), _)]) => + EPrim (Prim.String (attrifyChar s)) + | EWrite (EFfiApp ("Basis", "attrifyChar", [(EPrim (Prim.Char s), _)]), loc) => + EWrite (EPrim (Prim.String (attrifyChar s)), loc) + | EWrite (EFfiApp ("Basis", "attrifyChar", [e]), _) => + EFfiApp ("Basis", "attrifyChar_w", [e]) + | EFfiApp ("Basis", "attrifyCss_class", [(EPrim (Prim.String s), _)]) => EPrim (Prim.String s) | EWrite (EFfiApp ("Basis", "attrifyCss_class", [(EPrim (Prim.String s), _)]), loc) => @@ -318,6 +330,8 @@ result = (TFfi ("Basis", "string"), loc)}), loc) | EFfiApp ("Basis", "sqlifyString", [(EPrim (Prim.String n), _)]) => EPrim (Prim.String (sqlifyString n)) + | EFfiApp ("Basis", "sqlifyChar", [(EPrim (Prim.Char n), _)]) => + EPrim (Prim.String (sqlifyChar n)) | EWrite (ECase (discE, pes, {disc, ...}), loc) => optExp (ECase (discE,
--- a/src/monoize.sml Thu Oct 22 14:05:48 2009 -0400 +++ b/src/monoize.sml Thu Oct 22 16:15:56 2009 -0400 @@ -1921,6 +1921,10 @@ ((L'.EAbs ("x", (L'.TFfi ("Basis", "string"), loc), (L'.TFfi ("Basis", "string"), loc), (L'.EFfiApp ("Basis", "sqlifyString", [(L'.ERel 0, loc)]), loc)), loc), fm) + | L.EFfi ("Basis", "sql_char") => + ((L'.EAbs ("x", (L'.TFfi ("Basis", "char"), loc), (L'.TFfi ("Basis", "string"), loc), + (L'.EFfiApp ("Basis", "sqlifyChar", [(L'.ERel 0, loc)]), loc)), loc), + fm) | L.EFfi ("Basis", "sql_time") => ((L'.EAbs ("x", (L'.TFfi ("Basis", "time"), loc), (L'.TFfi ("Basis", "string"), loc), (L'.EFfiApp ("Basis", "sqlifyTime", [(L'.ERel 0, loc)]), loc)), loc),
--- a/src/mysql.sml Thu Oct 22 14:05:48 2009 -0400 +++ b/src/mysql.sml Thu Oct 22 16:15:56 2009 -0400 @@ -36,6 +36,7 @@ Int => "bigint" | Float => "double" | String => "longtext" + | Char => "char" | Bool => "bool" | Time => "timestamp" | Blob => "longblob" @@ -48,6 +49,7 @@ Int => "MYSQL_TYPE_LONGLONG" | Float => "MYSQL_TYPE_DOUBLE" | String => "MYSQL_TYPE_STRING" + | Char => "MYSQL_TYPE_TINY" | Bool => "MYSQL_TYPE_LONG" | Time => "MYSQL_TYPE_TIMESTAMP" | Blob => "MYSQL_TYPE_BLOB" @@ -60,6 +62,7 @@ Int => "bigint" | Float => "double" | String => "longtext" + | Char => "char" | Bool => "tinyint" | Time => "timestamp" | Blob => "longblob" @@ -386,6 +389,8 @@ newline, string "uw_sqlsuffixString = \"\";", newline, + string "uw_sqlsuffixChar = \"\";", + newline, string "uw_sqlsuffixBlob = \"\";", newline, string "uw_sqlfmtUint4 = \"%u%n\";",
--- a/src/postgres.sml Thu Oct 22 14:05:48 2009 -0400 +++ b/src/postgres.sml Thu Oct 22 16:15:56 2009 -0400 @@ -39,6 +39,7 @@ Int => "int8" | Float => "float8" | String => "text" + | Char => "char" | Bool => "bool" | Time => "timestamp" | Blob => "bytea" @@ -51,6 +52,7 @@ Int => "bigint" | Float => "double precision" | String => "text" + | Char => "character" | Bool => "boolean" | Time => "timestamp without time zone" | Blob => "bytea" @@ -257,6 +259,8 @@ newline, string "uw_sqlsuffixString = \"::text\";", newline, + string "uw_sqlsuffixChar = \"::char\";", + newline, string "uw_sqlsuffixBlob = \"::bytea\";", newline, string "uw_sqlfmtUint4 = \"%u::int4%n\";", @@ -505,6 +509,7 @@ e else box [string "uw_strdup(ctx, ", e, string ")"] + | Char => box [e, string "[0]"] | Bool => box [string "uw_Basis_stringToBool_error(ctx, ", e, string ")"] | Time => box [string "uw_Basis_unsqlTime(ctx, ", e, string ")"] | Blob => box [string "uw_Basis_stringToBlob_error(ctx, ", @@ -643,6 +648,7 @@ Int => box [string "uw_Basis_attrifyInt(ctx, ", e, string ")"] | Float => box [string "uw_Basis_attrifyFloat(ctx, ", e, string ")"] | String => e + | Char => box [string "uw_Basis_attrifyChar(ctx, ", e, string ")"] | Bool => box [string "(", e, string " ? \"TRUE\" : \"FALSE\")"] | Time => box [string "uw_Basis_attrifyTime(ctx, ", e, string ")"] | Blob => box [e, string ".data"]
--- a/src/settings.sig Thu Oct 22 14:05:48 2009 -0400 +++ b/src/settings.sig Thu Oct 22 16:15:56 2009 -0400 @@ -105,6 +105,7 @@ Int | Float | String + | Char | Bool | Time | Blob
--- a/src/settings.sml Thu Oct 22 14:05:48 2009 -0400 +++ b/src/settings.sml Thu Oct 22 16:15:56 2009 -0400 @@ -282,6 +282,7 @@ Int | Float | String + | Char | Bool | Time | Blob @@ -298,6 +299,7 @@ Int => "uw_Basis_int" | Float => "uw_Basis_float" | String => "uw_Basis_string" + | Char => "uw_Basis_char" | Bool => "uw_Basis_bool" | Time => "uw_Basis_time" | Blob => "uw_Basis_blob"
--- a/src/sqlite.sml Thu Oct 22 14:05:48 2009 -0400 +++ b/src/sqlite.sml Thu Oct 22 16:15:56 2009 -0400 @@ -36,6 +36,7 @@ Int => "integer" | Float => "real" | String => "text" + | Char => "integer" | Bool => "integer" | Time => "text" | Blob => "blob" @@ -165,6 +166,8 @@ newline, string "uw_sqlsuffixString = \"\";", newline, + string "uw_sqlsuffixChar = \"\";", + newline, string "uw_sqlsuffixBlob = \"\";", newline, string "uw_sqlfmtUint4 = \"%u%n\";", @@ -370,6 +373,7 @@ box [string "sqlite3_column_text(stmt, ", string (Int.toString i), string ")"] else box [string "uw_strdup(ctx, sqlite3_column_text(stmt, ", string (Int.toString i), string "))"] + | Char => box [string "sqlite3_column_int(stmt, ", string (Int.toString i), string ")"] | Bool => box [string "(uw_Basis_bool)sqlite3_column_int(stmt, ", string (Int.toString i), string ")"] | Time => box [string "uw_Basis_stringToTime_error(ctx, sqlite3_column_text(stmt, ", string (Int.toString i), string "))"] | Blob => box [string "({", @@ -523,6 +527,11 @@ string ", ", arg, string ", -1, SQLITE_TRANSIENT)"] + | Char => box [string "sqlite3_bind_int(stmt, ", + string (Int.toString (i + 1)), + string ", ", + arg, + string ")"] | Bool => box [string "sqlite3_bind_int(stmt, ", string (Int.toString (i + 1)), string ", ",