summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2009-10-20 11:05:58 -0400
committerGravatar Adam Chlipala <adamc@hcoop.net>2009-10-20 11:05:58 -0400
commite23f4d764bc93640cb08a7d6ebd7e261fac2cb05 (patch)
treed11bc3451bff30a58f66c2d1dbb41852526a308f
parent66fa98fe9619afa56b10f1357edb617dc813051c (diff)
Registering for Conference1
Diffstat
-rw-r--r--demo/more/conference.ur87
-rw-r--r--demo/more/conference.urp1
-rw-r--r--demo/more/conference.urs17
-rw-r--r--demo/more/conference1.ur4
-rw-r--r--demo/more/conference1.urp5
-rw-r--r--lib/ur/top.ur13
-rw-r--r--lib/ur/top.urs11
7 files changed, 120 insertions, 18 deletions
diff --git a/demo/more/conference.ur b/demo/more/conference.ur
index a028bc41..569059c1 100644
--- a/demo/more/conference.ur
+++ b/demo/more/conference.ur
@@ -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}
-
-fun default [t] (sh : show t) (rd : read t) (inj : sql_injectable t) : reviewMeta (t, string) =
+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) : meta (t, string) =
{Show = txt,
Widget = fn [nm :: Name] => <xml><textbox{nm}/></xml>,
WidgetPopulated = fn [nm :: Name] n =>
@@ -24,10 +24,77 @@ val bool = {Show = txt,
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
diff --git a/demo/more/conference.urp b/demo/more/conference.urp
index 399721d4..51a63cb0 100644
--- a/demo/more/conference.urp
+++ b/demo/more/conference.urp
@@ -1,2 +1,3 @@
+$/option
conference
diff --git a/demo/more/conference.urs b/demo/more/conference.urs
index 696b8b32..aecdf143 100644
--- a/demo/more/conference.urs
+++ b/demo/more/conference.urs
@@ -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
diff --git a/demo/more/conference1.ur b/demo/more/conference1.ur
new file mode 100644
index 00000000..8d263a3c
--- /dev/null
+++ b/demo/more/conference1.ur
@@ -0,0 +1,4 @@
+open Conference.Make(struct
+ val paper = {}
+ val review = {}
+ end)
diff --git a/demo/more/conference1.urp b/demo/more/conference1.urp
new file mode 100644
index 00000000..c78219c4
--- /dev/null
+++ b/demo/more/conference1.urp
@@ -0,0 +1,5 @@
+library conference
+database dbname=conf1
+sql conf1.sql
+
+conference1
diff --git a/lib/ur/top.ur b/lib/ur/top.ur
index a2395d4f..6ffc888f 100644
--- a/lib/ur/top.ur
+++ b/lib/ur/top.ur
@@ -236,11 +236,16 @@ fun queryX' [tables ::: {{Type}}] [exps ::: {Type}] [ctx ::: {Unit}]
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 @@ fun oneRow [tables ::: {{Type}}] [exps ::: {Type}]
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))
diff --git a/lib/ur/top.urs b/lib/ur/top.urs
index ef907760..82090dd2 100644
--- a/lib/ur/top.urs
+++ b/lib/ur/top.urs
@@ -147,13 +147,22 @@ val oneOrNoRows : tables ::: {{Type}} -> exps ::: {Type}
$(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)
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-01 12:45:57 +0000