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/home/html/static/"
  14
  15 fun generate () =
  16     let
  17         val db = C.conn "dbname='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 WebUser 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                 C.app db doOne "SELECT id, name, rname, joined, usr FROM WebUser LEFT OUTER JOIN DirectoryPref ON usr = id"
 193             end
 194
 195         fun genLocations () =
 196             let
 197                 val outf = TextIO.openOut (outputDir ^ "locs.html")
 198
 199                 val _ = header (outf, "Where members live")
 200
 201                 fun countResidents () =
 202                     let
 203                         fun mkLivesRow [loc, usr] =
 204                             {loc = C.intFromSql loc, usr = C.intFromSql usr}
 205                           | mkLivesRow row = raise Fail "Bad lives row"
 206
 207                         fun folder (row, count) =
 208                             let
 209                                 fun addToParents (id, count) =
 210                                     let
 211                                         val count = NM.insert (count, id, (case NM.find (count, id) of
 212                                                                                NONE => 1
 213                                                                              | SOME n => n+1))
 214                                     in
 215                                         case C.oneRow db ("SELECT parent FROM Location WHERE id = " ^ C.intToSql id) of
 216                                             [p] => if C.isNull p then
 217                                                        count
 218                                                    else
 219                                                        addToParents (C.intFromSql p, count)
 220                                           | r => raise Fail "Bad addToParents row"
 221                                     end
 222
 223                                 val lives = mkLivesRow row
 224                             in
 225                                 addToParents (#loc lives, count)
 226                             end
 227                     in
 228                         C.fold db folder NM.empty "SELECT loc, usr FROM Lives"
 229                     end
 230
 231                 val res = countResidents ()
 232
 233                 fun locationTree root =
 234                     let
 235                         fun doOne [id, name] =
 236                             let
 237                                 val id = C.intFromSql id
 238                                 val name = C.stringFromSql name
 239                             in
 240                                 TextIO.output (outf, "<li> ");
 241                                 TextIO.output (outf, Web.html name);
 242                                 case NM.find (res, id) of
 243                                     NONE => ()
 244                                   | SOME n => (TextIO.output (outf, " (");
 245                                                TextIO.output (outf, Int.toString n);
 246                                                TextIO.output (outf, ")"));
 247                                 TextIO.output (outf, "</li>\n<ul>\n");
 248                                 locationTree (SOME id);
 249                                 TextIO.output (outf, "</ul>\n")
 250                             end
 251                           | doOne _ = raise Fail "Bad locationTree row"
 252                     in
 253                         C.app db doOne (String.concat ["SELECT id, name FROM Location WHERE parent ",
 254                                                        (case root of NONE => "IS NULL" | SOME p => "= " ^ Int.toString p),
 255                                                        " ORDER BY name"])
 256                     end
 257             in
 258                 locationTree NONE;
 259                 footer outf;
 260                 TextIO.closeOut outf
 261             end
 262     in
 263         genMemberList ();
 264         genMemberPages ();
 265         genLocations ();
 266         OS.Process.success
 267     end
 268
 269 fun main _ = (generate ())
 270     handle
 271     C.Sql s => (print "SQL exception: \n";
 272                 print s;
 273                 OS.Process.failure)
 274   | Fail s => (print "Fail: ";
 275                print s;
 276                OS.Process.failure)
 277   | ex => (print "Exception!\n";
 278                   List.app (fn s => print (s ^ "\n")) (SMLofNJ.exnHistory ex);
 279                   OS.Process.failure)
 280
 281 end