Member data
- - Geographic location
- Hosted web site registry
- Summarize these with publicly accessible static pages
in
(case C.oneOrNoRows c ($`SELECT COUNT( * )
FROM Membership
- WHERE grp = ^(C.intToSql grp)
+ WHERE (grp IN (0, ^(C.intToSql grp)))
AND usr = ^(C.intToSql usr)`) of
SOME[x] => not (C.isNull x) andalso C.intFromSql x <> 0
| _ => false)
in
(case C.oneOrNoRows c ($`SELECT COUNT( * )
FROM Membership, WebGroup
- WHERE name = ^(C.stringToSql grp)
- AND usr = ^(C.intToSql usr)
- AND grp = id`) of
+ WHERE (id = 0 OR (name = ^(C.stringToSql grp) AND grp = id))
+ AND usr = ^(C.intToSql usr)`) of
SOME[x] => not (C.isNull x) andalso C.intFromSql x <> 0
| _ => false)
end
<table>
<% foreach group in Group.listGroups () do %>
- <tr> <td><% Web.html (#name group) %>
(#<% #id group %>)</td> <td></td> <td><a href="groups?mod=<% #id group %>">[Modify]</a> <a href="groups?del=<% #id group %>">[Delete]</a></td> </tr>
+ <tr> <td><% Web.html (#name group) %></td> <td></td> <td><a href="groups?mod=<% #id group %>">[Modify]</a> <a href="groups?del=<% #id group %>">[Delete]</a></td> </tr>
<% foreach user in Group.groupMembers (#id group) do %>
<tr> <td></td> <td><a href="user?id=<% #id user %>"><% Web.html (#name user) %></a></td> <td><a href="groups?revoke=<% #id user %>&grp=<% #id group %>">[Revoke]</a></td> </tr>
<% end
--- /dev/null
+<% @header[("title", ["Member locations"])];
+
+val admin = Group.inGroupName "location";
+
+ref showNormal = true;
+
+if $"cmd" = "add" then
+ val parent = (case $"parent" of "" => NONE | parent => SOME (Web.stoi parent));
+ val name = $"name";
+
+ if Location.alreadyExists (parent, name) then
+ %><h3><b>That location already exists!</b></h3><%
+ else
+ val id = Location.addLocation (parent, $"name")
+ %><h3><b>Location added</b></h3>
+<% end
+
+elseif $"mod" <> "" then
+ Group.requireGroupName "location";
+ showNormal := false;
+ val id = Web.stoi ($"mod");
+ val loc = Location.lookupLocation id %>
+
+<h3><b>Modify a location</b></h3>
+
+<form action="location">
+<input type="hidden" name="save" value="<% id %>">
+<table>
+<tr> <td align="right"><b>Parent</b>:</td> <td><select name="parent">
+ <option value=""<% if #parent loc = NONE then %> selected<% end %>><None></option>
+<% ref indent = 0;
+foreach item in Location.locationTree (NONE, NONE) do
+ switch item of
+ Util.BEGIN =>
+ indent := indent + 1 %>
+ <ul>
+<% | Util.END =>
+ indent := indent - 1 %>
+ </ul>
+<% | Util.ITEM loc2 => %>
+ <option value="<% #id loc2 %>"<% if SOME (#id loc2) = #parent loc then %> selected<% end %>><% for i in 1 .. indent do %>-<% end %><% Web.html (#name loc2) %></option>
+<% end
+end %>
+</select></td> </tr>
+<tr> <td align="right"><b>Name</b>:</td> <td><input name="name" value="<% Web.html (#name loc) %>"></td> </tr>
+<tr> <td><input type="submit" value="Save"></td> </tr>
+</table>
+</form>
+
+<% elseif $"save" <> "" then
+ Group.requireGroupName "location";
+ val id = Web.stoi ($"save");
+ val loc = Location.lookupLocation id;
+ Location.modLocation {loc with parent = (case $"parent" of "" => NONE | parent => SOME (Web.stoi parent)),
+ name = $"name"};
+ %><h3><b>Location saved</b></h3>
+
+<% elseif $"del" <> "" then
+ Group.requireGroupName "location";
+ showNormal := false;
+ val id = Web.stoi ($"del");
+ val loc = Location.lookupLocation id %>
+ <h3><b>Are you sure you want to delete "<% Web.html (#name loc) %>"?</b></h3>
+ <a href="location?del2=<% id %>">Yes, delete "<% Web.html (#name loc) %>"!</a>
+
+<% elseif $"del2" <> "" then
+ Group.requireGroupName "location";
+ val id = Web.stoi ($"del2");
+ val loc = Location.lookupLocation id;
+ Location.deleteLocation id %>
+ <h3><b>Deleted location "<% Web.html (#name loc) %>"</b></h3>
+
+<% elseif $"addLoc" <> "" then
+ Location.addToLocation {loc = Web.stoi ($"addLoc"), usr = Init.getUserId ()}
+ %><h3><b>Added</b></h3>
+
+<% elseif $"remLoc" <> "" then
+ Location.removeFromLocation {loc = Web.stoi ($"remLoc"), usr = Init.getUserId ()}
+ %><h3><b>Removed</b></h3>
+
+<% elseif $"id" <> "" then
+ showNormal := false;
+ val id = Web.stoi ($"id");
+ val loc = Location.lookupLocation id %>
+
+<h2><b><% Web.html (#name loc) %></b></h2>
+
+<% switch #parent loc of
+ SOME par =>
+ val ploc = Location.lookupLocation par;
+ %><b>Parent</b>: <a href="location?id=<% par %>"><% Web.html (#name ploc) %></a><%
+end %>
+
+<h3><b>Residents:</b></h3>
+<% ref first = true;
+foreach user in Location.residents id do
+ if first then
+ first := false
+ else
+ %>, <%
+ end;
+ %><a href="user?id=<% #id user %>"><% #name user %></a><%
+end %>
+
+<h3><b>Regions:</b></h3>
+<% foreach loc in Location.subLocations (SOME id) do %>
+ <a href="location?id=<% #id loc %>"><% Web.html (#name loc) %></a><br>
+<% end;
+
+end;
+
+if showNormal then %>
+<ul>
+<% foreach item in Location.locationTreeWithCounts (NONE, NONE) do
+ switch item of
+ Util.BEGIN => %>
+ <ul>
+<% | Util.END => %>
+ </ul>
+<% | Util.ITEM (num, loc) => %>
+ <li> <a href="location?id=<% #id loc %>"><% Web.html (#name loc) %></a> (<% num %>)
+<a href="location?mod=<% #id loc %>">[Modify]</a> <a href="location?del=<% #id loc %>">[Delete]</a></li>
+<% end
+end %>
+</ul>
+
+<h3><b>Add a new location</b></h3>
+
+<form action="location">
+<input type="hidden" name="cmd" value="add">
+<table>
+<tr> <td align="right"><b>Parent</b>:</td> <td><select name="parent">
+ <option value=""><None></option>
+<% ref indent = 0;
+foreach item in Location.locationTree (NONE, NONE) do
+ switch item of
+ Util.BEGIN =>
+ indent := indent + 1 %>
+ <ul>
+<% | Util.END =>
+ indent := indent - 1 %>
+ </ul>
+<% | Util.ITEM loc => %>
+ <option value="<% #id loc %>"><% for i in 1 .. indent do %>-<% end %><% Web.html (#name loc) %></option>
+<% end
+end %>
+</select></td> </tr>
+<tr> <td align="right"><b>Name</b>:</td> <td><input name="name"></td> </tr>
+<tr> <td><input type="submit" value="Add"></td> </tr>
+</table>
+</form>
+
+<% val withUser = Location.locationTreeWithUser (NONE, NONE, Init.getUserId ()) %>
+
+<h3><b>Add yourself to a location</b></h3>
+
+Adding yourself to a location automatically adds you to all more general loations.
+
+<form action="location">
+<select name="addLoc">
+<% ref indent = 0;
+foreach item in withUser do
+ switch item of
+ Util.BEGIN =>
+ indent := indent + 1 %>
+ <ul>
+<% | Util.END =>
+ indent := indent - 1 %>
+ </ul>
+<% | Util.ITEM (true, _) =>
+ | Util.ITEM (false, loc) => %>
+ <option value="<% #id loc %>"><% for i in 1 .. indent do %>-<% end %><% Web.html (#name loc) %></option>
+<% end
+end %>
+</select> <input type="submit" value="Add">
+</form>
+
+<h3><b>Remove yourself from a location</b></h3>
+
+<form action="location">
+<select name="remLoc">
+<% ref indent = 0;
+foreach item in withUser do
+ switch item of
+ Util.BEGIN =>
+ indent := indent + 1 %>
+ <ul>
+<% | Util.END =>
+ indent := indent - 1 %>
+ </ul>
+<% | Util.ITEM (false, _) =>
+ | Util.ITEM (true, loc) => %>
+ <option value="<% #id loc %>"><% for i in 1 .. indent do %>-<% end %><% Web.html (#name loc) %></option>
+<% end
+end %>
+</select> <input type="submit" value="Remove">
+</form>
+
+
+<% end %>
+
+<% @footer[] %>
\ No newline at end of file
--- /dev/null
+signature LOCATION =
+sig
+ type location = {id : int, parent : int option, name : string}
+ type lives = {usr : int, loc : int}
+
+ val addLocation : int option * string -> int
+ val lookupLocation : int -> location
+ val modLocation : location -> unit
+ val deleteLocation : int -> unit
+
+ val locationTree : int option * int option -> location Util.flat_tree
+ val locationTreeWithUser : int option * int option * int -> (bool * location) Util.flat_tree
+ val locationTreeWithCounts : int option * int option -> (int * location) Util.flat_tree
+
+ val livesIn : int * int -> bool
+ val addToLocation : lives -> unit
+ val removeFromLocation : lives -> unit
+
+ val alreadyExists : int option * string -> bool
+
+ val residents : int -> Init.user list
+ val residentsOneLevel : int -> Init.user list
+ val userLocations : int -> location list
+ val subLocations : int option -> location list
+end
\ No newline at end of file
--- /dev/null
+structure Location :> LOCATION =
+struct
+
+open Util Sql Init
+
+
+(* Managing locations *)
+
+type location = {id : int, parent : int option, name : string}
+
+fun intOptFromSql v =
+ if C.isNull v then
+ NONE
+ else
+ SOME (C.intFromSql v)
+
+fun mkLocationRow [id, parent, name] =
+ {id = C.intFromSql id,
+ parent = intOptFromSql parent,
+ name = C.stringFromSql name}
+ | mkLocationRow row = Init.rowError ("location", row)
+
+val intOptToSql =
+ fn NONE => "NULL"
+ | SOME n => C.intToSql n
+
+val intOptToSqlCompare =
+ fn NONE => "IS NULL"
+ | SOME n => "= " ^ C.intToSql n
+
+fun addLocation (parent, name) =
+ let
+ val db = getDb ()
+ val id = nextSeq (db, "LocationSeq")
+ in
+ C.dml db ($`INSERT INTO Location (id, parent, name)
+ VALUES (^(C.intToSql id), ^(intOptToSql parent), ^(C.stringToSql name))`);
+ id
+ end
+
+fun lookupLocation id =
+ let
+ val c = getDb ()
+ in
+ (case C.oneOrNoRows c ($`SELECT id, parent, name FROM Location WHERE id = ^(C.intToSql id)`) of
+ NONE => raise Fail "Location not found"
+ | SOME r => mkLocationRow r)
+ end
+
+fun modLocation (loc : location) =
+ let
+ val db = getDb ()
+ in
+ ignore (C.dml db ($`UPDATE Location
+ SET parent = ^(intOptToSql (#parent loc)), name = ^(C.stringToSql (#name loc))
+ WHERE id = ^(C.intToSql (#id loc))`))
+ end
+
+fun deleteLocation id =
+ ignore (C.dml (getDb ()) ($`DELETE FROM Location WHERE id = ^(C.intToSql id)`))
+
+structure IntKey = struct
+ type ord_key = int
+ val compare = Int.compare
+end
+
+structure NM = BinaryMapFn(IntKey)
+
+structure UserKey = struct
+ type ord_key = Init.user
+ fun compare (u1 : ord_key, u2 : ord_key) = String.compare (#name u1, #name u2)
+end
+
+structure US = BinarySetFn(UserKey)
+
+fun mkLivesRow [loc, usr] =
+ {loc = C.intFromSql loc, usr = C.intFromSql usr}
+ | mkLivesRow row = Init.rowError ("lives", row)
+
+fun countResidents () =
+ let
+ val db = getDb ()
+
+ 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 => Init.rowError ("Location.addToParents", r)
+ end
+
+ val lives = mkLivesRow row
+ in
+ addToParents (#loc lives, count)
+ end
+ in
+ C.fold db folder NM.empty ($`SELECT loc, usr FROM Lives`)
+ end
+
+fun recordResidents () =
+ let
+ val db = getDb ()
+
+ fun mkRow row =
+ case row of
+ loc :: rest => (C.intFromSql loc, mkUserRow rest)
+ | _ => Init.rowError ("recordResidents.mkRow", row)
+
+ fun folder (row, count) =
+ let
+ val (loc, user) = mkRow row
+
+ fun addToParents (id, count) =
+ let
+ val count = NM.insert (count, id, (case NM.find (count, id) of
+ NONE => US.singleton user
+ | SOME ns => US.add (ns, user)))
+ 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 => Init.rowError ("Location.addToParents'", r)
+ end
+ in
+ addToParents (loc, count)
+ end
+ in
+ C.fold db folder NM.empty ($`SELECT loc, id, name, rname, bal, joined
+ FROM Lives JOIN WebUser ON usr = id`)
+ end
+
+fun residents loc =
+ let
+ val res = recordResidents ()
+ in
+ case NM.find (res, loc) of
+ NONE => []
+ | SOME us => US.foldr (op ::) [] us
+ end
+
+fun locationTree (root, lim) =
+ let
+ val db = getDb ()
+
+ fun locationTree' (root, lim, acc) =
+ let
+ fun folder (row, acc) =
+ let
+ val loc = mkLocationRow row
+ in
+ case lim of
+ SOME 0 => Util.ITEM loc :: acc
+ | _ =>
+ let
+ val dec = case lim of
+ SOME n => SOME (n-1)
+ | NONE => NONE
+ in
+ Util.ITEM loc :: Util.BEGIN :: locationTree' (SOME (#id loc), dec, Util.END :: acc)
+ end
+ end
+ in
+ C.fold db folder acc ($`SELECT id, parent, name FROM Location
+ WHERE parent ^(intOptToSqlCompare root)
+ ORDER BY name`)
+ end
+ in
+ locationTree' (root, lim, [])
+ end
+
+fun locationTreeWithUser (root, lim, usr) =
+ let
+ val db = getDb ()
+
+ val mkLocationRow' =
+ fn (mine :: rest) => (not (C.isNull mine), mkLocationRow rest)
+ | row => Init.rowError ("location'", row)
+
+ fun locationTree' (root, lim, acc) =
+ let
+ fun folder (row, acc) =
+ let
+ val loc = mkLocationRow' row
+ in
+ case lim of
+ SOME 0 => Util.ITEM loc :: acc
+ | _ =>
+ let
+ val dec = case lim of
+ SOME n => SOME (n-1)
+ | NONE => NONE
+ in
+ Util.ITEM loc :: Util.BEGIN :: locationTree' (SOME (#id (#2 loc)), dec, Util.END :: acc)
+ end
+ end
+ in
+ C.fold db folder acc ($`SELECT loc, id, parent, name
+ FROM Location LEFT OUTER JOIN Lives ON (id = loc AND usr = ^(C.intToSql usr))
+ WHERE parent ^(intOptToSqlCompare root)
+ ORDER BY name`)
+ end
+ in
+ locationTree' (root, lim, [])
+ end
+
+fun locationTreeWithCounts (root, lim) =
+ let
+ val count = countResidents ()
+ fun numResidents id =
+ case NM.find (count, id) of
+ NONE => 0
+ | SOME n => n
+
+ val db = getDb ()
+
+ fun locationTree' (root, lim, acc) =
+ let
+ fun folder (row, acc) =
+ let
+ val loc = mkLocationRow row
+ in
+ case lim of
+ SOME 0 => Util.ITEM (numResidents (#id loc), loc) :: acc
+ | _ =>
+ let
+ val dec = case lim of
+ SOME n => SOME (n-1)
+ | NONE => NONE
+ in
+ Util.ITEM (numResidents (#id loc), loc) :: Util.BEGIN :: locationTree' (SOME (#id loc), dec, Util.END :: acc)
+ end
+ end
+ in
+ C.fold db folder acc ($`SELECT id, parent, name
+ FROM Location
+ WHERE parent ^(intOptToSqlCompare root)
+ ORDER BY name`)
+ end
+ in
+ locationTree' (root, lim, [])
+ end
+
+
+(* Checking who lives where *)
+
+type lives = {usr : int, loc : int}
+
+fun livesIn (usr, loc) =
+ let
+ val c = getDb ()
+ in
+ (case C.oneOrNoRows c ($`SELECT COUNT( * )
+ FROM Lives
+ WHERE loc = ^(C.intToSql loc)
+ AND usr = ^(C.intToSql usr)`) of
+ SOME[x] => not (C.isNull x) andalso C.intFromSql x <> 0
+ | _ => false)
+ end
+
+
+(* Managing who lives where *)
+
+fun addToLocation (lives : lives) =
+ let
+ val usr = #usr lives
+ val loc = #loc lives
+ in
+ if livesIn (usr, loc) then
+ ()
+ else
+ ignore (C.dml (getDb ()) ($`INSERT INTO Lives (loc, usr)
+ VALUES (^(C.intToSql loc), ^(C.intToSql usr))`))
+ end
+
+fun removeFromLocation (lives : lives) =
+ let
+ val usr = #usr lives
+ val loc = #loc lives
+ in
+ ignore (C.dml (getDb ()) ($`DELETE FROM Lives
+ WHERE loc = ^(C.intToSql loc)
+ AND usr = ^(C.intToSql usr)`))
+ end
+
+fun residentsOneLevel loc =
+ C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined FROM Lives, WebUser
+ WHERE loc = ^(C.intToSql loc)
+ AND usr = id
+ ORDER BY name`)
+
+fun alreadyExists (parent, name) =
+ case C.oneRow (getDb ()) ($`SELECT COUNT( * ) FROM Location
+ WHERE parent ^(intOptToSqlCompare parent)
+ AND name = ^(C.stringToSql name)`) of
+ [n] => not (C.isNull n) andalso C.intFromSql n <> 0
+ | r => Init.rowError ("Location.alreadyExists", r)
+
+fun userLocations usr =
+ C.map (getDb ()) mkLocationRow ($`SELECT id, parent, name FROM Location JOIN Lives ON loc = id
+ WHERE usr = ^(C.intToSql usr)
+ ORDER BY name`)
+
+fun subLocations par =
+ C.map (getDb ()) mkLocationRow ($`SELECT id, parent, name FROM Location
+ WHERE parent ^(intOptToSqlCompare par)
+ ORDER BY name`)
+
+end
\ No newline at end of file
FOREIGN KEY (knd) REFERENCES ContactKind(id) ON DELETE CASCADE);
CREATE SEQUENCE ContactSeq START 1;
+
+CREATE TABLE Location(
+ id INTEGER PRIMARY KEY,
+ parent INTEGER,
+ name TEXT NOT NULL,
+ FOREIGN KEY (parent) REFERENCES Location(id) ON DELETE CASCADE);
+
+CREATE SEQUENCE LocationSeq START 1;
+
+CREATE TABLE Lives(
+ usr INTEGER NOT NULL,
+ loc INTEGER NOT NULL,
+ PRIMARY KEY (usr, loc),
+ FOREIGN KEY (usr) REFERENCES WebUser(id) ON DELETE CASCADE,
+ FOREIGN KEY (loc) REFERENCES Location(id) ON DELETE CASCADE);
<tr> <td align="right"><b>Real name</b>:</td> <td><% Web.html (#rname user) %></td> </tr>
<tr> <td align="right"><b>Hcoop e-mail</b>:</td> <td><a href="mailto:<% #name user %>@hcoop.net"><tt><% #name user %>@hcoop.net</tt></a></td> </tr>
<tr> <td align="right"><b>Joined</b>:</td> <td><% #joined user %></td> </tr>
+<tr> <td align="right"><b>Locations</b>:</td> <td><%
+ ref first = true;
+ foreach loc in Location.userLocations id do
+ if first then
+ first := false
+ else
+ %>, <%
+ end
+ %><a href="location?id=<% #id loc %>"><% Web.html (#name loc) %></a><%
+ end %></td> </tr>
<tr> </tr>
signature UTIL =
sig
+ datatype 'a flat_element =
+ BEGIN
+ | END
+ | ITEM of 'a
+ type 'a flat_tree = 'a flat_element list
+
val printInt : int -> unit
val printReal : real -> unit
structure Util :> UTIL =
struct
+datatype 'a flat_element =
+ BEGIN
+ | END
+ | ITEM of 'a
+type 'a flat_tree = 'a flat_element list
+
fun printInt n =
Web.print (if n < 0 then
"-" ^ Int.toString (~n)
HCoop / bpt / portal.git / commitdiff