summaryrefslogtreecommitdiff
path: root/demo/more
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 /demo/more
parente23f4d764bc93640cb08a7d6ebd7e261fac2cb05 (diff)
Start of user management
Diffstat (limited to 'demo/more')
-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
7 files changed, 142 insertions, 41 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)
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-17 01:46:35 +0000