566fd712 |
1 | structure Gen :> GEN = |
2 | struct |
3 | |
4 | structure C = PgClient |
5 | |
7b8746ef |
6 | structure IntKey = struct |
7 | type ord_key = int |
8 | val compare = Int.compare |
9 | end |
10 | |
11 | structure NM = BinaryMapFn(IntKey) |
12 | |
646dca75 |
13 | val outputDir = "/var/www/dyn/" |
566fd712 |
14 | |
15 | fun generate () = |
16 | let |
646dca75 |
17 | val db = C.conn "dbname='hcoop_hcoop'" |
566fd712 |
18 | |
19 | fun header (outf, title) = |
20 | (TextIO.output (outf, "<html><head>\n<title>"); |
21 | TextIO.output (outf, title); |
22 | TextIO.output (outf, "</title></head>\n<body>\n<h2><b>"); |
23 | TextIO.output (outf, title); |
24 | TextIO.output (outf, "</b></h2>\n")) |
25 | |
26 | fun footer outf = |
27 | TextIO.output (outf, "\n</body></html>") |
28 | |
29 | fun genMemberList () = |
30 | let |
31 | val outf = TextIO.openOut (outputDir ^ "members.html") |
32 | |
33 | fun printOne ([name, rname, usr], (total, anon)) = |
34 | let |
35 | val name = C.stringFromSql name |
36 | val rname = C.stringFromSql rname |
37 | val isAnon = C.isNull usr |
38 | in |
39 | if not isAnon then |
40 | (TextIO.output (outf, "<tr> <td><a href=\"member/"); |
41 | TextIO.output (outf, name); |
42 | TextIO.output (outf, ".html\">"); |
43 | TextIO.output (outf, name); |
44 | TextIO.output (outf, "</a></td> <td>"); |
45 | TextIO.output (outf, rname); |
46 | TextIO.output (outf, "</td> </tr>\n")) |
47 | else |
48 | (); |
49 | (total + 1, (if C.isNull usr then anon + 1 else anon)) |
50 | end |
51 | | printOne _ = raise Fail "Bad printOne line" |
52 | |
53 | val _ = header (outf, "Member list") |
54 | val _ = TextIO.output (outf, "<table>\n") |
55 | val (total, anon) = C.fold db printOne (0, 0) |
ea455810 |
56 | "SELECT name, rname, usr FROM WebUserPaying LEFT OUTER JOIN DirectoryPref ON id = usr ORDER BY name" |
566fd712 |
57 | in |
58 | TextIO.output (outf, "</table><br><br>\n\nUnlisted members: "); |
59 | TextIO.output (outf, Int.toString anon); |
60 | TextIO.output (outf, " out of "); |
61 | TextIO.output (outf, Int.toString total); |
62 | TextIO.output (outf, " total.\n"); |
63 | footer outf; |
64 | TextIO.closeOut outf |
65 | end |
7b8746ef |
66 | |
67 | fun genMemberPages () = |
68 | let |
69 | fun doOne [id, name, rname, joined, usr] = |
70 | let |
71 | val id = C.intFromSql id |
72 | val name = C.stringFromSql name |
73 | val rname = C.stringFromSql rname |
74 | val joined = C.timestampFromSql joined |
75 | val anon = C.isNull usr |
76 | in |
77 | if anon then |
78 | () |
79 | else |
80 | let |
81 | val outf = TextIO.openOut (String.concat [outputDir, "member/", name, ".html"]) |
82 | |
83 | val _ = header (outf, "Hcoop member: " ^ name) |
84 | val _ = TextIO.output (outf, "<table>\n<tr> <td align=\"right\"><b>Member</b>:</td> <td>") |
85 | val _ = TextIO.output (outf, name) |
86 | val _ = TextIO.output (outf, "</td> </tr>\n<tr> <td align=\"right\"><b>Name</b>:</td> <td>") |
87 | val _ = TextIO.output (outf, rname) |
88 | val _ = TextIO.output (outf, "</td> </tr>\n<tr> <td align=\"right\"><b>Joined</b>:</td> <td>") |
89 | val _ = TextIO.output (outf, Date.toString (Date.fromTimeLocal joined)) |
90 | |
91 | fun doLocation [id] = C.intFromSql id |
92 | | doLocation _ = raise Fail "Bad location row" |
93 | |
94 | val locations = C.map db doLocation (String.concat ["SELECT id FROM Location JOIN Lives ON loc = id AND usr = ", |
95 | Int.toString id]) |
96 | |
97 | fun printLocation id = |
98 | let |
99 | val (name, parent) = |
100 | case C.oneRow db ("SELECT name, parent FROM Location WHERE id = " ^ Int.toString id) of |
101 | [name, parent] => (C.stringFromSql name, if C.isNull parent then NONE else SOME (C.intFromSql parent)) |
102 | | _ => raise Fail "Bad printLocation row" |
103 | in |
104 | case parent of |
105 | NONE => () |
106 | | SOME parent => (printLocation parent; |
107 | TextIO.output (outf, " : ")); |
108 | TextIO.output (outf, name) |
109 | end |
110 | |
111 | val first = ref true |
112 | |
113 | fun appLocation id = |
114 | (if !first then |
115 | first := false |
116 | else |
117 | TextIO.output (outf, ", "); |
118 | printLocation id) |
119 | |
120 | val _ = case locations of |
121 | [] => () |
122 | | _ => |
123 | (TextIO.output (outf, "<tr> </tr>\n\n<tr> <td align=\"right\"><b>Locations</b>:</td> <td>"); |
124 | app appLocation locations; |
125 | TextIO.output (outf, "</td> </tr>\n")) |
126 | |
127 | fun doLink [url, title, descr] = (C.stringFromSql url, C.stringFromSql title, C.stringFromSql descr) |
128 | | doLink _ = raise Fail "Bad link row" |
129 | |
130 | val links = C.map db doLink (String.concat ["SELECT url, title, descr FROM Link WHERE usr = ", |
131 | Int.toString id, |
132 | " ORDER BY title"]) |
133 | |
134 | fun appLink (url, title, descr) = |
135 | (TextIO.output (outf, "<tr> <td></td> <td><b><a href=\""); |
136 | TextIO.output (outf, Web.html url); |
137 | TextIO.output (outf, "\">"); |
138 | TextIO.output (outf, Web.html title); |
139 | TextIO.output (outf, "</a></b>"); |
140 | if descr <> "" then |
141 | TextIO.output (outf, ": ") |
142 | else |
143 | (); |
144 | TextIO.output (outf, Web.html descr); |
145 | TextIO.output (outf, "</td> </tr>\n")) |
146 | |
147 | val _ = case links of |
148 | [] => () |
149 | | _ => |
150 | (TextIO.output (outf, "<tr> </tr>\n\n<tr> <td><b>Hosted sites</b></td> </tr>\n"); |
151 | app appLink links) |
152 | |
153 | fun doContact [v, name, url, urlPrefix, urlPostfix] = |
154 | (C.stringFromSql v, C.stringFromSql name, |
155 | if C.boolFromSql url then SOME (C.stringFromSql urlPrefix, C.stringFromSql urlPostfix) else NONE) |
156 | | doContact _ = raise Fail "Bad contact row" |
157 | |
158 | val contacts = C.map db doContact (String.concat ["SELECT v, name, url, urlPrefix, urlPostfix", |
159 | " FROM Contact JOIN ContactKind ON knd = ContactKind.id", |
160 | " WHERE priv = 0", |
161 | " AND usr = ", |
162 | Int.toString id, |
163 | " ORDER BY name, v"]) |
164 | |
165 | fun appContact (v, name, url) = |
166 | let |
167 | val link = |
168 | case url of |
169 | SOME (pre, post) => String.concat ["<a href=\"", pre, Web.html v, post, "\">", Web.html v, "</a>"] |
170 | | NONE => v |
171 | in |
172 | TextIO.output (outf, "<tr> <td align=\"right\" valign=\"top\"><b>"); |
173 | TextIO.output (outf, Web.html name); |
174 | TextIO.output (outf, "</b>:</td>\n<td>"); |
175 | TextIO.output (outf, link); |
176 | TextIO.output (outf, "</td> </tr>\n") |
177 | end |
178 | |
179 | val _ = case contacts of |
180 | [] => () |
181 | | _ => |
182 | (TextIO.output (outf, "<tr> </tr>\n\n<tr> <td><b>Contact information</b></td> </tr>\n"); |
183 | app appContact contacts) |
184 | in |
185 | TextIO.output (outf, "</table>\n"); |
186 | footer outf; |
187 | TextIO.closeOut outf |
188 | end |
189 | end |
190 | | doOne _ = raise Fail "Bad member row" |
191 | in |
f98251aa |
192 | ignore (OS.Process.system ("/bin/rm " ^ outputDir ^ "member/*.html")); |
ea455810 |
193 | C.app db doOne "SELECT id, name, rname, joined, usr FROM WebUserPaying LEFT OUTER JOIN DirectoryPref ON usr = id" |
7b8746ef |
194 | end |
195 | |
196 | fun genLocations () = |
197 | let |
198 | val outf = TextIO.openOut (outputDir ^ "locs.html") |
199 | |
200 | val _ = header (outf, "Where members live") |
201 | |
202 | fun countResidents () = |
203 | let |
204 | fun mkLivesRow [loc, usr] = |
205 | {loc = C.intFromSql loc, usr = C.intFromSql usr} |
206 | | mkLivesRow row = raise Fail "Bad lives row" |
207 | |
208 | fun folder (row, count) = |
209 | let |
210 | fun addToParents (id, count) = |
211 | let |
212 | val count = NM.insert (count, id, (case NM.find (count, id) of |
213 | NONE => 1 |
214 | | SOME n => n+1)) |
215 | in |
216 | case C.oneRow db ("SELECT parent FROM Location WHERE id = " ^ C.intToSql id) of |
217 | [p] => if C.isNull p then |
218 | count |
219 | else |
220 | addToParents (C.intFromSql p, count) |
221 | | r => raise Fail "Bad addToParents row" |
222 | end |
223 | |
224 | val lives = mkLivesRow row |
225 | in |
226 | addToParents (#loc lives, count) |
227 | end |
228 | in |
229 | C.fold db folder NM.empty "SELECT loc, usr FROM Lives" |
230 | end |
231 | |
232 | val res = countResidents () |
233 | |
234 | fun locationTree root = |
235 | let |
236 | fun doOne [id, name] = |
237 | let |
238 | val id = C.intFromSql id |
239 | val name = C.stringFromSql name |
240 | in |
241 | TextIO.output (outf, "<li> "); |
242 | TextIO.output (outf, Web.html name); |
243 | case NM.find (res, id) of |
244 | NONE => () |
245 | | SOME n => (TextIO.output (outf, " ("); |
246 | TextIO.output (outf, Int.toString n); |
247 | TextIO.output (outf, ")")); |
248 | TextIO.output (outf, "</li>\n<ul>\n"); |
249 | locationTree (SOME id); |
250 | TextIO.output (outf, "</ul>\n") |
251 | end |
252 | | doOne _ = raise Fail "Bad locationTree row" |
253 | in |
254 | C.app db doOne (String.concat ["SELECT id, name FROM Location WHERE parent ", |
255 | (case root of NONE => "IS NULL" | SOME p => "= " ^ Int.toString p), |
256 | " ORDER BY name"]) |
257 | end |
258 | in |
259 | locationTree NONE; |
260 | footer outf; |
261 | TextIO.closeOut outf |
262 | end |
3bc39953 |
263 | |
264 | fun genLinks () = |
265 | let |
266 | val outf = TextIO.openOut (outputDir ^ "sites.html") |
267 | |
268 | val _ = header (outf, "Hosted sites") |
269 | |
270 | fun doLink [url, title, descr, name] = (C.stringFromSql url, C.stringFromSql title, C.stringFromSql descr, C.stringFromSql name) |
271 | | doLink _ = raise Fail "Bad link' row" |
272 | |
273 | val links = C.map db doLink (String.concat ["SELECT url, title, descr, name FROM Link", |
ea455810 |
274 | " JOIN WebUserPaying ON WebUserPaying.id = usr", |
275 | " JOIN DirectoryPref ON WebUserPaying.id = DirectoryPref.usr", |
3bc39953 |
276 | " ORDER BY title"]) |
277 | |
278 | fun appLink (url, title, descr, name) = |
279 | (TextIO.output (outf, "<tr> <td><b><a href=\""); |
280 | TextIO.output (outf, Web.html url); |
281 | TextIO.output (outf, "\">"); |
282 | TextIO.output (outf, Web.html title); |
283 | TextIO.output (outf, "</a></b></td> <td>"); |
284 | TextIO.output (outf, Web.html descr); |
285 | TextIO.output (outf, "</td> <td><a href=\"member/"); |
286 | TextIO.output (outf, name); |
287 | TextIO.output (outf, ".html\">"); |
288 | TextIO.output (outf, name); |
289 | TextIO.output (outf, "</a></td> </tr>\n")) |
290 | in |
291 | TextIO.output (outf, "<table>\n"); |
292 | app appLink links; |
293 | footer outf; |
294 | TextIO.closeOut outf |
295 | end |
566fd712 |
296 | in |
297 | genMemberList (); |
7b8746ef |
298 | genMemberPages (); |
299 | genLocations (); |
3bc39953 |
300 | genLinks (); |
566fd712 |
301 | OS.Process.success |
302 | end |
303 | |
304 | fun main _ = (generate ()) |
7b8746ef |
305 | handle |
306 | C.Sql s => (print "SQL exception: \n"; |
307 | print s; |
308 | OS.Process.failure) |
309 | | Fail s => (print "Fail: "; |
310 | print s; |
311 | OS.Process.failure) |
312 | | ex => (print "Exception!\n"; |
313 | List.app (fn s => print (s ^ "\n")) (SMLofNJ.exnHistory ex); |
566fd712 |
314 | OS.Process.failure) |
315 | |
646dca75 |
316 | end |