Mercurial > urweb

comparison demo/crud.ur @ 421:0767d7ad0c3a

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