| 1 | structure Gen :> GEN = |
| 2 | struct |
| 3 | |
| 4 | structure C = PgClient |
| 5 | |
| 6 | structure IntKey = struct |
| 7 | type ord_key = int |
| 8 | val compare = Int.compare |
| 9 | end |
| 10 | |
| 11 | structure NM = BinaryMapFn(IntKey) |
| 12 | |
| 13 | val outputDir = "/home/hcoop/new-hcoop-website/" |
| 14 | |
| 15 | fun generate () = |
| 16 | let |
| 17 | val db = C.conn "dbname='hcoop_hcoop' host='postgres'" |
| 18 | |
| 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 | |
| 33 | fun header (outf, title) = |
| 34 | (TextIO.output (outf, "<!--#include file=\"header.html\" -->\n<div id=\"main\">"); |
| 35 | TextIO.output (outf, "<h2>" ^ title ^ "</h2>\n")) |
| 36 | |
| 37 | fun footer outf = TextIO.output (outf, "</div>\n<!--#include file=\"footer.html\" -->\n"); |
| 38 | |
| 39 | fun genMemberList () = |
| 40 | let |
| 41 | val outf = TextIO.openOut (outputDir ^ "members.shtml") |
| 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, ".shtml\">"); |
| 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 | |
| 63 | val _ = header (outf, "HCoop Member List") |
| 64 | val _ = TextIO.output (outf, "<table>\n") |
| 65 | val (total, anon) = C.fold db printOne (0, 0) |
| 66 | "SELECT name, rname, usr FROM WebUserPaying LEFT OUTER JOIN DirectoryPref ON id = usr ORDER BY name" |
| 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 |
| 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, ".shtml"]) |
| 92 | |
| 93 | val _ = header (outf, "HCoop Member: " ^ name) |
| 94 | val _ = TextIO.output (outf, "<p><a href=\"/members.shtml\">Return to members directory</a></p>\n\n"); |
| 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)) |
| 101 | val _ = TextIO.output (outf, "</td></tr>\n\n"); |
| 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 | | _ => |
| 135 | (TextIO.output (outf, "<tr> <td align=\"right\"><b>Locations</b>:</td> <td>"); |
| 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 | | _ => |
| 162 | (TextIO.output (outf, "<tr> <td><b>Hosted sites</b></td> </tr>\n"); |
| 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 | | _ => |
| 194 | (TextIO.output (outf, "<tr> <td><b>Contact information</b></td> </tr>\n"); |
| 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 |
| 204 | ignore (OS.Process.system ("/bin/rm " ^ outputDir ^ "member/*.shtml")); |
| 205 | C.app db doOne "SELECT id, name, rname, joined, usr FROM WebUserPaying LEFT OUTER JOIN DirectoryPref ON usr = id" |
| 206 | end |
| 207 | |
| 208 | fun genLocations () = |
| 209 | let |
| 210 | val outf = TextIO.openOut (outputDir ^ "locs.html") |
| 211 | |
| 212 | val _ = header (outf, "HCoop: Where members live") |
| 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 |
| 241 | C.fold db folder NM.empty "SELECT loc, usr FROM Lives JOIN WebUserActive ON id = usr" |
| 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 |
| 253 | case NM.find (res, id) of |
| 254 | NONE => () |
| 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")) |
| 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 |
| 276 | |
| 277 | fun genLinks () = |
| 278 | let |
| 279 | val outf = TextIO.openOut (outputDir ^ "sites.html") |
| 280 | |
| 281 | (* val _ = header (outf, "HCoop: Hosted sites") *) |
| 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", |
| 287 | " JOIN WebUserPaying ON WebUserPaying.id = usr", |
| 288 | " JOIN DirectoryPref ON WebUserPaying.id = DirectoryPref.usr", |
| 289 | " ORDER BY title"]) |
| 290 | |
| 291 | fun appLink (url, title, descr, name) = |
| 292 | (TextIO.output (outf, "<tr> <td><a href=\""); |
| 293 | TextIO.output (outf, Web.html url); |
| 294 | TextIO.output (outf, "\">"); |
| 295 | TextIO.output (outf, Web.html title); |
| 296 | TextIO.output (outf, "</a></td> <td>"); |
| 297 | TextIO.output (outf, Web.html descr); |
| 298 | TextIO.output (outf, "</td> <td><a href=\"member/"); |
| 299 | TextIO.output (outf, name); |
| 300 | TextIO.output (outf, ".shtml\">"); |
| 301 | TextIO.output (outf, name); |
| 302 | TextIO.output (outf, "</a></td> </tr>\n")) |
| 303 | in |
| 304 | (* TextIO.output (outf, "<table>\n"); *) |
| 305 | app appLink links; |
| 306 | (* footer outf; *) |
| 307 | TextIO.closeOut outf |
| 308 | end |
| 309 | in |
| 310 | genMemberList (); |
| 311 | genMemberPages (); |
| 312 | genLocations (); |
| 313 | genLinks (); |
| 314 | OS.Process.success |
| 315 | end |
| 316 | |
| 317 | fun main _ = (generate ()) |
| 318 | handle |
| 319 | C.Sql s => (print "SQL exception: \n"; |
| 320 | print s; |
| 321 | print "\n"; |
| 322 | OS.Process.failure) |
| 323 | | Fail s => (print "Fail: "; |
| 324 | print s; |
| 325 | print "\n"; |
| 326 | OS.Process.failure) |
| 327 | | IO.Io {name, function, ...} => (print "IO exception "; |
| 328 | print function; |
| 329 | print ": "; |
| 330 | print name; |
| 331 | print "\n"; |
| 332 | OS.Process.failure) |
| 333 | | ex => (print "Exception!\n"; |
| 334 | List.app (fn s => print (s ^ "\n")) (SMLofNJ.exnHistory ex); |
| 335 | OS.Process.failure) |
| 336 | |
| 337 | end |