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 = "/var/www/dyn/"
  14
  15 fun generate () =
  16     let
  17         val db = C.conn "dbname='hcoop_hcoop'"
  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)
  56                                            "SELECT name, rname, usr FROM WebUserPaying LEFT OUTER JOIN DirectoryPref ON id = usr ORDER BY name"
  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
  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
 192                 ignore (OS.Process.system ("/bin/rm " ^ outputDir ^ "member/*.html"));
 193                 C.app db doOne "SELECT id, name, rname, joined, usr FROM WebUserPaying LEFT OUTER JOIN DirectoryPref ON usr = id"
 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
 241                                 case NM.find (res, id) of
 242                                     NONE => ()
 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"))
 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
 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",
 275                                                             " JOIN WebUserPaying ON WebUserPaying.id = usr",
 276                                                             " JOIN DirectoryPref ON WebUserPaying.id = DirectoryPref.usr",
 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
 297     in
 298         genMemberList ();
 299         genMemberPages ();
 300         genLocations ();
 301         genLinks ();
 302         OS.Process.success
 303     end
 304
 305 fun main _ = (generate ())
 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);
 315                   OS.Process.failure)
 316
 317 end