From b340786b13dacb1070c79713ebc4eaf298d27943 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 17 Apr 2005 00:02:14 +0000 Subject: [PATCH] Geography database --- TODO | 1 - group.sml | 7 +- groups.mlt | 2 +- location.mlt | 202 ++++++++++++++++++++++++++++++++ location.sig | 25 ++++ location.sml | 318 +++++++++++++++++++++++++++++++++++++++++++++++++++ tables.sql | 15 +++ user.mlt | 10 ++ util.sig | 6 + util.sml | 6 + 10 files changed, 586 insertions(+), 6 deletions(-) create mode 100644 location.mlt create mode 100644 location.sig create mode 100644 location.sml diff --git a/TODO b/TODO index f7412b7..19777c3 100644 --- a/TODO +++ b/TODO @@ -1,5 +1,4 @@ Member data - - Geographic location - Hosted web site registry - Summarize these with publicly accessible static pages diff --git a/group.sml b/group.sml index 7c24bbc..5daf76c 100644 --- a/group.sml +++ b/group.sml @@ -55,7 +55,7 @@ fun userInGroupNum (usr, grp) = 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) @@ -67,9 +67,8 @@ fun userInGroupName (usr, grp) = 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 diff --git a/groups.mlt b/groups.mlt index 3941620..d0a1a28 100644 --- a/groups.mlt +++ b/groups.mlt @@ -87,7 +87,7 @@ elseif $"mod" <> "" then <% foreach group in Group.listGroups () do %> - + <% foreach user in Group.groupMembers (#id group) do %> <% end diff --git a/location.mlt b/location.mlt new file mode 100644 index 0000000..ce8c799 --- /dev/null +++ b/location.mlt @@ -0,0 +1,202 @@ +<% @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 + %>

That location already exists!

<% + else + val id = Location.addLocation (parent, $"name") + %>

Location added

+<% end + +elseif $"mod" <> "" then + Group.requireGroupName "location"; + showNormal := false; + val id = Web.stoi ($"mod"); + val loc = Location.lookupLocation id %> + +

Modify a location

+ + + +
<% Web.html (#name group) %>(#<% #id group %>) [Modify] [Delete]
<% Web.html (#name group) %> [Modify] [Delete]
<% Web.html (#name user) %> [Revoke]
+ + + +
Parent:
Name:
+ + +<% 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"}; + %>

Location saved

+ +<% elseif $"del" <> "" then + Group.requireGroupName "location"; + showNormal := false; + val id = Web.stoi ($"del"); + val loc = Location.lookupLocation id %> +

Are you sure you want to delete "<% Web.html (#name loc) %>"?

+ Yes, delete "<% Web.html (#name loc) %>"! + +<% elseif $"del2" <> "" then + Group.requireGroupName "location"; + val id = Web.stoi ($"del2"); + val loc = Location.lookupLocation id; + Location.deleteLocation id %> +

Deleted location "<% Web.html (#name loc) %>"

+ +<% elseif $"addLoc" <> "" then + Location.addToLocation {loc = Web.stoi ($"addLoc"), usr = Init.getUserId ()} + %>

Added

+ +<% elseif $"remLoc" <> "" then + Location.removeFromLocation {loc = Web.stoi ($"remLoc"), usr = Init.getUserId ()} + %>

Removed

+ +<% elseif $"id" <> "" then + showNormal := false; + val id = Web.stoi ($"id"); + val loc = Location.lookupLocation id %> + +

<% Web.html (#name loc) %>

+ +<% switch #parent loc of + SOME par => + val ploc = Location.lookupLocation par; + %>Parent: <% Web.html (#name ploc) %><% +end %> + +

Residents:

+<% ref first = true; +foreach user in Location.residents id do + if first then + first := false + else + %>, <% + end; + %><% #name user %><% +end %> + +

Regions:

+<% foreach loc in Location.subLocations (SOME id) do %> + <% Web.html (#name loc) %>
+<% end; + +end; + +if showNormal then %> + + +

Add a new location

+ +
+ + + + + +
Parent:
Name:
+
+ +<% val withUser = Location.locationTreeWithUser (NONE, NONE, Init.getUserId ()) %> + +

Add yourself to a location

+ +Adding yourself to a location automatically adds you to all more general loations. + +
+ +
+ +

Remove yourself from a location

+ +
+ +
+ + +<% end %> + +<% @footer[] %> \ No newline at end of file diff --git a/location.sig b/location.sig new file mode 100644 index 0000000..7ae4c3e --- /dev/null +++ b/location.sig @@ -0,0 +1,25 @@ +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 diff --git a/location.sml b/location.sml new file mode 100644 index 0000000..fd73de8 --- /dev/null +++ b/location.sml @@ -0,0 +1,318 @@ +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 diff --git a/tables.sql b/tables.sql index df2d5be..1ffc2a4 100644 --- a/tables.sql +++ b/tables.sql @@ -120,3 +120,18 @@ CREATE TABLE Contact( 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); diff --git a/user.mlt b/user.mlt index 498fc49..7316db6 100644 --- a/user.mlt +++ b/user.mlt @@ -8,6 +8,16 @@ val user = Init.lookupUser id; Real name: <% Web.html (#rname user) %> Hcoop e-mail: <% #name user %>@hcoop.net Joined: <% #joined user %> + Locations: <% + ref first = true; + foreach loc in Location.userLocations id do + if first then + first := false + else + %>, <% + end + %><% Web.html (#name loc) %><% + end %> diff --git a/util.sig b/util.sig index a4f5b28..2c134b8 100644 --- a/util.sig +++ b/util.sig @@ -1,5 +1,11 @@ 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 diff --git a/util.sml b/util.sml index 39edd39..579482d 100644 --- a/util.sml +++ b/util.sml @@ -1,6 +1,12 @@ 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) -- 2.20.1