[hcoop/zz_old/portal.git] / static / gen.sml

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 = "/home/hcoop/public_html/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, "<tr> <td><a href=\"member/");
			     TextIO.output (outf, name);
			     TextIO.output (outf, ".html\">");
			     TextIO.output (outf, name);
			     TextIO.output (outf, "</a></td> <td>");
			     TextIO.output (outf, rname);
			     TextIO.output (outf, "</td> </tr>\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, "<table>\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, "</table><br><br>\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, "<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))

				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> </tr>\n\n<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> </tr>\n\n<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> </tr>\n\n<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/*.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 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><b><a href=\"");
		     TextIO.output (outf, Web.html url);
		     TextIO.output (outf, "\">");
		     TextIO.output (outf, Web.html title);
		     TextIO.output (outf, "</a></b></td> <td>");
		     TextIO.output (outf, Web.html descr);
		     TextIO.output (outf, "</td> <td><a href=\"member/");
		     TextIO.output (outf, name);
		     TextIO.output (outf, ".html\">");
		     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
    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
Commit	Line	Data
566fd712	1	structure Gen :> GEN =
	2	struct
	3
	4	structure C = PgClient
	5
7b8746ef	6	structure IntKey = struct
	7	type ord_key = int
	8	val compare = Int.compare
	9	end
	10
	11	structure NM = BinaryMapFn(IntKey)
	12
cb855527	13	val outputDir = "/home/hcoop/public_html/dyn/"
566fd712	14
	15	fun generate () =
	16	let
646dca75	17	val db = C.conn "dbname='hcoop_hcoop'"
566fd712	18
1fe415e0	19	fun procOutput (outf, cmdline) =
	20	let
	21	val proc = Unix.execute cmdline
	22	val ins = Unix.textInstreamOf proc
	23
	24	fun loop () =
	25	case TextIO.inputLine ins of
	26	NONE => ()
	27	\| SOME s => (TextIO.output (outf, s); loop ())
	28	in
	29	loop ();
	30	ignore (Unix.reap proc)
	31	end
	32
566fd712	33	fun header (outf, title) =
1fe415e0	34	procOutput (outf, ("/usr/local/bin/hcoop_header", [title]))
566fd712	35
566fd712	36	fun footer outf =
1fe415e0	37	procOutput (outf, ("/usr/local/bin/hcoop_footer", []))
566fd712	38
	39	fun genMemberList () =
	40	let
	41	val outf = TextIO.openOut (outputDir ^ "members.html")
	42
	43	fun printOne ([name, rname, usr], (total, anon)) =
	44	let
	45	val name = C.stringFromSql name
	46	val rname = C.stringFromSql rname
	47	val isAnon = C.isNull usr
	48	in
	49	if not isAnon then
	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"))
	57	else
	58	();
	59	(total + 1, (if C.isNull usr then anon + 1 else anon))
	60	end
	61	\| printOne _ = raise Fail "Bad printOne line"
	62
1fe415e0	63	val _ = header (outf, "HCoop Member List")
566fd712	64	val _ = TextIO.output (outf, "<table>\n")
566fd712	65	val (total, anon) = C.fold db printOne (0, 0)
ea455810	66	"SELECT name, rname, usr FROM WebUserPaying LEFT OUTER JOIN DirectoryPref ON id = usr ORDER BY name"
566fd712	67	in
	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");
	73	footer outf;
	74	TextIO.closeOut outf
	75	end
7b8746ef	76
	77	fun genMemberPages () =
	78	let
	79	fun doOne [id, name, rname, joined, usr] =
	80	let
	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
	86	in
	87	if anon then
	88	()
	89	else
	90	let
	91	val outf = TextIO.openOut (String.concat [outputDir, "member/", name, ".html"])
	92
1fe415e0	93	val _ = header (outf, "HCoop member: " ^ name)
7b8746ef	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))
	100
	101	fun doLocation [id] = C.intFromSql id
	102	\| doLocation _ = raise Fail "Bad location row"
	103
	104	val locations = C.map db doLocation (String.concat ["SELECT id FROM Location JOIN Lives ON loc = id AND usr = ",
	105	Int.toString id])
	106
	107	fun printLocation id =
	108	let
	109	val (name, parent) =
	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"
	113	in
	114	case parent of
	115	NONE => ()
	116	\| SOME parent => (printLocation parent;
	117	TextIO.output (outf, " : "));
	118	TextIO.output (outf, name)
	119	end
	120
	121	val first = ref true
	122
	123	fun appLocation id =
	124	(if !first then
	125	first := false
	126	else
	127	TextIO.output (outf, ", ");
	128	printLocation id)
	129
	130	val _ = case locations of
	131	[] => ()
	132	\| _ =>
	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"))
	136
	137	fun doLink [url, title, descr] = (C.stringFromSql url, C.stringFromSql title, C.stringFromSql descr)
	138	\| doLink _ = raise Fail "Bad link row"
	139
	140	val links = C.map db doLink (String.concat ["SELECT url, title, descr FROM Link WHERE usr = ",
	141	Int.toString id,
	142	" ORDER BY title"])
	143
	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>");
	150	if descr <> "" then
	151	TextIO.output (outf, ": ")
	152	else
	153	();
	154	TextIO.output (outf, Web.html descr);
	155	TextIO.output (outf, "</td> </tr>\n"))
	156
	157	val _ = case links of
158	[] => ()
159	\| _ =>
160	(TextIO.output (outf, "<tr> </tr>\n\n<tr> <td><b>Hosted sites</b></td> </tr>\n");
161	app appLink links)
162
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"
167
168	val contacts = C.map db doContact (String.concat ["SELECT v, name, url, urlPrefix, urlPostfix",
169	" FROM Contact JOIN ContactKind ON knd = ContactKind.id",
170	" WHERE priv = 0",
171	" AND usr = ",
172	Int.toString id,
173	" ORDER BY name, v"])
174
175	fun appContact (v, name, url) =
176	let
177	val link =
178	case url of
179	SOME (pre, post) => String.concat ["<a href=\"", pre, Web.html v, post, "\">", Web.html v, "</a>"]
180	\| NONE => v
181	in
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")
187	end
188
189	val _ = case contacts of
190	[] => ()
191	\| _ =>
192	(TextIO.output (outf, "<tr> </tr>\n\n<tr> <td><b>Contact information</b></td> </tr>\n");
193	app appContact contacts)
194	in
195	TextIO.output (outf, "</table>\n");
196	footer outf;
197	TextIO.closeOut outf
198	end
199	end
200	\| doOne _ = raise Fail "Bad member row"
201	in
f98251aa	202	ignore (OS.Process.system ("/bin/rm " ^ outputDir ^ "member/*.html"));
ea455810	203	C.app db doOne "SELECT id, name, rname, joined, usr FROM WebUserPaying LEFT OUTER JOIN DirectoryPref ON usr = id"
7b8746ef	204	end
	205
	206	fun genLocations () =
	207	let
	208	val outf = TextIO.openOut (outputDir ^ "locs.html")
	209
1fe415e0	210	val _ = header (outf, "HCoop: Where members live")
7b8746ef	211
	212	fun countResidents () =
	213	let
	214	fun mkLivesRow [loc, usr] =
	215	{loc = C.intFromSql loc, usr = C.intFromSql usr}
	216	\| mkLivesRow row = raise Fail "Bad lives row"
	217
	218	fun folder (row, count) =
	219	let
	220	fun addToParents (id, count) =
	221	let
	222	val count = NM.insert (count, id, (case NM.find (count, id) of
	223	NONE => 1
	224	\| SOME n => n+1))
	225	in
	226	case C.oneRow db ("SELECT parent FROM Location WHERE id = " ^ C.intToSql id) of
	227	[p] => if C.isNull p then
	228	count
	229	else
	230	addToParents (C.intFromSql p, count)
	231	\| r => raise Fail "Bad addToParents row"
	232	end
	233
	234	val lives = mkLivesRow row
	235	in
	236	addToParents (#loc lives, count)
	237	end
	238	in
cb855527	239	C.fold db folder NM.empty "SELECT loc, usr FROM Lives JOIN WebUserActive ON id = usr"
7b8746ef	240	end
	241
	242	val res = countResidents ()
	243
	244	fun locationTree root =
	245	let
	246	fun doOne [id, name] =
	247	let
	248	val id = C.intFromSql id
	249	val name = C.stringFromSql name
	250	in
7b8746ef	251	case NM.find (res, id) of
7b8746ef	252	NONE => ()
6ad764f5	253	\| SOME n =>
	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"))
7b8746ef	262	end
	263	\| doOne _ = raise Fail "Bad locationTree row"
	264	in
	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),
	267	" ORDER BY name"])
	268	end
	269	in
	270	locationTree NONE;
	271	footer outf;
	272	TextIO.closeOut outf
	273	end
3bc39953	274
	275	fun genLinks () =
	276	let
	277	val outf = TextIO.openOut (outputDir ^ "sites.html")
	278
1fe415e0	279	val _ = header (outf, "HCoop: Hosted sites")
3bc39953	280
	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"
	283
	284	val links = C.map db doLink (String.concat ["SELECT url, title, descr, name FROM Link",
ea455810	285	" JOIN WebUserPaying ON WebUserPaying.id = usr",
ea455810	286	" JOIN DirectoryPref ON WebUserPaying.id = DirectoryPref.usr",
3bc39953	287	" ORDER BY title"])
	288
	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"))
	301	in
	302	TextIO.output (outf, "<table>\n");
	303	app appLink links;
	304	footer outf;
	305	TextIO.closeOut outf
	306	end
566fd712	307	in
566fd712	308	genMemberList ();
7b8746ef	309	genMemberPages ();
7b8746ef	310	genLocations ();
3bc39953	311	genLinks ();
566fd712	312	OS.Process.success
	313	end
	314
	315	fun main _ = (generate ())
7b8746ef	316	handle
	317	C.Sql s => (print "SQL exception: \n";
	318	print s;
	319	OS.Process.failure)
	320	\| Fail s => (print "Fail: ";
	321	print s;
	322	OS.Process.failure)
	323	\| ex => (print "Exception!\n";
	324	List.app (fn s => print (s ^ "\n")) (SMLofNJ.exnHistory ex);
566fd712	325	OS.Process.failure)
566fd712	326
646dca75	327	end