admin page
+222 −1 · 6 files changed
-
crud.ur+175 −0 -
crud.urs+28 −0 -
urblog.sql+3 −1 -
urblog.ur+13 −0 -
urblog.urp+2 −0 -
urblog.urs+1 −0
@@ -0,0 +1,175 @@ +con colMeta = 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} +con colsMeta = fn cols => $(map colMeta cols) + +fun default [t] (sh : show t) (rd : read t) (inj : sql_injectable t) + name : colMeta (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 +val time = 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 = _} + +functor Make(M : sig + con cols :: {(Type * Type)} + constraint [Id] ~ cols + val fl : folder cols + + table tab : ([Id = int] ++ map fst cols) + + val title : string + + val cols : colsMeta cols + end) = struct + + val tab = M.tab + + sequence seq + + fun editList () = + rows <- queryX (SELECT * FROM tab AS T) + (fn (fs : {T : $([Id = int] ++ map fst M.cols)}) => <xml> + <tr> + <td>{[fs.T.Id]}</td> + {@mapX2 [fst] [colMeta] [tr] + (fn [nm :: Name] [t ::_] [rest ::_] [[nm] ~ rest] v col => <xml> + <td>{col.Show v}</td> + </xml>) + M.fl (fs.T -- #Id) M.cols} + <td> + <a link={upd fs.T.Id}>[Update]</a> + <a link={confirm fs.T.Id}>[Delete]</a> + </td> + </tr> + </xml>); + return <xml> + <table border={1}> + <tr> + <th>ID</th> + {@mapX [colMeta] [tr] + (fn [nm :: Name] [t ::_] [rest ::_] [[nm] ~ rest] col => <xml> + <th>{cdata col.Nam}</th> + </xml>) + M.fl M.cols} + </tr> + {rows} + </table> + + <br/><hr/><br/> + + <form> + {@foldR [colMeta] [fn cols => xml form [] (map snd cols)] + (fn [nm :: Name] [t ::_] [rest ::_] [[nm] ~ rest] (col : colMeta t) acc => <xml> + <li> {cdata col.Nam}:<br /> {col.Widget [nm]}</li> + {useMore acc} + </xml>) + <xml/> + M.fl M.cols} + + <submit action={create}/> + </form> + </xml> + + and create (inputs : $(map snd M.cols)) = + id <- nextval seq; + dml (insert tab + (@foldR2 [snd] [colMeta] + [fn cols => $(map (fn t => sql_exp [] [] [] t.1) cols)] + (fn [nm :: Name] [t ::_] [rest ::_] [[nm] ~ rest] => + fn input col acc => acc ++ {nm = @sql_inject col.Inject (col.Parse input)}) + {} M.fl inputs M.cols + ++ {Id = (SQL {[id]})})); + ls <- editList (); + return <xml><body> + <p>Inserted with ID {[id]}.</p> + + {ls} + </body></xml> + + and upd (id : int) = + let + fun save (inputs : $(map snd M.cols)) = + dml (update [map fst M.cols] + (@foldR2 [snd] [colMeta] + [fn cols => $(map (fn t => sql_exp [T = [Id = int] ++ map fst M.cols] [] [] t.1) cols)] + (fn [nm :: Name] [t ::_] [rest ::_] [[nm] ~ rest] => + fn input col acc => acc ++ {nm = + @sql_inject col.Inject (col.Parse input)}) + {} M.fl inputs M.cols) + tab (WHERE T.Id = {[id]})); + ls <- editList (); + return <xml><body> + <p>Saved!</p> + + {ls} + </body></xml> + in + fso <- oneOrNoRows (SELECT tab.{{map fst M.cols}} FROM tab WHERE tab.Id = {[id]}); + case fso : (Basis.option {Tab : $(map fst M.cols)}) of + None => return <xml><body>Not found!</body></xml> + | Some fs => return <xml><body><form> + {@foldR2 [fst] [colMeta] [fn cols => xml form [] (map snd cols)] + (fn [nm :: Name] [t ::_] [rest ::_] [[nm] ~ rest] v (col : colMeta t) + (acc : xml form [] (map snd rest)) => + <xml> + <li> {cdata col.Nam}:<br/> {col.WidgetPopulated [nm] v}</li> + {useMore acc} + </xml>) + <xml/> + M.fl fs.Tab M.cols} + + <submit action={save}/> + </form></body></xml> + end + + and confirm (id : int) = + let + fun delete () = + dml (DELETE FROM tab WHERE Id = {[id]}); + ls <- editList (); + return <xml><body> + <p>The deed is done.</p> + + {ls} + </body></xml> + in + return <xml><body> + <p>Are you sure you want to delete ID #{[id]}?</p> + + <form><submit action={delete} value="I was born sure!"/></form> + </body></xml> + end + + and admin () = + ls <- editList (); + return <xml><head> + <title>{cdata M.title}</title> + </head><body> + + <h1>{cdata M.title}</h1> + + {ls} + </body></xml> + +end + @@ -0,0 +1,28 @@ +con colMeta = 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} +con colsMeta = fn cols :: {(Type * Type)} => $(map colMeta cols) + +val int : string -> colMeta (int, string) +val float : string -> colMeta (float, string) +val time : string -> colMeta (time, string) +val string : string -> colMeta (string, string) +val bool : string -> colMeta (bool, bool) + +functor Make(M : sig + con cols :: {(Type * Type)} + constraint [Id] ~ cols + val fl : folder cols + + table tab : ([Id = int] ++ map fst cols) + + val title : string + + val cols : colsMeta cols + end) : sig + val admin : unit -> transaction page +end @@ -16,4 +16,6 @@ CREATE TABLE uw_Urblog_entry(uw_id int8 NOT NULL, uw_title text NOT NULL, FOREIGN KEY (uw_entry) REFERENCES uw_Urblog_entry (uw_id) ); - \ No newline at end of file + CREATE SEQUENCE uw_Urblog_seq; + + \ No newline at end of file @@ -10,6 +10,7 @@ style blogEntry style blogComment style commentForm + fun comments i : transaction xbody = queryX (SELECT * FROM comment WHERE comment.Entry = {[i]}) (fn row => @@ -98,3 +99,15 @@ fun main () = return <xml> <h1>UrBlog</h1> </body> </xml> + +open Crud.Make(struct + val tab = entry + + val title = "Blog Admin" + + val cols = {Title = Crud.string "Blog Title", + Created = Crud.time "Created", + Author = Crud.string "Author", + Body = Crud.string "Entry Body"} +(* test *) +end) @@ -6,4 +6,6 @@ rewrite style Urblog/blogComment blogComment database dbname=urblog sql urblog.sql +$/string +crud urblog @@ -1,3 +1,4 @@ val main : unit -> transaction page val list : unit -> transaction page val detail : int -> transaction page +val admin : unit -> transaction page