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] =>