From 8ba88fa1aacb63cff48fe42ba7d3dcfc31c45bbb Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 20 Oct 2009 12:48:53 -0400 Subject: Start of user management --- demo/more/bulkEdit.ur | 51 ++++++++++++++++++++++++++++++++++++++++++++++ demo/more/bulkEdit.urs | 22 ++++++++++++++++++++ demo/more/conference.ur | 53 ++++++++++++++++++++++++------------------------ demo/more/conference.urp | 2 ++ demo/more/conference.urs | 16 ++------------- demo/more/meta.ur | 27 ++++++++++++++++++++++++ demo/more/meta.urs | 12 +++++++++++ 7 files changed, 142 insertions(+), 41 deletions(-) create mode 100644 demo/more/bulkEdit.ur create mode 100644 demo/more/bulkEdit.urs create mode 100644 demo/more/meta.ur create mode 100644 demo/more/meta.urs (limited to 'demo/more') 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 => + + {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)) => + + {m.WidgetPopulated [nm] v} + {useMore acc} + ) + + [_] folder visible (r.T -- keyName))} + ); + + return +

{[title]}

+ +
+ {foldRX [meta] [_] + (fn [nm :: Name] [p :: (Type * Type)] [rest :: {(Type * Type)}] [[nm] ~ rest] m => + ) [_] folder visible} + {items} +
{[m.Nam]}
+ + +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] => , - WidgetPopulated = fn [nm :: Name] n => - , - Parse = readError, - Inject = _} - -val int = default -val float = default -val string = default -val bool = {Show = txt, - Widget = fn [nm :: Name] => , - WidgetPopulated = fn [nm :: Name] b => - , - 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 and main () = - me <- checkLogin (); + me <- checkLogin; return {case me of None =>
  • Register for access
    •  - | Some {Nam = name, ...} => Welcome, {[name]}!} + | Some me => +
    Welcome, {[me.Nam]}!
    + + {if me.Chair then +
  • Manage users
    •  + else + } + }     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] => , + WidgetPopulated = fn [nm :: Name] n => + , + Parse = readError, + Inject = _} + +val int = default +val float = default +val string = default +fun bool name = {Nam = name, + Show = txt, + Widget = fn [nm :: Name] => , + WidgetPopulated = fn [nm :: Name] b => + , + 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) -- cgit v1.2.3