structure Gen :> GEN =
struct
structure C = PgClient
structure IntKey = struct
type ord_key = int
val compare = Int.compare
end
structure NM = BinaryMapFn(IntKey)
val outputDir = "/var/www/dyn/"
fun generate () =
let
val db = C.conn "dbname='hcoop_hcoop'"
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) =
procOutput (outf, ("/usr/local/bin/hcoop_header", [title]))
fun footer outf =
procOutput (outf, ("/usr/local/bin/hcoop_footer", []))
fun genMemberList () =
let
val outf = TextIO.openOut (outputDir ^ "members.html")
fun printOne ([name, rname, usr], (total, anon)) =
let
val name = C.stringFromSql name
val rname = C.stringFromSql rname
val isAnon = C.isNull usr
in
if not isAnon then
(TextIO.output (outf, "
");
TextIO.output (outf, name);
TextIO.output (outf, " | ");
TextIO.output (outf, rname);
TextIO.output (outf, " |
\n"))
else
();
(total + 1, (if C.isNull usr then anon + 1 else anon))
end
| printOne _ = raise Fail "Bad printOne line"
val _ = header (outf, "HCoop Member List")
val _ = TextIO.output (outf, "\n")
val (total, anon) = C.fold db printOne (0, 0)
"SELECT name, rname, usr FROM WebUserPaying LEFT OUTER JOIN DirectoryPref ON id = usr ORDER BY name"
in
TextIO.output (outf, "
\n\nUnlisted members: ");
TextIO.output (outf, Int.toString anon);
TextIO.output (outf, " out of ");
TextIO.output (outf, Int.toString total);
TextIO.output (outf, " total.\n");
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, ".html"])
val _ = header (outf, "HCoop member: " ^ name)
val _ = TextIO.output (outf, "\n Member: | ")
val _ = TextIO.output (outf, name)
val _ = TextIO.output (outf, " |
\n Name: | ")
val _ = TextIO.output (outf, rname)
val _ = TextIO.output (outf, " |
\n Joined: | ")
val _ = TextIO.output (outf, Date.toString (Date.fromTimeLocal joined))
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, " |
\n\n Locations: | ");
app appLocation locations;
TextIO.output (outf, " |
\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, " | ");
TextIO.output (outf, Web.html title);
TextIO.output (outf, "");
if descr <> "" then
TextIO.output (outf, ": ")
else
();
TextIO.output (outf, Web.html descr);
TextIO.output (outf, " |
\n"))
val _ = case links of
[] => ()
| _ =>
(TextIO.output (outf, "
\n\n Hosted sites |
\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 ["", Web.html v, ""]
| NONE => v
in
TextIO.output (outf, " ");
TextIO.output (outf, Web.html name);
TextIO.output (outf, ": | \n");
TextIO.output (outf, link);
TextIO.output (outf, " |
\n")
end
val _ = case contacts of
[] => ()
| _ =>
(TextIO.output (outf, "
\n\n Contact information |
\n");
app appContact contacts)
in
TextIO.output (outf, "
\n");
footer outf;
TextIO.closeOut outf
end
end
| doOne _ = raise Fail "Bad member row"
in
ignore (OS.Process.system ("/bin/rm " ^ outputDir ^ "member/*.html"));
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"
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, " ");
TextIO.output (outf, Web.html name);
TextIO.output (outf, " (");
TextIO.output (outf, Int.toString n);
TextIO.output (outf, ")");
TextIO.output (outf, "\n\n");
locationTree (SOME id);
TextIO.output (outf, "
\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, " ");
TextIO.output (outf, Web.html title);
TextIO.output (outf, " | ");
TextIO.output (outf, Web.html descr);
TextIO.output (outf, " | ");
TextIO.output (outf, name);
TextIO.output (outf, " |
\n"))
in
TextIO.output (outf, "\n");
app appLink links;
footer outf;
TextIO.closeOut outf
end
in
genMemberList ();
genMemberPages ();
genLocations ();
genLinks ();
OS.Process.success
end
fun main _ = (generate ())
handle
C.Sql s => (print "SQL exception: \n";
print s;
OS.Process.failure)
| Fail s => (print "Fail: ";
print s;
OS.Process.failure)
| ex => (print "Exception!\n";
List.app (fn s => print (s ^ "\n")) (SMLofNJ.exnHistory ex);
OS.Process.failure)
end