summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2009-10-20 12:48:53 -0400
committerGravatar Adam Chlipala <adamc@hcoop.net>2009-10-20 12:48:53 -0400
commit8ba88fa1aacb63cff48fe42ba7d3dcfc31c45bbb (patch)
tree06207c87f54c242948fab98a5331a12d0557c85d
parente23f4d764bc93640cb08a7d6ebd7e261fac2cb05 (diff)
Start of user management
Diffstat
-rw-r--r--demo/more/bulkEdit.ur51
-rw-r--r--demo/more/bulkEdit.urs22
-rw-r--r--demo/more/conference.ur53
-rw-r--r--demo/more/conference.urp2
-rw-r--r--demo/more/conference.urs16
-rw-r--r--demo/more/meta.ur27
-rw-r--r--demo/more/meta.urs12
-rw-r--r--lib/ur/basis.urs14
-rw-r--r--lib/ur/top.ur4
-rw-r--r--lib/ur/top.urs6
10 files changed, 154 insertions, 53 deletions
diff --git a/demo/more/bulkEdit.ur b/demo/more/bulkEdit.ur
new file mode 100644
index 00000000..c033d2e8
--- /dev/null
+++ b/demo/more/bulkEdit.ur
@@ -0,0 +1,51 @@
+open Meta
+
+functor Make(M : sig
+ con keyName :: Name
+ con keyType :: Type
+ val showKey : show keyType
+
+ con visible :: {(Type * Type)}
+ constraint [keyName] ~ visible
+ val folder : folder visible
+ val visible : $(map Meta.meta visible)
+
+ con invisible :: {Type}
+ constraint [keyName] ~ invisible
+ constraint visible ~ invisible
+
+ val title : string
+ val isAllowed : transaction bool
+ table t : ([keyName = keyType] ++ map fst visible ++ invisible)
+ end) = struct
+
+ open M
+
+ fun main () =
+ items <- queryX (SELECT t.{keyName}, t.{{map fst visible}} FROM t)
+ (fn r => <xml><entry><tr>
+ <hidden{keyName} value={show r.T.keyName}/>
+ {useMore (foldR2 [meta] [fst] [fn cols :: {(Type * Type)} =>
+ xml [Body, Form, Tr] [] (map snd cols)]
+ (fn [nm :: Name] [p :: (Type * Type)] [rest :: {(Type * Type)}] [[nm] ~ rest]
+ (m : meta p) v (acc : xml [Body, Form, Tr] [] (map snd rest)) =>
+ <xml>
+ <td>{m.WidgetPopulated [nm] v}</td>
+ {useMore acc}
+ </xml>)
+ <xml/>
+ [_] folder visible (r.T -- keyName))}
+ </tr></entry></xml>);
+
+ return <xml><body>
+ <h1>{[title]}</h1>
+
+ <form><table>
+ <tr>{foldRX [meta] [_]
+ (fn [nm :: Name] [p :: (Type * Type)] [rest :: {(Type * Type)}] [[nm] ~ rest] m =>
+ <xml><th>{[m.Nam]}</th></xml>) [_] folder visible}</tr>
+ <subforms{#Users}>{items}</subforms>
+ </table></form>
+ </body></xml>
+
+end
diff --git a/demo/more/bulkEdit.urs b/demo/more/bulkEdit.urs
new file mode 100644
index 00000000..6593af1b
--- /dev/null
+++ b/demo/more/bulkEdit.urs
@@ -0,0 +1,22 @@
+functor Make(M : sig
+ con keyName :: Name
+ con keyType :: Type
+ val showKey : show keyType
+
+ con visible :: {(Type * Type)}
+ constraint [keyName] ~ visible
+ val folder : folder visible
+ val visible : $(map Meta.meta visible)
+
+ con invisible :: {Type}
+ constraint [keyName] ~ invisible
+ constraint visible ~ invisible
+
+ val title : string
+ val isAllowed : transaction bool
+ table t : ([keyName = keyType] ++ map fst visible ++ invisible)
+ end) : sig
+
+ val main : unit -> transaction page
+
+end
diff --git a/demo/more/conference.ur b/demo/more/conference.ur
index 569059c1..0410e0bb 100644
--- a/demo/more/conference.ur
+++ b/demo/more/conference.ur
@@ -1,27 +1,4 @@
-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 =>
- <xml><textbox{nm} value={show n}/></xml>,
- Parse = readError,
- Inject = _}
-
-val int = default
-val float = default
-val string = default
-val bool = {Show = txt,
- Widget = fn [nm :: Name] => <xml><checkbox{nm}/></xml>,
- WidgetPopulated = fn [nm :: Name] b =>
- <xml><checkbox{nm} checked={b}/></xml>,
- Parse = fn x => x,
- Inject = _}
+open Meta
functor Make(M : sig
con paper :: {(Type * Type)}
@@ -52,7 +29,7 @@ functor Make(M : sig
cookie login : {Id : int, Password : string}
- fun checkLogin () =
+ val checkLogin =
r <- getCookie login;
case r of
None => return None
@@ -62,6 +39,21 @@ functor Make(M : sig
WHERE user.Id = {[r.Id]}
AND user.Password = {[r.Password]})
+ structure Users = BulkEdit.Make(struct
+ con keyName = #Id
+ val visible = {Nam = string "Name",
+ Chair = bool "Chair?",
+ OnPc = bool "On PC?"}
+
+ val title = "Users"
+ val isAllowed =
+ me <- checkLogin;
+ return (Option.isSome me)
+
+ val t = user
+ end)
+
+
fun doRegister r =
n <- oneRowE1 (SELECT COUNT( * ) AS N
FROM user
@@ -90,11 +82,18 @@ functor Make(M : sig
</body></xml>
and main () =
- me <- checkLogin ();
+ 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>}
+ | Some me => <xml>
+ <div>Welcome, {[me.Nam]}!</div>
+
+ {if me.Chair then
+ <xml><li><a link={Users.main ()}>Manage users</a></li></xml>
+ else
+ <xml/>}
+ </xml>}
</body></xml>
end
diff --git a/demo/more/conference.urp b/demo/more/conference.urp
index 51a63cb0..853b9b63 100644
--- a/demo/more/conference.urp
+++ b/demo/more/conference.urp
@@ -1,3 +1,5 @@
$/option
+meta
+bulkEdit
conference
diff --git a/demo/more/conference.urs b/demo/more/conference.urs
index aecdf143..7ca042a5 100644
--- a/demo/more/conference.urs
+++ b/demo/more/conference.urs
@@ -1,23 +1,11 @@
-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 : 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)
+ val paper : $(map Meta.meta paper)
con review :: {(Type * Type)}
constraint [Paper, User] ~ review
- val review : $(map meta review)
+ val review : $(map Meta.meta review)
end) : sig
val main : unit -> transaction page
diff --git a/demo/more/meta.ur b/demo/more/meta.ur
new file mode 100644
index 00000000..2a8787f7
--- /dev/null
+++ b/demo/more/meta.ur
@@ -0,0 +1,27 @@
+con meta = fn (db :: Type, widget :: Type) =>
+ {Nam : string,
+ 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) name : meta (t, string) =
+ {Nam = name,
+ Show = txt,
+ Widget = fn [nm :: Name] => <xml><textbox{nm}/></xml>,
+ WidgetPopulated = fn [nm :: Name] n =>
+ <xml><textbox{nm} value={show n}/></xml>,
+ Parse = readError,
+ Inject = _}
+
+val int = default
+val float = default
+val string = default
+fun bool name = {Nam = name,
+ Show = txt,
+ Widget = fn [nm :: Name] => <xml><checkbox{nm}/></xml>,
+ WidgetPopulated = fn [nm :: Name] b =>
+ <xml><checkbox{nm} checked={b}/></xml>,
+ Parse = fn x => x,
+ Inject = _}
diff --git a/demo/more/meta.urs b/demo/more/meta.urs
new file mode 100644
index 00000000..d4d626c5
--- /dev/null
+++ b/demo/more/meta.urs
@@ -0,0 +1,12 @@
+con meta = fn (db :: Type, widget :: Type) =>
+ {Nam : string,
+ 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 : string -> meta (int, string)
+val float : string -> meta (float, string)
+val string : string -> meta (string, string)
+val bool : string -> meta (bool, bool)
diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index 9ddae8fe..7c3c0969 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -594,25 +594,25 @@ val img : bodyTag ([Src = url, Onabort = transaction unit, Onerror = transaction
Onload = transaction unit] ++ boxEvents)
val form : ctx ::: {Unit} -> bind ::: {Type}
- -> [[Body] ~ ctx] =>
- xml form [] bind
+ -> [[Body, Form] ~ ctx] =>
+ xml ([Body, Form] ++ ctx) [] bind
-> xml ([Body] ++ ctx) [] []
val subform : ctx ::: {Unit} -> use ::: {Type} -> bind ::: {Type}
-> [[Form] ~ ctx] =>
nm :: Name -> [[nm] ~ use] =>
- xml form [] bind
+ xml ([Form] ++ ctx) [] bind
-> xml ([Form] ++ ctx) use [nm = $bind]
val subforms : ctx ::: {Unit} -> use ::: {Type} -> bind ::: {Type}
- -> [[Form] ~ ctx] =>
+ -> [[Form, Subform] ~ ctx] =>
nm :: Name -> [[nm] ~ use] =>
- xml subform [Entry = $bind] []
+ xml ([Subform] ++ ctx) [Entry = $bind] []
-> xml ([Form] ++ ctx) use [nm = list ($bind)]
val entry : ctx ::: {Unit} -> bind ::: {Type}
- -> [[Subform] ~ ctx] =>
- xml form [] bind
+ -> [[Subform, Form] ~ ctx] =>
+ xml ([Form] ++ ctx) [] bind
-> xml ([Subform] ++ ctx) [Entry = $bind] []
con formTag = fn (ty :: Type) (inner :: {Unit}) (attrs :: {Type}) =>
diff --git a/lib/ur/top.ur b/lib/ur/top.ur
index 6ffc888f..6a0f8751 100644
--- a/lib/ur/top.ur
+++ b/lib/ur/top.ur
@@ -216,10 +216,10 @@ fun queryI [tables ::: {{Type}}] [exps ::: {Type}]
(fn fs _ => f fs)
()
-fun queryX [tables ::: {{Type}}] [exps ::: {Type}] [ctx ::: {Unit}]
+fun queryX [tables ::: {{Type}}] [exps ::: {Type}] [ctx ::: {Unit}] [inp ::: {Type}]
[tables ~ exps] (q : sql_query tables exps)
(f : $(exps ++ map (fn fields :: {Type} => $fields) tables)
- -> xml ctx [] []) =
+ -> xml ctx inp []) =
query q
(fn fs acc => return <xml>{acc}{f fs}</xml>)
<xml/>
diff --git a/lib/ur/top.urs b/lib/ur/top.urs
index 82090dd2..b6734cd3 100644
--- a/lib/ur/top.urs
+++ b/lib/ur/top.urs
@@ -125,12 +125,12 @@ val queryI : tables ::: {{Type}} -> exps ::: {Type}
-> transaction unit)
-> transaction unit
-val queryX : tables ::: {{Type}} -> exps ::: {Type} -> ctx ::: {Unit}
+val queryX : tables ::: {{Type}} -> exps ::: {Type} -> ctx ::: {Unit} -> inp ::: {Type}
-> [tables ~ exps] =>
sql_query tables exps
-> ($(exps ++ map (fn fields :: {Type} => $fields) tables)
- -> xml ctx [] [])
- -> transaction (xml ctx [] [])
+ -> xml ctx inp [])
+ -> transaction (xml ctx inp [])
val queryX' : tables ::: {{Type}} -> exps ::: {Type} -> ctx ::: {Unit}
-> [tables ~ exps] =>
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-23 15:55:48 +0000