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 | ||
63ffda04 | 13 | val outputDir = "/home/hcoop/public_html/dyn/" |
27e48ace AC |
14 | |
15 | fun generate () = | |
16 | let | |
93f77ca7 | 17 | val db = C.conn "dbname='hcoop_hcoop'" |
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) = |
b6dd1aaf | 34 | procOutput (outf, ("/usr/local/bin/hcoop_header", [title])) |
27e48ace AC |
35 | |
36 | fun footer outf = | |
b6dd1aaf | 37 | procOutput (outf, ("/usr/local/bin/hcoop_footer", [])) |
27e48ace AC |
38 | |
39 | fun genMemberList () = | |
40 | let | |
41 | val outf = TextIO.openOut (outputDir ^ "members.html") | |
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); | |
52 | TextIO.output (outf, ".html\">"); | |
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 | |
91 | val outf = TextIO.openOut (String.concat [outputDir, "member/", name, ".html"]) | |
92 | ||
b6dd1aaf | 93 | val _ = header (outf, "HCoop member: " ^ name) |
4b210a5d AC |
94 | val _ = TextIO.output (outf, "<table>\n<tr> <td align=\"right\"><b>Member</b>:</td> <td>") |
95 | val _ = TextIO.output (outf, name) | |
96 | val _ = TextIO.output (outf, "</td> </tr>\n<tr> <td align=\"right\"><b>Name</b>:</td> <td>") | |
97 | val _ = TextIO.output (outf, rname) | |
98 | val _ = TextIO.output (outf, "</td> </tr>\n<tr> <td align=\"right\"><b>Joined</b>:</td> <td>") | |
99 | val _ = TextIO.output (outf, Date.toString (Date.fromTimeLocal joined)) | |
100 | ||
101 | fun doLocation [id] = C.intFromSql id | |
102 | | doLocation _ = raise Fail "Bad location row" | |
103 | ||
104 | val locations = C.map db doLocation (String.concat ["SELECT id FROM Location JOIN Lives ON loc = id AND usr = ", | |
105 | Int.toString id]) | |
106 | ||
107 | fun printLocation id = | |
108 | let | |
109 | val (name, parent) = | |
110 | case C.oneRow db ("SELECT name, parent FROM Location WHERE id = " ^ Int.toString id) of | |
111 | [name, parent] => (C.stringFromSql name, if C.isNull parent then NONE else SOME (C.intFromSql parent)) | |
112 | | _ => raise Fail "Bad printLocation row" | |
113 | in | |
114 | case parent of | |
115 | NONE => () | |
116 | | SOME parent => (printLocation parent; | |
117 | TextIO.output (outf, " : ")); | |
118 | TextIO.output (outf, name) | |
119 | end | |
120 | ||
121 | val first = ref true | |
122 | ||
123 | fun appLocation id = | |
124 | (if !first then | |
125 | first := false | |
126 | else | |
127 | TextIO.output (outf, ", "); | |
128 | printLocation id) | |
129 | ||
130 | val _ = case locations of | |
131 | [] => () | |
132 | | _ => | |
133 | (TextIO.output (outf, "<tr> </tr>\n\n<tr> <td align=\"right\"><b>Locations</b>:</td> <td>"); | |
134 | app appLocation locations; | |
135 | TextIO.output (outf, "</td> </tr>\n")) | |
136 | ||
137 | fun doLink [url, title, descr] = (C.stringFromSql url, C.stringFromSql title, C.stringFromSql descr) | |
138 | | doLink _ = raise Fail "Bad link row" | |
139 | ||
140 | val links = C.map db doLink (String.concat ["SELECT url, title, descr FROM Link WHERE usr = ", | |
141 | Int.toString id, | |
142 | " ORDER BY title"]) | |
143 | ||
144 | fun appLink (url, title, descr) = | |
145 | (TextIO.output (outf, "<tr> <td></td> <td><b><a href=\""); | |
146 | TextIO.output (outf, Web.html url); | |
147 | TextIO.output (outf, "\">"); | |
148 | TextIO.output (outf, Web.html title); | |
149 | TextIO.output (outf, "</a></b>"); | |
150 | if descr <> "" then | |
151 | TextIO.output (outf, ": ") | |
152 | else | |
153 | (); | |
154 | TextIO.output (outf, Web.html descr); | |
155 | TextIO.output (outf, "</td> </tr>\n")) | |
156 | ||
157 | val _ = case links of | |
158 | [] => () | |
159 | | _ => | |
160 | (TextIO.output (outf, "<tr> </tr>\n\n<tr> <td><b>Hosted sites</b></td> </tr>\n"); | |
161 | app appLink links) | |
162 | ||
163 | fun doContact [v, name, url, urlPrefix, urlPostfix] = | |
164 | (C.stringFromSql v, C.stringFromSql name, | |
165 | if C.boolFromSql url then SOME (C.stringFromSql urlPrefix, C.stringFromSql urlPostfix) else NONE) | |
166 | | doContact _ = raise Fail "Bad contact row" | |
167 | ||
168 | val contacts = C.map db doContact (String.concat ["SELECT v, name, url, urlPrefix, urlPostfix", | |
169 | " FROM Contact JOIN ContactKind ON knd = ContactKind.id", | |
170 | " WHERE priv = 0", | |
171 | " AND usr = ", | |
172 | Int.toString id, | |
173 | " ORDER BY name, v"]) | |
174 | ||
175 | fun appContact (v, name, url) = | |
176 | let | |
177 | val link = | |
178 | case url of | |
179 | SOME (pre, post) => String.concat ["<a href=\"", pre, Web.html v, post, "\">", Web.html v, "</a>"] | |
180 | | NONE => v | |
181 | in | |
182 | TextIO.output (outf, "<tr> <td align=\"right\" valign=\"top\"><b>"); | |
183 | TextIO.output (outf, Web.html name); | |
184 | TextIO.output (outf, "</b>:</td>\n<td>"); | |
185 | TextIO.output (outf, link); | |
186 | TextIO.output (outf, "</td> </tr>\n") | |
187 | end | |
188 | ||
189 | val _ = case contacts of | |
190 | [] => () | |
191 | | _ => | |
192 | (TextIO.output (outf, "<tr> </tr>\n\n<tr> <td><b>Contact information</b></td> </tr>\n"); | |
193 | app appContact contacts) | |
194 | in | |
195 | TextIO.output (outf, "</table>\n"); | |
196 | footer outf; | |
197 | TextIO.closeOut outf | |
198 | end | |
199 | end | |
200 | | doOne _ = raise Fail "Bad member row" | |
201 | in | |
9bda1e7f | 202 | ignore (OS.Process.system ("/bin/rm " ^ outputDir ^ "member/*.html")); |
711b47a1 | 203 | C.app db doOne "SELECT id, name, rname, joined, usr FROM WebUserPaying LEFT OUTER JOIN DirectoryPref ON usr = id" |
4b210a5d AC |
204 | end |
205 | ||
206 | fun genLocations () = | |
207 | let | |
208 | val outf = TextIO.openOut (outputDir ^ "locs.html") | |
209 | ||
b6dd1aaf | 210 | val _ = header (outf, "HCoop: Where members live") |
4b210a5d AC |
211 | |
212 | fun countResidents () = | |
213 | let | |
214 | fun mkLivesRow [loc, usr] = | |
215 | {loc = C.intFromSql loc, usr = C.intFromSql usr} | |
216 | | mkLivesRow row = raise Fail "Bad lives row" | |
217 | ||
218 | fun folder (row, count) = | |
219 | let | |
220 | fun addToParents (id, count) = | |
221 | let | |
222 | val count = NM.insert (count, id, (case NM.find (count, id) of | |
223 | NONE => 1 | |
224 | | SOME n => n+1)) | |
225 | in | |
226 | case C.oneRow db ("SELECT parent FROM Location WHERE id = " ^ C.intToSql id) of | |
227 | [p] => if C.isNull p then | |
228 | count | |
229 | else | |
230 | addToParents (C.intFromSql p, count) | |
231 | | r => raise Fail "Bad addToParents row" | |
232 | end | |
233 | ||
234 | val lives = mkLivesRow row | |
235 | in | |
236 | addToParents (#loc lives, count) | |
237 | end | |
238 | in | |
63ffda04 | 239 | C.fold db folder NM.empty "SELECT loc, usr FROM Lives JOIN WebUserActive ON id = usr" |
4b210a5d AC |
240 | end |
241 | ||
242 | val res = countResidents () | |
243 | ||
244 | fun locationTree root = | |
245 | let | |
246 | fun doOne [id, name] = | |
247 | let | |
248 | val id = C.intFromSql id | |
249 | val name = C.stringFromSql name | |
250 | in | |
4b210a5d AC |
251 | case NM.find (res, id) of |
252 | NONE => () | |
cebd52f7 AC |
253 | | SOME n => |
254 | (TextIO.output (outf, "<li> "); | |
255 | TextIO.output (outf, Web.html name); | |
256 | TextIO.output (outf, " ("); | |
257 | TextIO.output (outf, Int.toString n); | |
258 | TextIO.output (outf, ")"); | |
259 | TextIO.output (outf, "</li>\n<ul>\n"); | |
260 | locationTree (SOME id); | |
261 | TextIO.output (outf, "</ul>\n")) | |
4b210a5d AC |
262 | end |
263 | | doOne _ = raise Fail "Bad locationTree row" | |
264 | in | |
265 | C.app db doOne (String.concat ["SELECT id, name FROM Location WHERE parent ", | |
266 | (case root of NONE => "IS NULL" | SOME p => "= " ^ Int.toString p), | |
267 | " ORDER BY name"]) | |
268 | end | |
269 | in | |
270 | locationTree NONE; | |
271 | footer outf; | |
272 | TextIO.closeOut outf | |
273 | end | |
3f4ab2db AC |
274 | |
275 | fun genLinks () = | |
276 | let | |
277 | val outf = TextIO.openOut (outputDir ^ "sites.html") | |
278 | ||
b6dd1aaf | 279 | val _ = header (outf, "HCoop: Hosted sites") |
3f4ab2db AC |
280 | |
281 | fun doLink [url, title, descr, name] = (C.stringFromSql url, C.stringFromSql title, C.stringFromSql descr, C.stringFromSql name) | |
282 | | doLink _ = raise Fail "Bad link' row" | |
283 | ||
284 | val links = C.map db doLink (String.concat ["SELECT url, title, descr, name FROM Link", | |
711b47a1 AC |
285 | " JOIN WebUserPaying ON WebUserPaying.id = usr", |
286 | " JOIN DirectoryPref ON WebUserPaying.id = DirectoryPref.usr", | |
3f4ab2db AC |
287 | " ORDER BY title"]) |
288 | ||
289 | fun appLink (url, title, descr, name) = | |
290 | (TextIO.output (outf, "<tr> <td><b><a href=\""); | |
291 | TextIO.output (outf, Web.html url); | |
292 | TextIO.output (outf, "\">"); | |
293 | TextIO.output (outf, Web.html title); | |
294 | TextIO.output (outf, "</a></b></td> <td>"); | |
295 | TextIO.output (outf, Web.html descr); | |
296 | TextIO.output (outf, "</td> <td><a href=\"member/"); | |
297 | TextIO.output (outf, name); | |
298 | TextIO.output (outf, ".html\">"); | |
299 | TextIO.output (outf, name); | |
300 | TextIO.output (outf, "</a></td> </tr>\n")) | |
301 | in | |
302 | TextIO.output (outf, "<table>\n"); | |
303 | app appLink links; | |
304 | footer outf; | |
305 | TextIO.closeOut outf | |
306 | end | |
27e48ace AC |
307 | in |
308 | genMemberList (); | |
4b210a5d AC |
309 | genMemberPages (); |
310 | genLocations (); | |
3f4ab2db | 311 | genLinks (); |
27e48ace AC |
312 | OS.Process.success |
313 | end | |
314 | ||
315 | fun main _ = (generate ()) | |
4b210a5d AC |
316 | handle |
317 | C.Sql s => (print "SQL exception: \n"; | |
318 | print s; | |
ddc53b56 | 319 | print "\n"; |
4b210a5d AC |
320 | OS.Process.failure) |
321 | | Fail s => (print "Fail: "; | |
322 | print s; | |
ddc53b56 | 323 | print "\n"; |
4b210a5d | 324 | OS.Process.failure) |
ddc53b56 AC |
325 | | IO.Io {name, function, ...} => (print "IO exception "; |
326 | print function; | |
327 | print ": "; | |
328 | print name; | |
329 | print "\n"; | |
330 | OS.Process.failure) | |
4b210a5d AC |
331 | | ex => (print "Exception!\n"; |
332 | List.app (fn s => print (s ^ "\n")) (SMLofNJ.exnHistory ex); | |
27e48ace AC |
333 | OS.Process.failure) |
334 | ||
93f77ca7 | 335 | end |