1 structure Location
:> LOCATION
=
7 (* Managing locations
*)
9 type location
= {id
: int, parent
: int option
, name
: string}
17 fun mkLocationRow
[id
, parent
, name
] =
18 {id
= C
.intFromSql id
,
19 parent
= intOptFromSql parent
,
20 name
= C
.stringFromSql name
}
21 | mkLocationRow row
= Init
.rowError ("location", row
)
25 | SOME n
=> C
.intToSql n
27 val intOptToSqlCompare
=
29 | SOME n
=> "= " ^ C
.intToSql n
31 fun addLocation (parent
, name
) =
34 val id
= nextSeq (db
, "LocationSeq")
36 C
.dml
db ($`INSERT INTO
Location (id
, parent
, name
)
37 VALUES (^
(C
.intToSql id
), ^
(intOptToSql parent
), ^
(C
.stringToSql name
))`
);
41 fun lookupLocation id
=
45 (case C
.oneOrNoRows
c ($`SELECT id
, parent
, name FROM Location WHERE id
= ^
(C
.intToSql id
)`
) of
46 NONE
=> raise Fail
"Location not found"
47 | SOME r
=> mkLocationRow r
)
50 fun modLocation (loc
: location
) =
54 ignore (C
.dml
db ($`UPDATE Location
55 SET parent
= ^
(intOptToSql (#parent loc
)), name
= ^
(C
.stringToSql (#name loc
))
56 WHERE id
= ^
(C
.intToSql (#id loc
))`
))
59 fun deleteLocation id
=
60 ignore (C
.dml (getDb ()) ($`DELETE FROM Location WHERE id
= ^
(C
.intToSql id
)`
))
62 structure IntKey
= struct
64 val compare
= Int.compare
67 structure NM
= BinaryMapFn(IntKey
)
69 structure UserKey
= struct
70 type ord_key
= Init
.user
71 fun compare (u1
: ord_key
, u2
: ord_key
) = String.compare (#name u1
, #name u2
)
74 structure US
= BinarySetFn(UserKey
)
76 fun mkLivesRow
[loc
, usr
] =
77 {loc
= C
.intFromSql loc
, usr
= C
.intFromSql usr
}
78 | mkLivesRow row
= Init
.rowError ("lives", row
)
80 fun countResidents () =
84 fun folder (row
, count
) =
86 fun addToParents (id
, count
) =
88 val count
= NM
.insert (count
, id
, (case NM
.find (count
, id
) of
92 case C
.oneRow
db ($`SELECT parent FROM Location WHERE id
= ^
(C
.intToSql id
)`
) of
93 [p
] => if C
.isNull p
then
96 addToParents (C
.intFromSql p
, count
)
97 | r
=> Init
.rowError ("Location.addToParents", r
)
100 val lives
= mkLivesRow row
102 addToParents (#loc lives
, count
)
105 C
.fold db folder NM
.empty ($`SELECT loc
, usr FROM Lives JOIN WebUserActive ON usr
= id`
)
108 fun recordResidents () =
114 loc
:: rest
=> (C
.intFromSql loc
, mkUserRow rest
)
115 | _
=> Init
.rowError ("recordResidents.mkRow", row
)
117 fun folder (row
, count
) =
119 val (loc
, user
) = mkRow row
121 fun addToParents (id
, count
) =
123 val count
= NM
.insert (count
, id
, (case NM
.find (count
, id
) of
124 NONE
=> US
.singleton user
125 | SOME ns
=> US
.add (ns
, user
)))
127 case C
.oneRow
db ($`SELECT parent FROM Location WHERE id
= ^
(C
.intToSql id
)`
) of
128 [p
] => if C
.isNull p
then
131 addToParents (C
.intFromSql p
, count
)
132 | r
=> Init
.rowError ("Location.addToParents'", r
)
135 addToParents (loc
, count
)
138 C
.fold db folder NM
.empty ($`SELECT loc
, id
, name
, rname
, bal
, joined
, app
, shares
, paypal
, checkout
139 FROM Lives JOIN WebUserActive ON usr
= id`
)
144 val res
= recordResidents ()
146 case NM
.find (res
, loc
) of
148 | SOME us
=> US
.foldr (op ::) [] us
151 fun locationTree (root
, lim
) =
155 fun locationTree
' (root
, lim
, acc
) =
157 fun folder (row
, acc
) =
159 val loc
= mkLocationRow row
162 SOME
0 => Util
.ITEM loc
:: acc
165 val dec
= case lim
of
169 Util
.ITEM loc
:: Util
.BEGIN
:: locationTree
' (SOME (#id loc
), dec
, Util
.END
:: acc
)
173 C
.fold db folder
acc ($`SELECT id
, parent
, name FROM Location
174 WHERE parent ^
(intOptToSqlCompare root
)
178 locationTree
' (root
, lim
, [])
181 fun locationTreeWithUser (root
, lim
, usr
) =
186 fn (mine
:: rest
) => (not (C
.isNull mine
), mkLocationRow rest
)
187 | row
=> Init
.rowError ("location'", row
)
189 fun locationTree
' (root
, lim
, acc
) =
191 fun folder (row
, acc
) =
193 val loc
= mkLocationRow
' row
196 SOME
0 => Util
.ITEM loc
:: acc
199 val dec
= case lim
of
203 Util
.ITEM loc
:: Util
.BEGIN
:: locationTree
' (SOME (#
id (#
2 loc
)), dec
, Util
.END
:: acc
)
207 C
.fold db folder
acc ($`SELECT loc
, id
, parent
, name
208 FROM Location LEFT OUTER JOIN Lives
ON (id
= loc AND usr
= ^
(C
.intToSql usr
))
209 WHERE parent ^
(intOptToSqlCompare root
)
213 locationTree
' (root
, lim
, [])
216 fun locationTreeWithCounts (root
, lim
) =
218 val count
= countResidents ()
219 fun numResidents id
=
220 case NM
.find (count
, id
) of
226 fun locationTree
' (root
, lim
, acc
) =
228 fun folder (row
, acc
) =
230 val loc
= mkLocationRow row
233 SOME
0 => Util
.ITEM (numResidents (#id loc
), loc
) :: acc
236 val dec
= case lim
of
240 Util
.ITEM (numResidents (#id loc
), loc
) :: Util
.BEGIN
:: locationTree
' (SOME (#id loc
), dec
, Util
.END
:: acc
)
244 C
.fold db folder
acc ($`SELECT id
, parent
, name
246 WHERE parent ^
(intOptToSqlCompare root
)
250 locationTree
' (root
, lim
, [])
254 (* Checking who lives
where *)
256 type lives
= {usr
: int, loc
: int}
258 fun livesIn (usr
, loc
) =
262 (case C
.oneOrNoRows
c ($`SELECT
COUNT( * )
264 WHERE loc
= ^
(C
.intToSql loc
)
265 AND usr
= ^
(C
.intToSql usr
)`
) of
266 SOME
[x
] => not (C
.isNull x
) andalso C
.intFromSql x
<> 0
271 (* Managing who lives
where *)
273 fun addToLocation (lives
: lives
) =
278 if livesIn (usr
, loc
) then
281 ignore (C
.dml (getDb ()) ($`INSERT INTO
Lives (loc
, usr
)
282 VALUES (^
(C
.intToSql loc
), ^
(C
.intToSql usr
))`
))
285 fun removeFromLocation (lives
: lives
) =
290 ignore (C
.dml (getDb ()) ($`DELETE FROM Lives
291 WHERE loc
= ^
(C
.intToSql loc
)
292 AND usr
= ^
(C
.intToSql usr
)`
))
295 fun residentsOneLevel loc
=
296 C
.map (getDb ()) mkUserRow ($`SELECT id
, name
, rname
, bal
, joined
, app
, shares
, paypal
, checkout
297 FROM Lives
, WebUserActive
298 WHERE loc
= ^
(C
.intToSql loc
)
302 fun alreadyExists (parent
, name
) =
303 case C
.oneRow (getDb ()) ($`SELECT
COUNT( * ) FROM Location
304 WHERE parent ^
(intOptToSqlCompare parent
)
305 AND name
= ^
(C
.stringToSql name
)`
) of
306 [n
] => not (C
.isNull n
) andalso C
.intFromSql n
<> 0
307 | r
=> Init
.rowError ("Location.alreadyExists", r
)
309 fun userLocations usr
=
310 C
.map (getDb ()) mkLocationRow ($`SELECT id
, parent
, name FROM Location JOIN Lives ON loc
= id
311 WHERE usr
= ^
(C
.intToSql usr
)
314 fun subLocations par
=
315 C
.map (getDb ()) mkLocationRow ($`SELECT id
, parent
, name FROM Location
316 WHERE parent ^
(intOptToSqlCompare par
)