Mercurial > urweb
changeset 1004:a87495bcaeec
Start of user management
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Tue, 20 Oct 2009 12:48:53 -0400 |
| parents | 61c30f0742d7 |
| children | c6e948ec79e9 |
| files | demo/more/bulkEdit.ur demo/more/bulkEdit.urs demo/more/conference.ur demo/more/conference.urp demo/more/conference.urs demo/more/meta.ur demo/more/meta.urs lib/ur/basis.urs lib/ur/top.ur lib/ur/top.urs |
| diffstat | 10 files changed, 154 insertions(+), 53 deletions(-) [+] |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/demo/more/bulkEdit.ur Tue Oct 20 12:48:53 2009 -0400 @@ -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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/demo/more/bulkEdit.urs Tue Oct 20 12:48:53 2009 -0400 @@ -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
--- a/demo/more/conference.ur Tue Oct 20 11:05:58 2009 -0400 +++ b/demo/more/conference.ur Tue Oct 20 12:48:53 2009 -0400 @@ -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 @@ cookie login : {Id : int, Password : string} - fun checkLogin () = + val checkLogin = r <- getCookie login; case r of None => return None @@ -62,6 +39,21 @@ 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 @@ </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
--- a/demo/more/conference.urp Tue Oct 20 11:05:58 2009 -0400 +++ b/demo/more/conference.urp Tue Oct 20 12:48:53 2009 -0400 @@ -1,3 +1,5 @@ $/option +meta +bulkEdit conference
--- a/demo/more/conference.urs Tue Oct 20 11:05:58 2009 -0400 +++ b/demo/more/conference.urs Tue Oct 20 12:48:53 2009 -0400 @@ -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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/demo/more/meta.ur Tue Oct 20 12:48:53 2009 -0400 @@ -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 = _}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/demo/more/meta.urs Tue Oct 20 12:48:53 2009 -0400 @@ -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)
--- a/lib/ur/basis.urs Tue Oct 20 11:05:58 2009 -0400 +++ b/lib/ur/basis.urs Tue Oct 20 12:48:53 2009 -0400 @@ -594,25 +594,25 @@ 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}) =>
--- a/lib/ur/top.ur Tue Oct 20 11:05:58 2009 -0400 +++ b/lib/ur/top.ur Tue Oct 20 12:48:53 2009 -0400 @@ -216,10 +216,10 @@ (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/>
--- a/lib/ur/top.urs Tue Oct 20 11:05:58 2009 -0400 +++ b/lib/ur/top.urs Tue Oct 20 12:48:53 2009 -0400 @@ -125,12 +125,12 @@ -> 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] =>