summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2009-11-01 10:20:20 -0500
committerGravatar Adam Chlipala <adamc@hcoop.net>2009-11-01 10:20:20 -0500
commite20e964083a048ad4cbb88cc1af3790694f51dfa (patch)
tree09a704610f44afd4ad023245a9f59d901c3c4345
parent1be7e54fa70a40b16164f69e7153ada0e4935994 (diff)
Bidding interface
Diffstat
-rw-r--r--demo/more/bid.ur53
-rw-r--r--demo/more/bid.urs3
-rw-r--r--demo/more/conference.ur26
-rw-r--r--demo/more/conference.urp1
-rw-r--r--demo/more/conference.urs16
-rw-r--r--demo/more/conference1.ur4
-rw-r--r--demo/more/select.ur3
-rw-r--r--demo/more/select.urs1
-rw-r--r--include/urweb.h2
-rw-r--r--lib/ur/basis.urs1
-rw-r--r--lib/ur/string.ur2
-rw-r--r--lib/ur/string.urs2
-rw-r--r--src/c/urweb.c41
-rw-r--r--src/cjr_print.sml16
-rw-r--r--src/corify.sml4
15 files changed, 137 insertions, 38 deletions
diff --git a/demo/more/bid.ur b/demo/more/bid.ur
index 5bcaea3a..692f8e14 100644
--- a/demo/more/bid.ur
+++ b/demo/more/bid.ur
@@ -7,22 +7,51 @@ functor Make(M : Conference.INPUT) = struct
table assignment : {User : userId, Paper : paperId}
PRIMARY KEY (User, Paper)
- fun isOnPc id =
- ro <- oneOrNoRows1 (SELECT user.OnPc
- FROM user
- WHERE user.Id = {[id]});
- return (case ro of
- None => False
- | Some r => r.OnPc)
-
val linksForPc =
let
- fun bid () =
- me <- getLogin;
- return <xml>Bidding time!</xml>
+ fun yourBids () =
+ me <- getPcLogin;
+ ps <- queryX (SELECT paper.Id, paper.{{M.paper}}, bid.Interest
+ FROM paper LEFT JOIN bid ON bid.Paper = paper.Id
+ AND bid.User = {[me.Id]})
+ (fn r => <xml><entry>
+ <hidden{#Paper} value={show r.Paper.Id}/>
+ {useMore <xml><tr>
+ <td>{summarizePaper (r.Paper -- #Id)}</td>
+ <td><select{#Bid}>
+ {Select.selectChar ((#"-", "No") :: (#"_", "Maybe") :: (#"+", "Yes") :: [])
+ r.Bid.Interest}
+ </select></td>
+ </tr></xml>}
+ </entry></xml>);
+ return <xml><body>
+ <h1>Bid on papers</h1>
+
+ <form>
+ <subforms{#Papers}><table>
+ <tr> <th>Paper</th> <th>Your Bid</th> </tr>
+ {ps}
+ </table></subforms>
+ <submit value="Change" action={changeBids}/>
+ </form>
+ </body></xml>
+
+ and changeBids r =
+ me <- getPcLogin;
+ List.app (fn {Paper = p, Bid = b} =>
+ case b of
+ "" => return ()
+ | _ => let
+ val p = readError p
+ in
+ (dml (DELETE FROM bid WHERE Paper = {[p]} AND User = {[me.Id]});
+ dml (INSERT INTO bid (Paper, User, Interest)
+ VALUES ({[p]}, {[me.Id]}, {[String.sub b 0]})))
+ end) r.Papers;
+ yourBids ()
in
<xml>
- <li> <a link={bid ()}>Bid on papers</a></li>
+ <li> <a link={yourBids ()}>Bid on papers</a></li>
</xml>
end
diff --git a/demo/more/bid.urs b/demo/more/bid.urs
index 976d1ab6..f731f9ba 100644
--- a/demo/more/bid.urs
+++ b/demo/more/bid.urs
@@ -1,2 +1,3 @@
-functor Make (M : Conference.INPUT) : Conference.OUTPUT where con userId = M.userId
+functor Make (M : Conference.INPUT) : Conference.OUTPUT where con paper = M.paper
+ where con userId = M.userId
where con paperId = M.paperId
diff --git a/demo/more/conference.ur b/demo/more/conference.ur
index a80f1ab1..e810043b 100644
--- a/demo/more/conference.ur
+++ b/demo/more/conference.ur
@@ -1,5 +1,5 @@
signature INPUT = sig
- con paper :: {(Type * Type)}
+ con paper :: {Type}
constraint [Id, Document] ~ paper
type userId
@@ -10,14 +10,19 @@ signature INPUT = sig
type paperId
val paperId_inj : sql_injectable_prim paperId
- table paper : ([Id = paperId, Document = blob] ++ map fst paper)
+ val paperId_show : show paperId
+ val paperId_read : read paperId
+ table paper : ([Id = paperId, Document = blob] ++ paper)
PRIMARY KEY Id
val checkLogin : transaction (option {Id : userId, Nam : string, Chair : bool, OnPc : bool})
val getLogin : transaction {Id : userId, Nam : string, Chair : bool, OnPc : bool}
+ val getPcLogin : transaction {Id : userId, Nam : string, Chair : bool}
+ val summarizePaper : ctx ::: {Unit} -> [[Body] ~ ctx] => $paper -> xml ([Body] ++ ctx) [] []
end
signature OUTPUT = sig
+ con paper :: {Type}
type userId
type paperId
@@ -45,10 +50,11 @@ functor Make(M : sig
val reviewFolder : folder review
val submissionDeadline : time
- val summarizePaper : $(map fst paper) -> xbody
+ val summarizePaper : ctx ::: {Unit} -> [[Body] ~ ctx] => $(map fst paper) -> xml ([Body] ++ ctx) [] []
- functor Make (M : INPUT where con paper = paper)
- : OUTPUT where con userId = M.userId
+ functor Make (M : INPUT where con paper = map fst paper)
+ : OUTPUT where con paper = map fst paper
+ where con userId = M.userId
where con paperId = M.paperId
end) = struct
@@ -92,11 +98,20 @@ functor Make(M : sig
None => error <xml>You must be logged in to do that.</xml>
| Some r => return r
+ val getPcLogin =
+ r <- getLogin;
+ if r.OnPc then
+ return (r -- #OnPc)
+ else
+ error <xml>You are not on the PC.</xml>
+
structure O = M.Make(struct
val user = user
val paper = paper
val checkLogin = checkLogin
val getLogin = getLogin
+ val getPcLogin = getPcLogin
+ val summarizePaper = @@M.summarizePaper
end)
val checkOnPc =
@@ -195,6 +210,7 @@ functor Make(M : sig
{if me.OnPc then
<xml>
<li><a link={all ()}>All papers</a></li>
+ <li><a link={your ()}>Your papers</a></li>
{O.linksForPc}
</xml>
else
diff --git a/demo/more/conference.urp b/demo/more/conference.urp
index 3bc9156c..844baed9 100644
--- a/demo/more/conference.urp
+++ b/demo/more/conference.urp
@@ -8,4 +8,5 @@ bulkEdit
dnat
conference
conferenceFields
+select
bid
diff --git a/demo/more/conference.urs b/demo/more/conference.urs
index 226e9768..f9729851 100644
--- a/demo/more/conference.urs
+++ b/demo/more/conference.urs
@@ -1,5 +1,5 @@
signature INPUT = sig
- con paper :: {(Type * Type)}
+ con paper :: {Type}
constraint [Id, Document] ~ paper
type userId
@@ -10,14 +10,19 @@ signature INPUT = sig
type paperId
val paperId_inj : sql_injectable_prim paperId
- table paper : ([Id = paperId, Document = blob] ++ map fst paper)
+ val paperId_show : show paperId
+ val paperId_read : read paperId
+ table paper : ([Id = paperId, Document = blob] ++ paper)
PRIMARY KEY Id
val checkLogin : transaction (option {Id : userId, Nam : string, Chair : bool, OnPc : bool})
val getLogin : transaction {Id : userId, Nam : string, Chair : bool, OnPc : bool}
+ val getPcLogin : transaction {Id : userId, Nam : string, Chair : bool}
+ val summarizePaper : ctx ::: {Unit} -> [[Body] ~ ctx] => $paper -> xml ([Body] ++ ctx) [] []
end
signature OUTPUT = sig
+ con paper :: {Type}
type userId
type paperId
@@ -43,10 +48,11 @@ functor Make(M : sig
val reviewFolder : folder review
val submissionDeadline : time
- val summarizePaper : $(map fst paper) -> xbody
+ val summarizePaper : ctx ::: {Unit} -> [[Body] ~ ctx] => $(map fst paper) -> xml ([Body] ++ ctx) [] []
- functor Make (M : INPUT where con paper = paper)
- : OUTPUT where con userId = M.userId
+ functor Make (M : INPUT where con paper = map fst paper)
+ : OUTPUT where con paper = map fst paper
+ where con userId = M.userId
where con paperId = M.paperId
end) : sig
diff --git a/demo/more/conference1.ur b/demo/more/conference1.ur
index c51904e5..f8272b4f 100644
--- a/demo/more/conference1.ur
+++ b/demo/more/conference1.ur
@@ -7,9 +7,9 @@ open Conference.Make(struct
val submissionDeadline = readError "2009-11-22 23:59:59"
- fun summarizePaper r = cdata r.Title
+ fun summarizePaper [ctx] [[Body] ~ ctx] r = cdata r.Title
- functor Make (M : Conference.INPUT where con paper = _) = struct
+ functor Make (M : Conference.INPUT where con paper = [Title = string, Abstract = string]) = struct
open Bid.Make(M)
end
end)
diff --git a/demo/more/select.ur b/demo/more/select.ur
new file mode 100644
index 00000000..17cff4dd
--- /dev/null
+++ b/demo/more/select.ur
@@ -0,0 +1,3 @@
+fun selectChar choices current =
+ List.mapX (fn (ch, label) =>
+ <xml><option value={String.str ch} selected={current = Some ch}>{[label]}</option></xml>) choices
diff --git a/demo/more/select.urs b/demo/more/select.urs
new file mode 100644
index 00000000..f9208b91
--- /dev/null
+++ b/demo/more/select.urs
@@ -0,0 +1 @@
+val selectChar : list (char * string) -> option char -> xml select [] []
diff --git a/include/urweb.h b/include/urweb.h
index 359ba037..ef5fc5a4 100644
--- a/include/urweb.h
+++ b/include/urweb.h
@@ -115,6 +115,7 @@ uw_unit uw_Basis_urlifyChannel_w(uw_context, uw_Basis_channel);
uw_Basis_int uw_Basis_unurlifyInt(uw_context, char **);
uw_Basis_float uw_Basis_unurlifyFloat(uw_context, char **);
uw_Basis_string uw_Basis_unurlifyString(uw_context, char **);
+uw_Basis_string uw_Basis_unurlifyString_fromClient(uw_context, char **);
uw_Basis_bool uw_Basis_unurlifyBool(uw_context, char **);
uw_Basis_time uw_Basis_unurlifyTime(uw_context, char **);
@@ -127,6 +128,7 @@ uw_Basis_int *uw_Basis_strindex(uw_context, const char *, uw_Basis_char);
uw_Basis_string uw_Basis_strchr(uw_context, const char *, uw_Basis_char);
uw_Basis_int uw_Basis_strcspn(uw_context, const char *, const char *);
uw_Basis_string uw_Basis_substring(uw_context, const char *, uw_Basis_int, uw_Basis_int);
+uw_Basis_string uw_Basis_str1(uw_context, uw_Basis_char);
uw_Basis_string uw_strdup(uw_context, const char *);
uw_Basis_string uw_maybe_strdup(uw_context, const char *);
diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index 0f70fa14..d1ecf1ca 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -62,6 +62,7 @@ val strchr : string -> char -> option string
val strindex : string -> char -> option int
val strcspn : string -> string -> option int
val substring : string -> int -> int -> string
+val str1 : char -> string
class show
val show : t ::: Type -> show t -> t -> string
diff --git a/lib/ur/string.ur b/lib/ur/string.ur
index e31bbc27..fb5a3f97 100644
--- a/lib/ur/string.ur
+++ b/lib/ur/string.ur
@@ -1,5 +1,7 @@
type t = Basis.string
+val str = Basis.str1
+
val length = Basis.strlen
val append = Basis.strcat
diff --git a/lib/ur/string.urs b/lib/ur/string.urs
index 8fd434b4..1b584c08 100644
--- a/lib/ur/string.urs
+++ b/lib/ur/string.urs
@@ -1,5 +1,7 @@
type t = string
+val str : char -> t
+
val length : t -> int
val append : t -> t -> t
diff --git a/src/c/urweb.c b/src/c/urweb.c
index 7dd6d222..3cf8fd47 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -1668,14 +1668,16 @@ uw_Basis_time uw_Basis_unurlifyTime(uw_context ctx, char **s) {
return uw_Basis_unurlifyInt(ctx, s);
}
-static uw_Basis_string uw_unurlifyString_to(uw_context ctx, char *r, char *s) {
+static uw_Basis_string uw_unurlifyString_to(int fromClient, uw_context ctx, char *r, char *s) {
char *s1, *s2 = s;
int n;
- if (*s2 == '_')
- ++s2;
- else if (s2[0] == '%' && s2[1] == '5' && (s2[2] == 'f' || s2[2] == 'F'))
- s2 += 3;
+ if (!fromClient) {
+ if (*s2 == '_')
+ ++s2;
+ else if (s2[0] == '%' && s2[1] == '5' && (s2[2] == 'f' || s2[2] == 'F'))
+ s2 += 3;
+ }
for (s1 = r; *s2; ++s1, ++s2) {
char c = *s2;
@@ -1724,7 +1726,21 @@ uw_Basis_string uw_Basis_unurlifyString(uw_context ctx, char **s) {
uw_check_heap(ctx, len + 1);
r = ctx->heap.front;
- ctx->heap.front = uw_unurlifyString_to(ctx, ctx->heap.front, *s);
+ ctx->heap.front = uw_unurlifyString_to(0, ctx, ctx->heap.front, *s);
+ *s = new_s;
+ return r;
+}
+
+uw_Basis_string uw_Basis_unurlifyString_fromClient(uw_context ctx, char **s) {
+ char *new_s = uw_unurlify_advance(*s);
+ char *r, *s1, *s2;
+ int len, n;
+
+ len = strlen(*s);
+ uw_check_heap(ctx, len + 1);
+
+ r = ctx->heap.front;
+ ctx->heap.front = uw_unurlifyString_to(1, ctx, ctx->heap.front, *s);
*s = new_s;
return r;
}
@@ -1963,6 +1979,19 @@ uw_Basis_string uw_Basis_substring(uw_context ctx, uw_Basis_string s, uw_Basis_i
}
+uw_Basis_string uw_Basis_str1(uw_context ctx, uw_Basis_char ch) {
+ char *r;
+
+ uw_check_heap(ctx, 2);
+ r = ctx->heap.front;
+ r[0] = ch;
+ r[1] = 0;
+
+ ctx->heap.front += 2;
+
+ return r;
+}
+
uw_Basis_string uw_strdup(uw_context ctx, uw_Basis_string s1) {
int len = uw_Basis_strlen(ctx, s1) + 1;
char *s;
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index d63c9099..164035eb 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -561,11 +561,15 @@ fun capitalize s =
else
str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
-fun unurlify env (t, loc) =
+fun unurlify fromClient env (t, loc) =
let
fun unurlify' rf t =
case t of
- TFfi ("Basis", "unit") => string ("uw_unit_v")
+ TFfi ("Basis", "unit") => string "uw_unit_v"
+ | TFfi ("Basis", "string") => string (if fromClient then
+ "uw_Basis_unurlifyString_fromClient(ctx, &request)"
+ else
+ "uw_Basis_unurlifyString(ctx, &request)")
| TFfi (m, t) => string ("uw_" ^ ident m ^ "_unurlify" ^ capitalize t ^ "(ctx, &request)")
| TRecord 0 => string "uw_unit_v"
@@ -1835,7 +1839,7 @@ fun p_exp' par env (e, loc) =
let
fun getIt () =
if isUnboxable t then
- unurlify env t
+ unurlify false env t
else
box [string "({",
newline,
@@ -1845,7 +1849,7 @@ fun p_exp' par env (e, loc) =
string "));",
newline,
string "*tmp = ",
- unurlify env t,
+ unurlify false env t,
string ";",
newline,
string "tmp;",
@@ -2441,7 +2445,7 @@ fun p_file env (ds, ps) =
space,
string "=",
space,
- unurlify env t,
+ unurlify true env t,
string ";",
newline]
end
@@ -2599,7 +2603,7 @@ fun p_file env (ds, ps) =
space,
string "=",
space,
- unurlify env t,
+ unurlify false env t,
string ";",
newline]) ts),
defInputs,
diff --git a/src/corify.sml b/src/corify.sml
index a4979790..9bf322f3 100644
--- a/src/corify.sml
+++ b/src/corify.sml
@@ -43,8 +43,10 @@ fun doRestify k (mods, s) =
String.extract (s, 5, NONE)
else
s
+ val s = String.concatWith "/" (rev (s :: mods))
+ val s = String.implode (List.filter (fn ch => ch <> #"$") (String.explode s))
in
- Settings.rewrite k (String.concatWith "/" (rev (s :: mods)))
+ Settings.rewrite k s
end
val relify = CharVector.map (fn #"/" => #"_"
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-11 04:56:10 +0000