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