static/gen.sml

   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 = "/afs/hcoop.net/user/h/hc/hcoop/public_html/"
  14
  15 fun generate () =
  16     let
  17         val db = C.conn Config.dbstring
  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, "\">");
  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\">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, "\">");
 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