Mercurial > urweb

changeset 1003:61c30f0742d7

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Registering for Conference1
author Adam Chlipala <adamc@hcoop.net>
date Tue, 20 Oct 2009 11:05:58 -0400
parents bb3fc575cfe7
children a87495bcaeec
files demo/more/conference.ur demo/more/conference.urp demo/more/conference.urs demo/more/conference1.ur demo/more/conference1.urp lib/ur/top.ur lib/ur/top.urs
diffstat 7 files changed, 119 insertions(+), 17 deletions(-) [+]
line wrap: on
line diff
--- a/demo/more/conference.ur	Tue Oct 20 10:29:17 2009 -0400
+++ b/demo/more/conference.ur	Tue Oct 20 11:05:58 2009 -0400
@@ -1,11 +1,11 @@
-con reviewMeta = fn (db :: Type, widget :: Type) =>
-                    {Show : db -> xbody,
-                     Widget : nm :: Name -> xml form [] [nm = widget],
-                     WidgetPopulated : nm :: Name -> db -> xml form [] [nm = widget],
-                     Parse : widget -> db,
-                     Inject : sql_injectable db}
+con meta = fn (db :: Type, widget :: Type) =>
+              {Show : db -> xbody,
+               Widget : nm :: Name -> xml form [] [nm = widget],
+               WidgetPopulated : nm :: Name -> db -> xml form [] [nm = widget],
+               Parse : widget -> db,
+               Inject : sql_injectable db}
 
-fun default [t] (sh : show t) (rd : read t) (inj : sql_injectable t) : reviewMeta (t, string) =
+fun default [t] (sh : show t) (rd : read t) (inj : sql_injectable t) : meta (t, string) =
     {Show = txt,
      Widget = fn [nm :: Name] => <xml><textbox{nm}/></xml>,
      WidgetPopulated = fn [nm :: Name] n =>
@@ -24,10 +24,77 @@
             Inject = _}
 
 functor Make(M : sig
+                 con paper :: {(Type * Type)}
+                 constraint [Id, Title] ~ paper
+                 val paper : $(map meta paper)
+
                  con review :: {(Type * Type)}
-                 val review : $(map reviewMeta review)
+                 constraint [Paper, User] ~ review
+                 val review : $(map meta review)
              end) = struct
 
-    fun main () = return <xml/>
+    table user : {Id : int, Nam : string, Password : string, Chair : bool, OnPc : bool}
+          PRIMARY KEY Id,
+          CONSTRAINT Nam UNIQUE Nam
+    sequence userId
+
+    con paper = [Id = int, Title = string] ++ map fst M.paper
+    table paper : paper
+          PRIMARY KEY Id
+    sequence paperId
+
+    con review = [Paper = int, User = int] ++ map fst M.review
+    table review : review
+          PRIMARY KEY (Paper, User),
+          CONSTRAINT Paper FOREIGN KEY Paper REFERENCES paper(Id),
+          CONSTRAINT User FOREIGN KEY User REFERENCES user(Id)
+    sequence reviewId
+
+    cookie login : {Id : int, Password : string}
+
+    fun checkLogin () =
+        r <- getCookie login;
+        case r of
+            None => return None
+          | Some r =>
+            oneOrNoRows1 (SELECT user.Id, user.Nam, user.Chair, user.OnPc
+                          FROM user
+                          WHERE user.Id = {[r.Id]}
+                            AND user.Password = {[r.Password]})
+
+    fun doRegister r =
+        n <- oneRowE1 (SELECT COUNT( * ) AS N
+                       FROM user
+                       WHERE user.Nam = {[r.Nam]});
+        if n > 0 then
+            register (Some "Sorry; that username is taken.")
+        else
+            id <- nextval userId;
+            dml (INSERT INTO user (Id, Nam, Password, Chair, OnPc)
+                 VALUES ({[id]}, {[r.Nam]}, {[r.Password]}, FALSE, FALSE));
+            setCookie login {Id = id, Password = r.Password};
+            main ()
+
+    and register msg = return <xml><body>
+      <h1>Registering a New Account</h1>
+
+      {case msg of
+           None => <xml/>
+         | Some msg => <xml><div>{[msg]}</div></xml>}
+
+      <form><table>
+        <tr> <th>Username:</th> <td><textbox{#Nam}/></td> </tr>
+        <tr> <th>Password:</th> <td><password{#Password}/></td> </tr>
+        <tr> <th><submit action={doRegister}/></th> </tr>
+      </table></form>
+    </body></xml>
+
+    and main () =
+        me <- checkLogin ();
+        return <xml><body>
+          {case me of
+               None => <xml><li><a link={register None}>Register for access</a></li></xml>
+             | Some {Nam = name, ...} => <xml>Welcome, {[name]}!</xml>}
+        </body></xml>
 
 end
--- a/demo/more/conference.urp	Tue Oct 20 10:29:17 2009 -0400
+++ b/demo/more/conference.urp	Tue Oct 20 11:05:58 2009 -0400
@@ -1,2 +1,3 @@
 
+$/option
 conference
--- a/demo/more/conference.urs	Tue Oct 20 10:29:17 2009 -0400
+++ b/demo/more/conference.urs	Tue Oct 20 11:05:58 2009 -0400
@@ -1,18 +1,23 @@
-con reviewMeta = fn (db :: Type, widget :: Type) =>
+con meta = fn (db :: Type, widget :: Type) =>
                     {Show : db -> xbody,
                      Widget : nm :: Name -> xml form [] [nm = widget],
                      WidgetPopulated : nm :: Name -> db -> xml form [] [nm = widget],
                      Parse : widget -> db,
                      Inject : sql_injectable db}
 
-val int : reviewMeta (int, string)
-val float : reviewMeta (float, string)
-val string : reviewMeta (string, string)
-val bool : reviewMeta (bool, bool)
+val int : meta (int, string)
+val float : meta (float, string)
+val string : meta (string, string)
+val bool : meta (bool, bool)
 
 functor Make(M : sig
+                 con paper :: {(Type * Type)}
+                 constraint [Id, Title] ~ paper
+                 val paper : $(map meta paper)
+
                  con review :: {(Type * Type)}
-                 val review : $(map reviewMeta review)
+                 constraint [Paper, User] ~ review
+                 val review : $(map meta review)
              end) : sig
 
     val main : unit -> transaction page
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/demo/more/conference1.ur	Tue Oct 20 11:05:58 2009 -0400
@@ -0,0 +1,4 @@
+open Conference.Make(struct
+                         val paper = {}
+                         val review = {}
+                     end)
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/demo/more/conference1.urp	Tue Oct 20 11:05:58 2009 -0400
@@ -0,0 +1,5 @@
+library conference
+database dbname=conf1
+sql conf1.sql
+
+conference1
--- a/lib/ur/top.ur	Tue Oct 20 10:29:17 2009 -0400
+++ b/lib/ur/top.ur	Tue Oct 20 11:05:58 2009 -0400
@@ -236,11 +236,16 @@
 
 fun oneOrNoRows [tables ::: {{Type}}] [exps ::: {Type}]
                 [tables ~ exps]
-                (q : sql_query tables exps)  =
+                (q : sql_query tables exps) =
     query q
           (fn fs _ => return (Some fs))
           None
 
+fun oneOrNoRows1 [nm ::: Name] [fs ::: {Type}] (q : sql_query [nm = fs] []) =
+    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;
@@ -248,6 +253,12 @@
                 None => error <xml>Query returned no rows</xml>
               | Some r => r)
 
+fun oneRowE1 [tab ::: Name] [nm ::: Name] [t ::: Type] [[tab] ~ [nm]] (q : sql_query [tab = []] [nm = t]) =
+    o <- oneOrNoRows q;
+    return (case o of
+                None => error <xml>Query returned no rows</xml>
+              | Some r => r.nm)
+
 fun eqNullable [tables ::: {{Type}}] [agg ::: {{Type}}] [exps ::: {Type}]
     [t ::: Type] (_ : sql_injectable (option t))
     (e1 : sql_exp tables agg exps (option t))
--- a/lib/ur/top.urs	Tue Oct 20 10:29:17 2009 -0400
+++ b/lib/ur/top.urs	Tue Oct 20 11:05:58 2009 -0400
@@ -147,13 +147,22 @@
                               $(exps
                                     ++ map (fn fields :: {Type} => $fields) tables))
 
+val oneOrNoRows1 : nm ::: Name -> fs ::: {Type}
+                   -> sql_query [nm = fs] []
+                   -> transaction (option $fs)
+
 val oneRow : tables ::: {{Type}} -> exps ::: {Type}
              -> [tables ~ exps] =>
              sql_query tables exps
              -> transaction
                     $(exps
                           ++ map (fn fields :: {Type} => $fields) tables)
-                
+
+val oneRowE1 : tab ::: Name -> nm ::: Name -> t ::: Type
+               -> [[tab] ~ [nm]] =>
+    sql_query [tab = []] [nm = t]
+    -> transaction t
+
 val eqNullable : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
                  -> t ::: Type -> sql_injectable (option t)
                  -> sql_exp tables agg exps (option t)