Mercurial > urweb

changeset 1006:5a0f6ec208ce

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Checking deadline; sign-in
author Adam Chlipala <adamc@hcoop.net>
date Thu, 22 Oct 2009 11:15:37 -0400
parents c6e948ec79e9
children d3af9e54c828
files demo/more/conference.ur demo/more/conference.urs demo/more/conference1.ur include/urweb.h lib/ur/basis.urs lib/ur/top.ur lib/ur/top.urs src/c/urweb.c
diffstat 8 files changed, 65 insertions(+), 4 deletions(-) [+]
line wrap: on
line diff
--- a/demo/more/conference.ur	Tue Oct 20 13:08:42 2009 -0400
+++ b/demo/more/conference.ur	Thu Oct 22 11:15:37 2009 -0400
@@ -8,6 +8,8 @@
                  con review :: {(Type * Type)}
                  constraint [Paper, User] ~ review
                  val review : $(map meta review)
+
+                 val submissionDeadline : time
              end) = struct
 
     table user : {Id : int, Nam : string, Password : string, Chair : bool, OnPc : bool}
@@ -81,11 +83,36 @@
       </table></form>
     </body></xml>
 
-    and main () =
+    and signin r =
+        ro <- oneOrNoRowsE1 (SELECT user.Id AS N
+                             FROM user
+                             WHERE user.Nam = {[r.Nam]}
+                               AND user.Password = {[r.Password]});
+        (case ro of
+             None => return ()
+           | Some id => setCookie login {Id = id, Password = r.Password});
+        m <- main' ();
+        return <xml><body>
+          {case ro of
+               None => <xml><div>Invalid username or password.</div></xml>
+             | _ => <xml/>}
+
+          {m}
+        </body></xml>
+
+    and main' () =
         me <- checkLogin;
-        return <xml><body>
+        now <- now;
+        return <xml><ul>
           {case me of
-               None => <xml><li><a link={register None}>Register for access</a></li></xml>
+               None => <xml>
+                 <li><a link={register None}>Register for access</a></li>
+                 <li><b>Log in:</b> <form><table>
+                   <tr> <th>Username:</th> <td><textbox{#Nam}/></td> </tr>
+                   <tr> <th>Password:</th> <td><password{#Password}/></td> </tr>
+                   <tr> <th><submit value="Log in" action={signin}/></th> </tr>
+                 </table></form></li>
+               </xml>
              | Some me => <xml>
                <div>Welcome, {[me.Nam]}!</div>
 
@@ -93,7 +120,16 @@
                     <xml><li><a link={Users.main ()}>Manage users</a></li></xml>
                 else
                     <xml/>}
+
+               {if now < M.submissionDeadline then
+                    <xml><li>Submit</li></xml>
+                else
+                    <xml/>}
              </xml>}
-        </body></xml>
+        </ul></xml>
+
+    and main () =
+        m <- main' ();
+        return <xml><body>{m}</body></xml>
 
 end
--- a/demo/more/conference.urs	Tue Oct 20 13:08:42 2009 -0400
+++ b/demo/more/conference.urs	Thu Oct 22 11:15:37 2009 -0400
@@ -6,6 +6,8 @@
                  con review :: {(Type * Type)}
                  constraint [Paper, User] ~ review
                  val review : $(map Meta.meta review)
+
+                 val submissionDeadline : time
              end) : sig
 
     val main : unit -> transaction page
--- a/demo/more/conference1.ur	Tue Oct 20 13:08:42 2009 -0400
+++ b/demo/more/conference1.ur	Thu Oct 22 11:15:37 2009 -0400
@@ -1,4 +1,6 @@
 open Conference.Make(struct
                          val paper = {}
                          val review = {}
+
+                         val submissionDeadline = readError "2009-10-22 23:59:59"
                      end)
--- a/include/urweb.h	Tue Oct 20 13:08:42 2009 -0400
+++ b/include/urweb.h	Thu Oct 22 11:15:37 2009 -0400
@@ -202,6 +202,8 @@
 
 __attribute__((noreturn)) void uw_return_blob(uw_context, uw_Basis_blob, uw_Basis_string mimeType);
 
+uw_Basis_time uw_Basis_now(uw_context);
+
 void uw_register_transactional(uw_context, void *data, uw_callback commit, uw_callback rollback, uw_callback free);
 
 void uw_check_heap(uw_context, size_t extra);
--- a/lib/ur/basis.urs	Tue Oct 20 13:08:42 2009 -0400
+++ b/lib/ur/basis.urs	Thu Oct 22 11:15:37 2009 -0400
@@ -111,6 +111,11 @@
 val current : t ::: Type -> signal t -> transaction t
 
 
+(** * Time *)
+
+val now : transaction time
+
+
 (** HTTP operations *)
 
 val requestHeader : string -> transaction (option string)
--- a/lib/ur/top.ur	Tue Oct 20 13:08:42 2009 -0400
+++ b/lib/ur/top.ur	Thu Oct 22 11:15:37 2009 -0400
@@ -246,6 +246,11 @@
           (fn fs _ => return (Some fs.nm))
           None
 
+fun oneOrNoRowsE1 [tab ::: Name] [nm ::: Name] [t ::: Type] [[tab] ~ [nm]] (q : sql_query [tab = []] [nm = t]) =
+    query q
+          (fn fs _ => return (Some fs.nm))
+          None
+
 fun oneRow [tables ::: {{Type}}] [exps ::: {Type}]
            [tables ~ exps] (q : sql_query tables exps) =
     o <- oneOrNoRows q;
--- a/lib/ur/top.urs	Tue Oct 20 13:08:42 2009 -0400
+++ b/lib/ur/top.urs	Thu Oct 22 11:15:37 2009 -0400
@@ -151,6 +151,11 @@
                    -> sql_query [nm = fs] []
                    -> transaction (option $fs)
 
+val oneOrNoRowsE1 : tab ::: Name -> nm ::: Name -> t ::: Type
+                    -> [[tab] ~ [nm]] =>
+    sql_query [tab = []] [nm = t]
+    -> transaction (option t)
+
 val oneRow : tables ::: {{Type}} -> exps ::: {Type}
              -> [tables ~ exps] =>
              sql_query tables exps
--- a/src/c/urweb.c	Tue Oct 20 13:08:42 2009 -0400
+++ b/src/c/urweb.c	Thu Oct 22 11:15:37 2009 -0400
@@ -2907,3 +2907,7 @@
 
   return r;
 }
+
+uw_Basis_time uw_Basis_now(uw_context ctx) {
+  return time(NULL);
+}