Mercurial > urweb

annotate demo/crud.ur @ 911:12c77dc567a2

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Fix list jsification bug; grid1 working with foreign key, but booleans not getting into database properly
author Adam Chlipala <adamc@hcoop.net>
date Tue, 25 Aug 2009 14:50:19 -0400
parents 74e9e7642f08
children bb3fc575cfe7
rev   line source
adamc@421 1 con colMeta = fn t_formT :: (Type * Type) => {
adamc@421 2 Nam : string,
adamc@421 3 Show : t_formT.1 -> xbody,
adamc@421 4 Widget : nm :: Name -> xml form [] [nm = t_formT.2],
adamc@421 5 WidgetPopulated : nm :: Name -> t_formT.1 -> xml form [] [nm = t_formT.2],
adamc@421 6 Parse : t_formT.2 -> t_formT.1,
adamc@421 7 Inject : sql_injectable t_formT.1
adamc@421 8 }
adamc@622 9 con colsMeta = fn cols :: {(Type * Type)} => $(map colMeta cols)
adamc@421 10
adamc@823 11 fun default [t] (sh : show t) (rd : read t) (inj : sql_injectable t)
adamc@421 12 name : colMeta (t, string) =
adamc@421 13 {Nam = name,
adamc@421 14 Show = txt,
adamc@823 15 Widget = fn [nm :: Name] => <xml><textbox{nm}/></xml>,
adamc@823 16 WidgetPopulated = fn [nm :: Name] n =>
adamc@421 17 <xml><textbox{nm} value={show n}/></xml>,
adamc@421 18 Parse = readError,
adamc@421 19 Inject = _}
adamc@421 20
adamc@421 21 val int = default
adamc@421 22 val float = default
adamc@421 23 val string = default
adamc@421 24
adamc@421 25 fun bool name = {Nam = name,
adamc@421 26 Show = txt,
adamc@823 27 Widget = fn [nm :: Name] => <xml><checkbox{nm}/></xml>,
adamc@823 28 WidgetPopulated = fn [nm :: Name] b =>
adamc@421 29 <xml><checkbox{nm} checked={b}/></xml>,
adamc@421 30 Parse = fn x => x,
adamc@421 31 Inject = _}
adamc@421 32
adamc@421 33 functor Make(M : sig
adamc@421 34 con cols :: {(Type * Type)}
adamc@421 35 constraint [Id] ~ cols
adamc@632 36 val fl : folder cols
adamc@632 37
adamc@706 38 table tab : ([Id = int] ++ map fst cols)
adamc@421 39
adamc@421 40 val title : string
adamc@421 41
adamc@421 42 val cols : colsMeta cols
adamc@421 43 end) = struct
adamc@421 44
adamc@421 45 val tab = M.tab
adamc@421 46
adamc@421 47 sequence seq
adamc@421 48
adamc@421 49 fun list () =
adamc@421 50 rows <- queryX (SELECT * FROM tab AS T)
adamc@637 51 (fn (fs : {T : $([Id = int] ++ map fst M.cols)}) => <xml>
adamc@421 52 <tr>
adamc@421 53 <td>{[fs.T.Id]}</td>
adamc@637 54 {foldRX2 [fst] [colMeta] [tr]
adamc@823 55 (fn [nm :: Name] [t :: (Type * Type)] [rest :: {(Type * Type)}]
adamc@632 56 [[nm] ~ rest] v col => <xml>
adamc@632 57 <td>{col.Show v}</td>
adamc@632 58 </xml>)
adamc@632 59 [M.cols] M.fl (fs.T -- #Id) M.cols}
adamc@421 60 <td>
adamc@421 61 <a link={upd fs.T.Id}>[Update]</a>
adamc@421 62 <a link={confirm fs.T.Id}>[Delete]</a>
adamc@421 63 </td>
adamc@421 64 </tr>
adamc@421 65 </xml>);
adamc@421 66 return <xml>
adamc@421 67 <table border={1}>
adamc@421 68 <tr>
adamc@421 69 <th>ID</th>
adamc@632 70 {foldRX [colMeta] [tr]
adamc@823 71 (fn [nm :: Name] [t :: (Type * Type)] [rest :: {(Type * Type)}]
adamc@421 72 [[nm] ~ rest] col => <xml>
adamc@421 73 <th>{cdata col.Nam}</th>
adamc@421 74 </xml>)
adamc@632 75 [M.cols] M.fl M.cols}
adamc@421 76 </tr>
adamc@421 77 {rows}
adamc@421 78 </table>
adamc@421 79
adamc@421 80 <br/><hr/><br/>
adamc@421 81
adamc@421 82 <form>
adamc@637 83 {foldR [colMeta] [fn cols :: {(Type * Type)} => xml form [] (map snd cols)]
adamc@823 84 (fn [nm :: Name] [t :: (Type * Type)] [rest :: {(Type * Type)}]
adamc@637 85 [[nm] ~ rest] (col : colMeta t) (acc : xml form [] (map snd rest)) => <xml>
adamc@632 86 <li> {cdata col.Nam}: {col.Widget [nm]}</li>
adamc@632 87 {useMore acc}
adamc@632 88 </xml>)
adamc@421 89 <xml/>
adamc@632 90 [M.cols] M.fl M.cols}
adamc@421 91
adamc@421 92 <submit action={create}/>
adamc@421 93 </form>
adamc@421 94 </xml>
adamc@421 95
adamc@637 96 and create (inputs : $(map snd M.cols)) =
adamc@421 97 id <- nextval seq;
adamc@434 98 dml (insert tab
adamc@637 99 (foldR2 [snd] [colMeta]
adamc@632 100 [fn cols => $(map (fn t :: (Type * Type) =>
adamc@632 101 sql_exp [] [] [] t.1) cols)]
adamc@823 102 (fn [nm :: Name] [t :: (Type * Type)] [rest :: {(Type * Type)}]
adamc@632 103 [[nm] ~ rest] =>
adamc@632 104 fn input col acc => acc ++ {nm = @sql_inject col.Inject (col.Parse input)})
adamc@632 105 {} [M.cols] M.fl inputs M.cols
adamc@471 106 ++ {Id = (SQL {[id]})}));
adamc@421 107 ls <- list ();
adamc@421 108 return <xml><body>
adamc@421 109 <p>Inserted with ID {[id]}.</p>
adamc@421 110
adamc@421 111 {ls}
adamc@421 112 </body></xml>
adamc@421 113
adamc@499 114 and upd (id : int) =
adamc@499 115 let
adamc@637 116 fun save (inputs : $(map snd M.cols)) =
adamc@637 117 dml (update [map fst M.cols] !
adamc@637 118 (foldR2 [snd] [colMeta]
adamc@632 119 [fn cols => $(map (fn t :: (Type * Type) =>
adamc@632 120 sql_exp [T = [Id = int]
adamc@637 121 ++ map fst M.cols]
adamc@632 122 [] [] t.1) cols)]
adamc@823 123 (fn [nm :: Name] [t :: (Type * Type)] [rest :: {(Type * Type)}]
adamc@632 124 [[nm] ~ rest] =>
adamc@632 125 fn input col acc => acc ++ {nm =
adamc@632 126 @sql_inject col.Inject (col.Parse input)})
adamc@632 127 {} [M.cols] M.fl inputs M.cols)
adamc@499 128 tab (WHERE T.Id = {[id]}));
adamc@499 129 ls <- list ();
adamc@499 130 return <xml><body>
adamc@499 131 <p>Saved!</p>
adamc@421 132
adamc@499 133 {ls}
adamc@499 134 </body></xml>
adamc@499 135 in
adamc@637 136 fso <- oneOrNoRows (SELECT tab.{{map fst M.cols}} FROM tab WHERE tab.Id = {[id]});
adamc@637 137 case fso : (Basis.option {Tab : $(map fst M.cols)}) of
adamc@499 138 None => return <xml><body>Not found!</body></xml>
adamc@499 139 | Some fs => return <xml><body><form>
adamc@637 140 {foldR2 [fst] [colMeta] [fn cols :: {(Type * Type)} => xml form [] (map snd cols)]
adamc@823 141 (fn [nm :: Name] [t :: (Type * Type)] [rest :: {(Type * Type)}]
adamc@632 142 [[nm] ~ rest] (v : t.1) (col : colMeta t)
adamc@637 143 (acc : xml form [] (map snd rest)) =>
adamc@632 144 <xml>
adamc@632 145 <li> {cdata col.Nam}: {col.WidgetPopulated [nm] v}</li>
adamc@632 146 {useMore acc}
adamc@632 147 </xml>)
adamc@632 148 <xml/>
adamc@632 149 [M.cols] M.fl fs.Tab M.cols}
adamc@421 150
adamc@499 151 <submit action={save}/>
adamc@499 152 </form></body></xml>
adamc@499 153 end
adamc@421 154
adamc@499 155 and confirm (id : int) =
adamc@499 156 let
adamc@499 157 fun delete () =
adamc@499 158 dml (DELETE FROM tab WHERE Id = {[id]});
adamc@499 159 ls <- list ();
adamc@499 160 return <xml><body>
adamc@499 161 <p>The deed is done.</p>
adamc@499 162
adamc@499 163 {ls}
adamc@499 164 </body></xml>
adamc@499 165 in
adamc@499 166 return <xml><body>
adamc@499 167 <p>Are you sure you want to delete ID #{[id]}?</p>
adamc@499 168
adamc@732 169 <form><submit action={delete} value="I was born sure!"/></form>
adamc@499 170 </body></xml>
adamc@499 171 end
adamc@421 172
adamc@421 173 and main () =
adamc@421 174 ls <- list ();
adamc@421 175 return <xml><head>
adamc@421 176 <title>{cdata M.title}</title>
adamc@421 177 </head><body>
adamc@421 178
adamc@421 179 <h1>{cdata M.title}</h1>
adamc@421 180
adamc@421 181 {ls}
adamc@421 182 </body></xml>
adamc@421 183
adamc@421 184 end