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 | ||
93f77ca7 | 13 | val outputDir = "/var/www/dyn/" |
27e48ace AC |
14 | |
15 | fun generate () = | |
16 | let | |
93f77ca7 | 17 | val db = C.conn "dbname='hcoop_hcoop'" |
27e48ace AC |
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) | |
711b47a1 | 56 | "SELECT name, rname, usr FROM WebUserPaying LEFT OUTER JOIN DirectoryPref ON id = usr ORDER BY name" |
27e48ace AC |
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 | |
4b210a5d AC |
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 | |
9bda1e7f | 192 | ignore (OS.Process.system ("/bin/rm " ^ outputDir ^ "member/*.html")); |
711b47a1 | 193 | C.app db doOne "SELECT id, name, rname, joined, usr FROM WebUserPaying LEFT OUTER JOIN DirectoryPref ON usr = id" |
4b210a5d AC |
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 | |
4b210a5d AC |
241 | case NM.find (res, id) of |
242 | NONE => () | |
cebd52f7 AC |
243 | | SOME n => |
244 | (TextIO.output (outf, "<li> "); | |
245 | TextIO.output (outf, Web.html name); | |
246 | TextIO.output (outf, " ("); | |
247 | TextIO.output (outf, Int.toString n); | |
248 | TextIO.output (outf, ")"); | |
249 | TextIO.output (outf, "</li>\n<ul>\n"); | |
250 | locationTree (SOME id); | |
251 | TextIO.output (outf, "</ul>\n")) | |
4b210a5d AC |
252 | end |
253 | | doOne _ = raise Fail "Bad locationTree row" | |
254 | in | |
255 | C.app db doOne (String.concat ["SELECT id, name FROM Location WHERE parent ", | |
256 | (case root of NONE => "IS NULL" | SOME p => "= " ^ Int.toString p), | |
257 | " ORDER BY name"]) | |
258 | end | |
259 | in | |
260 | locationTree NONE; | |
261 | footer outf; | |
262 | TextIO.closeOut outf | |
263 | end | |
3f4ab2db AC |
264 | |
265 | fun genLinks () = | |
266 | let | |
267 | val outf = TextIO.openOut (outputDir ^ "sites.html") | |
268 | ||
269 | val _ = header (outf, "Hosted sites") | |
270 | ||
271 | fun doLink [url, title, descr, name] = (C.stringFromSql url, C.stringFromSql title, C.stringFromSql descr, C.stringFromSql name) | |
272 | | doLink _ = raise Fail "Bad link' row" | |
273 | ||
274 | val links = C.map db doLink (String.concat ["SELECT url, title, descr, name FROM Link", | |
711b47a1 AC |
275 | " JOIN WebUserPaying ON WebUserPaying.id = usr", |
276 | " JOIN DirectoryPref ON WebUserPaying.id = DirectoryPref.usr", | |
3f4ab2db AC |
277 | " ORDER BY title"]) |
278 | ||
279 | fun appLink (url, title, descr, name) = | |
280 | (TextIO.output (outf, "<tr> <td><b><a href=\""); | |
281 | TextIO.output (outf, Web.html url); | |
282 | TextIO.output (outf, "\">"); | |
283 | TextIO.output (outf, Web.html title); | |
284 | TextIO.output (outf, "</a></b></td> <td>"); | |
285 | TextIO.output (outf, Web.html descr); | |
286 | TextIO.output (outf, "</td> <td><a href=\"member/"); | |
287 | TextIO.output (outf, name); | |
288 | TextIO.output (outf, ".html\">"); | |
289 | TextIO.output (outf, name); | |
290 | TextIO.output (outf, "</a></td> </tr>\n")) | |
291 | in | |
292 | TextIO.output (outf, "<table>\n"); | |
293 | app appLink links; | |
294 | footer outf; | |
295 | TextIO.closeOut outf | |
296 | end | |
27e48ace AC |
297 | in |
298 | genMemberList (); | |
4b210a5d AC |
299 | genMemberPages (); |
300 | genLocations (); | |
3f4ab2db | 301 | genLinks (); |
27e48ace AC |
302 | OS.Process.success |
303 | end | |
304 | ||
305 | fun main _ = (generate ()) | |
4b210a5d AC |
306 | handle |
307 | C.Sql s => (print "SQL exception: \n"; | |
308 | print s; | |
309 | OS.Process.failure) | |
310 | | Fail s => (print "Fail: "; | |
311 | print s; | |
312 | OS.Process.failure) | |
313 | | ex => (print "Exception!\n"; | |
314 | List.app (fn s => print (s ^ "\n")) (SMLofNJ.exnHistory ex); | |
27e48ace AC |
315 | OS.Process.failure) |
316 | ||
93f77ca7 | 317 | end |