structure C = PgClient
-val outputDir = "/var/www/home/html/static/"
+structure IntKey = struct
+ type ord_key = int
+ val compare = Int.compare
+end
+
+structure NM = BinaryMapFn(IntKey)
+
+val outputDir = "/home/hcoop/public_html/"
fun generate () =
let
- val db = C.conn "dbname='hcoop'"
+ val db = C.conn "dbname='hcoop_hcoop' host='postgres'"
+
+ fun procOutput (outf, cmdline) =
+ let
+ val proc = Unix.execute cmdline
+ val ins = Unix.textInstreamOf proc
+
+ fun loop () =
+ case TextIO.inputLine ins of
+ NONE => ()
+ | SOME s => (TextIO.output (outf, s); loop ())
+ in
+ loop ();
+ ignore (Unix.reap proc)
+ end
fun header (outf, title) =
- (TextIO.output (outf, "<html><head>\n<title>");
- TextIO.output (outf, title);
- TextIO.output (outf, "</title></head>\n<body>\n<h2><b>");
- TextIO.output (outf, title);
- TextIO.output (outf, "</b></h2>\n"))
+ (TextIO.output (outf, "<!--#include file=\"header.html\" -->\n<div id=\"main\">");
+ TextIO.output (outf, "<h2>" ^ title ^ "</h2>\n"))
- fun footer outf =
- TextIO.output (outf, "\n</body></html>")
+ fun footer outf = TextIO.output (outf, "</div>\n<!--#include file=\"footer.html\" -->\n");
fun genMemberList () =
let
- val outf = TextIO.openOut (outputDir ^ "members.html")
+ val outf = TextIO.openOut (outputDir ^ "members.shtml")
fun printOne ([name, rname, usr], (total, anon)) =
let
if not isAnon then
(TextIO.output (outf, "<tr> <td><a href=\"member/");
TextIO.output (outf, name);
- TextIO.output (outf, ".html\">");
+ TextIO.output (outf, "\">");
TextIO.output (outf, name);
TextIO.output (outf, "</a></td> <td>");
TextIO.output (outf, rname);
end
| printOne _ = raise Fail "Bad printOne line"
- val _ = header (outf, "Member list")
+ val _ = header (outf, "HCoop Member List")
val _ = TextIO.output (outf, "<table>\n")
val (total, anon) = C.fold db printOne (0, 0)
- "SELECT name, rname, usr FROM WebUser LEFT OUTER JOIN DirectoryPref ON id = usr ORDER BY name"
+ "SELECT name, rname, usr FROM WebUserPaying LEFT OUTER JOIN DirectoryPref ON id = usr ORDER BY name"
in
TextIO.output (outf, "</table><br><br>\n\nUnlisted members: ");
TextIO.output (outf, Int.toString anon);
footer outf;
TextIO.closeOut outf
end
+
+ fun genMemberPages () =
+ let
+ fun doOne [id, name, rname, joined, usr] =
+ let
+ val id = C.intFromSql id
+ val name = C.stringFromSql name
+ val rname = C.stringFromSql rname
+ val joined = C.timestampFromSql joined
+ val anon = C.isNull usr
+ in
+ if anon then
+ ()
+ else
+ let
+ val outf = TextIO.openOut (String.concat [outputDir, "member/", name, ".shtml"])
+
+ val _ = header (outf, "HCoop Member: " ^ name)
+ val _ = TextIO.output (outf, "<p><a href=\"/members\">Return to members directory</a></p>\n\n");
+ val _ = TextIO.output (outf, "<table>\n<tr> <td align=\"right\"><b>Member</b>:</td> <td>")
+ val _ = TextIO.output (outf, name)
+ val _ = TextIO.output (outf, "</td> </tr>\n<tr> <td align=\"right\"><b>Name</b>:</td> <td>")
+ val _ = TextIO.output (outf, rname)
+ val _ = TextIO.output (outf, "</td> </tr>\n<tr> <td align=\"right\"><b>Joined</b>:</td> <td>")
+ val _ = TextIO.output (outf, Date.toString (Date.fromTimeLocal joined))
+ val _ = TextIO.output (outf, "</td></tr>\n\n");
+
+ fun doLocation [id] = C.intFromSql id
+ | doLocation _ = raise Fail "Bad location row"
+
+ val locations = C.map db doLocation (String.concat ["SELECT id FROM Location JOIN Lives ON loc = id AND usr = ",
+ Int.toString id])
+
+ fun printLocation id =
+ let
+ val (name, parent) =
+ case C.oneRow db ("SELECT name, parent FROM Location WHERE id = " ^ Int.toString id) of
+ [name, parent] => (C.stringFromSql name, if C.isNull parent then NONE else SOME (C.intFromSql parent))
+ | _ => raise Fail "Bad printLocation row"
+ in
+ case parent of
+ NONE => ()
+ | SOME parent => (printLocation parent;
+ TextIO.output (outf, " : "));
+ TextIO.output (outf, name)
+ end
+
+ val first = ref true
+
+ fun appLocation id =
+ (if !first then
+ first := false
+ else
+ TextIO.output (outf, ", ");
+ printLocation id)
+
+ val _ = case locations of
+ [] => ()
+ | _ =>
+ (TextIO.output (outf, "<tr> <td align=\"right\"><b>Locations</b>:</td> <td>");
+ app appLocation locations;
+ TextIO.output (outf, "</td> </tr>\n"))
+
+ fun doLink [url, title, descr] = (C.stringFromSql url, C.stringFromSql title, C.stringFromSql descr)
+ | doLink _ = raise Fail "Bad link row"
+
+ val links = C.map db doLink (String.concat ["SELECT url, title, descr FROM Link WHERE usr = ",
+ Int.toString id,
+ " ORDER BY title"])
+
+ fun appLink (url, title, descr) =
+ (TextIO.output (outf, "<tr> <td></td> <td><b><a href=\"");
+ TextIO.output (outf, Web.html url);
+ TextIO.output (outf, "\">");
+ TextIO.output (outf, Web.html title);
+ TextIO.output (outf, "</a></b>");
+ if descr <> "" then
+ TextIO.output (outf, ": ")
+ else
+ ();
+ TextIO.output (outf, Web.html descr);
+ TextIO.output (outf, "</td> </tr>\n"))
+
+ val _ = case links of
+ [] => ()
+ | _ =>
+ (TextIO.output (outf, "<tr> <td><b>Hosted sites</b></td> </tr>\n");
+ app appLink links)
+
+ fun doContact [v, name, url, urlPrefix, urlPostfix] =
+ (C.stringFromSql v, C.stringFromSql name,
+ if C.boolFromSql url then SOME (C.stringFromSql urlPrefix, C.stringFromSql urlPostfix) else NONE)
+ | doContact _ = raise Fail "Bad contact row"
+
+ val contacts = C.map db doContact (String.concat ["SELECT v, name, url, urlPrefix, urlPostfix",
+ " FROM Contact JOIN ContactKind ON knd = ContactKind.id",
+ " WHERE priv = 0",
+ " AND usr = ",
+ Int.toString id,
+ " ORDER BY name, v"])
+
+ fun appContact (v, name, url) =
+ let
+ val link =
+ case url of
+ SOME (pre, post) => String.concat ["<a href=\"", pre, Web.html v, post, "\">", Web.html v, "</a>"]
+ | NONE => v
+ in
+ TextIO.output (outf, "<tr> <td align=\"right\" valign=\"top\"><b>");
+ TextIO.output (outf, Web.html name);
+ TextIO.output (outf, "</b>:</td>\n<td>");
+ TextIO.output (outf, link);
+ TextIO.output (outf, "</td> </tr>\n")
+ end
+
+ val _ = case contacts of
+ [] => ()
+ | _ =>
+ (TextIO.output (outf, "<tr> <td><b>Contact information</b></td> </tr>\n");
+ app appContact contacts)
+ in
+ TextIO.output (outf, "</table>\n");
+ footer outf;
+ TextIO.closeOut outf
+ end
+ end
+ | doOne _ = raise Fail "Bad member row"
+ in
+ ignore (OS.Process.system ("/bin/rm " ^ outputDir ^ "member/*.shtml"));
+ C.app db doOne "SELECT id, name, rname, joined, usr FROM WebUserPaying LEFT OUTER JOIN DirectoryPref ON usr = id"
+ end
+
+ fun genLocations () =
+ let
+ val outf = TextIO.openOut (outputDir ^ "locs.html")
+
+ val _ = header (outf, "HCoop: Where members live")
+
+ fun countResidents () =
+ let
+ fun mkLivesRow [loc, usr] =
+ {loc = C.intFromSql loc, usr = C.intFromSql usr}
+ | mkLivesRow row = raise Fail "Bad lives row"
+
+ fun folder (row, count) =
+ let
+ fun addToParents (id, count) =
+ let
+ val count = NM.insert (count, id, (case NM.find (count, id) of
+ NONE => 1
+ | SOME n => n+1))
+ in
+ case C.oneRow db ("SELECT parent FROM Location WHERE id = " ^ C.intToSql id) of
+ [p] => if C.isNull p then
+ count
+ else
+ addToParents (C.intFromSql p, count)
+ | r => raise Fail "Bad addToParents row"
+ end
+
+ val lives = mkLivesRow row
+ in
+ addToParents (#loc lives, count)
+ end
+ in
+ C.fold db folder NM.empty "SELECT loc, usr FROM Lives JOIN WebUserActive ON id = usr"
+ end
+
+ val res = countResidents ()
+
+ fun locationTree root =
+ let
+ fun doOne [id, name] =
+ let
+ val id = C.intFromSql id
+ val name = C.stringFromSql name
+ in
+ case NM.find (res, id) of
+ NONE => ()
+ | SOME n =>
+ (TextIO.output (outf, "<li> ");
+ TextIO.output (outf, Web.html name);
+ TextIO.output (outf, " (");
+ TextIO.output (outf, Int.toString n);
+ TextIO.output (outf, ")");
+ TextIO.output (outf, "</li>\n<ul>\n");
+ locationTree (SOME id);
+ TextIO.output (outf, "</ul>\n"))
+ end
+ | doOne _ = raise Fail "Bad locationTree row"
+ in
+ C.app db doOne (String.concat ["SELECT id, name FROM Location WHERE parent ",
+ (case root of NONE => "IS NULL" | SOME p => "= " ^ Int.toString p),
+ " ORDER BY name"])
+ end
+ in
+ locationTree NONE;
+ footer outf;
+ TextIO.closeOut outf
+ end
+
+ fun genLinks () =
+ let
+ val outf = TextIO.openOut (outputDir ^ "sites.html")
+
+ (* val _ = header (outf, "HCoop: Hosted sites") *)
+
+ fun doLink [url, title, descr, name] = (C.stringFromSql url, C.stringFromSql title, C.stringFromSql descr, C.stringFromSql name)
+ | doLink _ = raise Fail "Bad link' row"
+
+ val links = C.map db doLink (String.concat ["SELECT url, title, descr, name FROM Link",
+ " JOIN WebUserPaying ON WebUserPaying.id = usr",
+ " JOIN DirectoryPref ON WebUserPaying.id = DirectoryPref.usr",
+ " ORDER BY title"])
+
+ fun appLink (url, title, descr, name) =
+ (TextIO.output (outf, "<tr> <td><a href=\"");
+ TextIO.output (outf, Web.html url);
+ TextIO.output (outf, "\">");
+ TextIO.output (outf, Web.html title);
+ TextIO.output (outf, "</a></td> <td>");
+ TextIO.output (outf, Web.html descr);
+ TextIO.output (outf, "</td> <td><a href=\"member/");
+ TextIO.output (outf, name);
+ TextIO.output (outf, "\">");
+ TextIO.output (outf, name);
+ TextIO.output (outf, "</a></td> </tr>\n"))
+ in
+ (* TextIO.output (outf, "<table>\n"); *)
+ app appLink links;
+ (* footer outf; *)
+ TextIO.closeOut outf
+ end
in
genMemberList ();
+ genMemberPages ();
+ genLocations ();
+ genLinks ();
OS.Process.success
end
fun main _ = (generate ())
- handle ex => (print "Exception!\n";
+ handle
+ C.Sql s => (print "SQL exception: \n";
+ print s;
+ print "\n";
+ OS.Process.failure)
+ | Fail s => (print "Fail: ";
+ print s;
+ print "\n";
+ OS.Process.failure)
+ | IO.Io {name, function, ...} => (print "IO exception ";
+ print function;
+ print ": ";
+ print name;
+ print "\n";
+ OS.Process.failure)
+ | ex => (print "Exception!\n";
+ List.app (fn s => print (s ^ "\n")) (SMLofNJ.exnHistory ex);
OS.Process.failure)
-end
\ No newline at end of file
+end
HCoop / hcoop / portal.git / blobdiff