+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