changeset 1023:e46227efcbba

Bidding interface
author Adam Chlipala <adamc@hcoop.net>
date Sun, 01 Nov 2009 10:20:20 -0500
parents 4de35df3d545
children 93415bcf54c0
files demo/more/bid.ur demo/more/bid.urs demo/more/conference.ur demo/more/conference.urp demo/more/conference.urs demo/more/conference1.ur demo/more/select.ur demo/more/select.urs include/urweb.h lib/ur/basis.urs lib/ur/string.ur lib/ur/string.urs src/c/urweb.c src/cjr_print.sml src/corify.sml
diffstat 15 files changed, 137 insertions(+), 38 deletions(-) [+]
line wrap: on
line diff
--- a/demo/more/bid.ur	Sat Oct 31 15:51:50 2009 -0400
+++ b/demo/more/bid.ur	Sun Nov 01 10:20:20 2009 -0500
@@ -7,22 +7,51 @@
     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
 
--- a/demo/more/bid.urs	Sat Oct 31 15:51:50 2009 -0400
+++ b/demo/more/bid.urs	Sun Nov 01 10:20:20 2009 -0500
@@ -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
--- a/demo/more/conference.ur	Sat Oct 31 15:51:50 2009 -0400
+++ b/demo/more/conference.ur	Sun Nov 01 10:20:20 2009 -0500
@@ -1,5 +1,5 @@
 signature INPUT = sig
-    con paper :: {(Type * Type)}
+    con paper :: {Type}
     constraint [Id, Document] ~ paper
 
     type userId
@@ -10,14 +10,19 @@
 
     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 @@
                  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 @@
             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 @@
                {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
--- a/demo/more/conference.urp	Sat Oct 31 15:51:50 2009 -0400
+++ b/demo/more/conference.urp	Sun Nov 01 10:20:20 2009 -0500
@@ -8,4 +8,5 @@
 dnat
 conference
 conferenceFields
+select
 bid
--- a/demo/more/conference.urs	Sat Oct 31 15:51:50 2009 -0400
+++ b/demo/more/conference.urs	Sun Nov 01 10:20:20 2009 -0500
@@ -1,5 +1,5 @@
 signature INPUT = sig
-    con paper :: {(Type * Type)}
+    con paper :: {Type}
     constraint [Id, Document] ~ paper
 
     type userId
@@ -10,14 +10,19 @@
 
     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 @@
                  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
 
--- a/demo/more/conference1.ur	Sat Oct 31 15:51:50 2009 -0400
+++ b/demo/more/conference1.ur	Sun Nov 01 10:20:20 2009 -0500
@@ -7,9 +7,9 @@
 
                          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)
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/demo/more/select.ur	Sun Nov 01 10:20:20 2009 -0500
@@ -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
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/demo/more/select.urs	Sun Nov 01 10:20:20 2009 -0500
@@ -0,0 +1,1 @@
+val selectChar : list (char * string) -> option char -> xml select [] []
--- a/include/urweb.h	Sat Oct 31 15:51:50 2009 -0400
+++ b/include/urweb.h	Sun Nov 01 10:20:20 2009 -0500
@@ -115,6 +115,7 @@
 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_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 *);
--- a/lib/ur/basis.urs	Sat Oct 31 15:51:50 2009 -0400
+++ b/lib/ur/basis.urs	Sun Nov 01 10:20:20 2009 -0500
@@ -62,6 +62,7 @@
 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
--- a/lib/ur/string.ur	Sat Oct 31 15:51:50 2009 -0400
+++ b/lib/ur/string.ur	Sun Nov 01 10:20:20 2009 -0500
@@ -1,5 +1,7 @@
 type t = Basis.string
 
+val str = Basis.str1
+
 val length = Basis.strlen
 val append = Basis.strcat
 
--- a/lib/ur/string.urs	Sat Oct 31 15:51:50 2009 -0400
+++ b/lib/ur/string.urs	Sun Nov 01 10:20:20 2009 -0500
@@ -1,5 +1,7 @@
 type t = string
 
+val str : char -> t
+
 val length : t -> int
 
 val append : t -> t -> t
--- a/src/c/urweb.c	Sat Oct 31 15:51:50 2009 -0400
+++ b/src/c/urweb.c	Sun Nov 01 10:20:20 2009 -0500
@@ -1668,14 +1668,16 @@
   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_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_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;
--- a/src/cjr_print.sml	Sat Oct 31 15:51:50 2009 -0400
+++ b/src/cjr_print.sml	Sun Nov 01 10:20:20 2009 -0500
@@ -561,11 +561,15 @@
     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 @@
         let
             fun getIt () =
                 if isUnboxable t then
-                    unurlify env t
+                    unurlify false env t
                 else
                     box [string "({",
                          newline,
@@ -1845,7 +1849,7 @@
                          string "));",
                          newline,
                          string "*tmp = ",
-                         unurlify env t,
+                         unurlify false env t,
                          string ";",
                          newline,
                          string "tmp;",
@@ -2441,7 +2445,7 @@
                               space,
                               string "=",
                               space,
-                              unurlify env t,
+                              unurlify true env t,
                               string ";",
                               newline]
             end
@@ -2599,7 +2603,7 @@
                                                                 space,
                                                                 string "=",
                                                                 space,
-                                                                unurlify env t,
+                                                                unurlify false env t,
                                                                 string ";",
                                                                 newline]) ts),
                           defInputs,
--- a/src/corify.sml	Sat Oct 31 15:51:50 2009 -0400
+++ b/src/corify.sml	Sun Nov 01 10:20:20 2009 -0500
@@ -43,8 +43,10 @@
                     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 #"/" => #"_"