6 structure IntKey
= struct
8 val compare
= Int.compare
11 structure NM
= BinaryMapFn(IntKey
)
13 val outputDir
= "/home/hcoop/public_html/dyn/"
17 val db
= C
.conn
"dbname='hcoop_hcoop'"
19 fun procOutput (outf
, cmdline
) =
21 val proc
= Unix
.execute cmdline
22 val ins
= Unix
.textInstreamOf proc
25 case TextIO.inputLine ins
of
27 | SOME s
=> (TextIO.output (outf
, s
); loop ())
30 ignore (Unix
.reap proc
)
33 fun header (outf
, title
) =
34 procOutput (outf
, ("/usr/local/bin/hcoop_header", [title
]))
37 procOutput (outf
, ("/usr/local/bin/hcoop_footer", []))
39 fun genMemberList () =
41 val outf
= TextIO.openOut (outputDir ^
"members.html")
43 fun printOne ([name
, rname
, usr
], (total
, anon
)) =
45 val name
= C
.stringFromSql name
46 val rname
= C
.stringFromSql rname
47 val isAnon
= C
.isNull usr
50 (TextIO.output (outf
, "<tr> <td><a href=\"member/");
51 TextIO.output (outf
, name
);
52 TextIO.output (outf
, ".html\">");
53 TextIO.output (outf
, name
);
54 TextIO.output (outf
, "</a></td> <td>");
55 TextIO.output (outf
, rname
);
56 TextIO.output (outf
, "</td> </tr>\n"))
59 (total
+ 1, (if C
.isNull usr
then anon
+ 1 else anon
))
61 | printOne _
= raise Fail
"Bad printOne line"
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"
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");
77 fun genMemberPages () =
79 fun doOne
[id
, name
, rname
, joined
, usr
] =
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
91 val outf
= TextIO.openOut (String.concat
[outputDir
, "member/", name
, ".html"])
93 val _
= header (outf
, "HCoop member: " ^ name
)
94 val _
= TextIO.output (outf
, "<table>\n<tr> <td align=\"right\"><b>Member</b>:</td> <td>")
95 val _
= TextIO.output (outf
, name
)
96 val _
= TextIO.output (outf
, "</td> </tr>\n<tr> <td align=\"right\"><b>Name</b>:</td> <td>")
97 val _
= TextIO.output (outf
, rname
)
98 val _
= TextIO.output (outf
, "</td> </tr>\n<tr> <td align=\"right\"><b>Joined</b>:</td> <td>")
99 val _
= TextIO.output (outf
, Date
.toString (Date
.fromTimeLocal joined
))
101 fun doLocation
[id
] = C
.intFromSql id
102 | doLocation _
= raise Fail
"Bad location row"
104 val locations
= C
.map db
doLocation (String.concat
["SELECT id FROM Location JOIN Lives ON loc = id AND usr = ",
107 fun printLocation id
=
110 case C
.oneRow
db ("SELECT name, parent FROM Location WHERE id = " ^
Int.toString id
) of
111 [name
, parent
] => (C
.stringFromSql name
, if C
.isNull parent
then NONE
else SOME (C
.intFromSql parent
))
112 | _
=> raise Fail
"Bad printLocation row"
116 | SOME parent
=> (printLocation parent
;
117 TextIO.output (outf
, " : "));
118 TextIO.output (outf
, name
)
127 TextIO.output (outf
, ", ");
130 val _
= case locations
of
133 (TextIO.output (outf
, "<tr> </tr>\n\n<tr> <td align=\"right\"><b>Locations</b>:</td> <td>");
134 app appLocation locations
;
135 TextIO.output (outf
, "</td> </tr>\n"))
137 fun doLink
[url
, title
, descr
] = (C
.stringFromSql url
, C
.stringFromSql title
, C
.stringFromSql descr
)
138 | doLink _
= raise Fail
"Bad link row"
140 val links
= C
.map db
doLink (String.concat
["SELECT url, title, descr FROM Link WHERE usr = ",
144 fun appLink (url
, title
, descr
) =
145 (TextIO.output (outf
, "<tr> <td></td> <td><b><a href=\"");
146 TextIO.output (outf
, Web
.html url
);
147 TextIO.output (outf
, "\">");
148 TextIO.output (outf
, Web
.html title
);
149 TextIO.output (outf
, "</a></b>");
151 TextIO.output (outf
, ": ")
154 TextIO.output (outf
, Web
.html descr
);
155 TextIO.output (outf
, "</td> </tr>\n"))
157 val _
= case links
of
160 (TextIO.output (outf
, "<tr> </tr>\n\n<tr> <td><b>Hosted sites</b></td> </tr>\n");
163 fun doContact
[v
, name
, url
, urlPrefix
, urlPostfix
] =
164 (C
.stringFromSql v
, C
.stringFromSql name
,
165 if C
.boolFromSql url
then SOME (C
.stringFromSql urlPrefix
, C
.stringFromSql urlPostfix
) else NONE
)
166 | doContact _
= raise Fail
"Bad contact row"
168 val contacts
= C
.map db
doContact (String.concat
["SELECT v, name, url, urlPrefix, urlPostfix",
169 " FROM Contact JOIN ContactKind ON knd = ContactKind.id",
173 " ORDER BY name, v"])
175 fun appContact (v
, name
, url
) =
179 SOME (pre
, post
) => String.concat
["<a href=\"", pre
, Web
.html v
, post
, "\">", Web
.html v
, "</a>"]
182 TextIO.output (outf
, "<tr> <td align=\"right\" valign=\"top\"><b>");
183 TextIO.output (outf
, Web
.html name
);
184 TextIO.output (outf
, "</b>:</td>\n<td>");
185 TextIO.output (outf
, link
);
186 TextIO.output (outf
, "</td> </tr>\n")
189 val _
= case contacts
of
192 (TextIO.output (outf
, "<tr> </tr>\n\n<tr> <td><b>Contact information</b></td> </tr>\n");
193 app appContact contacts
)
195 TextIO.output (outf
, "</table>\n");
200 | doOne _
= raise Fail
"Bad member row"
202 ignore (OS
.Process
.system ("/bin/rm " ^ outputDir ^
"member/*.html"));
203 C
.app db doOne
"SELECT id, name, rname, joined, usr FROM WebUserPaying LEFT OUTER JOIN DirectoryPref ON usr = id"
206 fun genLocations () =
208 val outf
= TextIO.openOut (outputDir ^
"locs.html")
210 val _
= header (outf
, "HCoop: Where members live")
212 fun countResidents () =
214 fun mkLivesRow
[loc
, usr
] =
215 {loc
= C
.intFromSql loc
, usr
= C
.intFromSql usr
}
216 | mkLivesRow row
= raise Fail
"Bad lives row"
218 fun folder (row
, count
) =
220 fun addToParents (id
, count
) =
222 val count
= NM
.insert (count
, id
, (case NM
.find (count
, id
) of
226 case C
.oneRow
db ("SELECT parent FROM Location WHERE id = " ^ C
.intToSql id
) of
227 [p
] => if C
.isNull p
then
230 addToParents (C
.intFromSql p
, count
)
231 | r
=> raise Fail
"Bad addToParents row"
234 val lives
= mkLivesRow row
236 addToParents (#loc lives
, count
)
239 C
.fold db folder NM
.empty
"SELECT loc, usr FROM Lives JOIN WebUserActive ON id = usr"
242 val res
= countResidents ()
244 fun locationTree root
=
246 fun doOne
[id
, name
] =
248 val id
= C
.intFromSql id
249 val name
= C
.stringFromSql name
251 case NM
.find (res
, id
) of
254 (TextIO.output (outf
, "<li> ");
255 TextIO.output (outf
, Web
.html name
);
256 TextIO.output (outf
, " (");
257 TextIO.output (outf
, Int.toString n
);
258 TextIO.output (outf
, ")");
259 TextIO.output (outf
, "</li>\n<ul>\n");
260 locationTree (SOME id
);
261 TextIO.output (outf
, "</ul>\n"))
263 | doOne _
= raise Fail
"Bad locationTree row"
265 C
.app db
doOne (String.concat
["SELECT id, name FROM Location WHERE parent ",
266 (case root
of NONE
=> "IS NULL" | SOME p
=> "= " ^
Int.toString p
),
277 val outf
= TextIO.openOut (outputDir ^
"sites.html")
279 val _
= header (outf
, "HCoop: Hosted sites")
281 fun doLink
[url
, title
, descr
, name
] = (C
.stringFromSql url
, C
.stringFromSql title
, C
.stringFromSql descr
, C
.stringFromSql name
)
282 | doLink _
= raise Fail
"Bad link' row"
284 val links
= C
.map db
doLink (String.concat
["SELECT url, title, descr, name FROM Link",
285 " JOIN WebUserPaying ON WebUserPaying.id = usr",
286 " JOIN DirectoryPref ON WebUserPaying.id = DirectoryPref.usr",
289 fun appLink (url
, title
, descr
, name
) =
290 (TextIO.output (outf
, "<tr> <td><b><a href=\"");
291 TextIO.output (outf
, Web
.html url
);
292 TextIO.output (outf
, "\">");
293 TextIO.output (outf
, Web
.html title
);
294 TextIO.output (outf
, "</a></b></td> <td>");
295 TextIO.output (outf
, Web
.html descr
);
296 TextIO.output (outf
, "</td> <td><a href=\"member/");
297 TextIO.output (outf
, name
);
298 TextIO.output (outf
, ".html\">");
299 TextIO.output (outf
, name
);
300 TextIO.output (outf
, "</a></td> </tr>\n"))
302 TextIO.output (outf
, "<table>\n");
315 fun main _
= (generate ())
317 C
.Sql s
=> (print
"SQL exception: \n";
320 | Fail s
=> (print
"Fail: ";
323 | ex
=> (print
"Exception!\n";
324 List.app (fn s
=> print (s ^
"\n")) (SMLofNJ
.exnHistory ex
);