51520441 |
1 | structure Location :> LOCATION = |
2 | struct |
3 | |
4 | open Util Sql Init |
5 | |
6 | |
7 | (* Managing locations *) |
8 | |
9 | type location = {id : int, parent : int option, name : string} |
10 | |
11 | fun intOptFromSql v = |
12 | if C.isNull v then |
13 | NONE |
14 | else |
15 | SOME (C.intFromSql v) |
16 | |
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) |
22 | |
23 | val intOptToSql = |
24 | fn NONE => "NULL" |
25 | | SOME n => C.intToSql n |
26 | |
27 | val intOptToSqlCompare = |
28 | fn NONE => "IS NULL" |
29 | | SOME n => "= " ^ C.intToSql n |
30 | |
31 | fun addLocation (parent, name) = |
32 | let |
33 | val db = getDb () |
34 | val id = nextSeq (db, "LocationSeq") |
35 | in |
36 | C.dml db ($`INSERT INTO Location (id, parent, name) |
37 | VALUES (^(C.intToSql id), ^(intOptToSql parent), ^(C.stringToSql name))`); |
38 | id |
39 | end |
40 | |
41 | fun lookupLocation id = |
42 | let |
43 | val c = getDb () |
44 | in |
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) |
48 | end |
49 | |
50 | fun modLocation (loc : location) = |
51 | let |
52 | val db = getDb () |
53 | in |
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))`)) |
57 | end |
58 | |
59 | fun deleteLocation id = |
60 | ignore (C.dml (getDb ()) ($`DELETE FROM Location WHERE id = ^(C.intToSql id)`)) |
61 | |
62 | structure IntKey = struct |
63 | type ord_key = int |
64 | val compare = Int.compare |
65 | end |
66 | |
67 | structure NM = BinaryMapFn(IntKey) |
68 | |
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) |
72 | end |
73 | |
74 | structure US = BinarySetFn(UserKey) |
75 | |
76 | fun mkLivesRow [loc, usr] = |
77 | {loc = C.intFromSql loc, usr = C.intFromSql usr} |
78 | | mkLivesRow row = Init.rowError ("lives", row) |
79 | |
80 | fun countResidents () = |
81 | let |
82 | val db = getDb () |
83 | |
84 | fun folder (row, count) = |
85 | let |
86 | fun addToParents (id, count) = |
87 | let |
88 | val count = NM.insert (count, id, (case NM.find (count, id) of |
89 | NONE => 1 |
90 | | SOME n => n+1)) |
91 | in |
92 | case C.oneRow db ($`SELECT parent FROM Location WHERE id = ^(C.intToSql id)`) of |
93 | [p] => if C.isNull p then |
94 | count |
95 | else |
96 | addToParents (C.intFromSql p, count) |
97 | | r => Init.rowError ("Location.addToParents", r) |
98 | end |
99 | |
100 | val lives = mkLivesRow row |
101 | in |
102 | addToParents (#loc lives, count) |
103 | end |
104 | in |
105 | C.fold db folder NM.empty ($`SELECT loc, usr FROM Lives`) |
106 | end |
107 | |
108 | fun recordResidents () = |
109 | let |
110 | val db = getDb () |
111 | |
112 | fun mkRow row = |
113 | case row of |
114 | loc :: rest => (C.intFromSql loc, mkUserRow rest) |
115 | | _ => Init.rowError ("recordResidents.mkRow", row) |
116 | |
117 | fun folder (row, count) = |
118 | let |
119 | val (loc, user) = mkRow row |
120 | |
121 | fun addToParents (id, count) = |
122 | let |
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))) |
126 | in |
127 | case C.oneRow db ($`SELECT parent FROM Location WHERE id = ^(C.intToSql id)`) of |
128 | [p] => if C.isNull p then |
129 | count |
130 | else |
131 | addToParents (C.intFromSql p, count) |
132 | | r => Init.rowError ("Location.addToParents'", r) |
133 | end |
134 | in |
135 | addToParents (loc, count) |
136 | end |
137 | in |
c5764f98 |
138 | C.fold db folder NM.empty ($`SELECT loc, id, name, rname, bal, joined, app, shares |
51520441 |
139 | FROM Lives JOIN WebUser ON usr = id`) |
140 | end |
141 | |
142 | fun residents loc = |
143 | let |
144 | val res = recordResidents () |
145 | in |
146 | case NM.find (res, loc) of |
147 | NONE => [] |
148 | | SOME us => US.foldr (op ::) [] us |
149 | end |
150 | |
151 | fun locationTree (root, lim) = |
152 | let |
153 | val db = getDb () |
154 | |
155 | fun locationTree' (root, lim, acc) = |
156 | let |
157 | fun folder (row, acc) = |
158 | let |
159 | val loc = mkLocationRow row |
160 | in |
161 | case lim of |
162 | SOME 0 => Util.ITEM loc :: acc |
163 | | _ => |
164 | let |
165 | val dec = case lim of |
166 | SOME n => SOME (n-1) |
167 | | NONE => NONE |
168 | in |
169 | Util.ITEM loc :: Util.BEGIN :: locationTree' (SOME (#id loc), dec, Util.END :: acc) |
170 | end |
171 | end |
172 | in |
173 | C.fold db folder acc ($`SELECT id, parent, name FROM Location |
174 | WHERE parent ^(intOptToSqlCompare root) |
175 | ORDER BY name`) |
176 | end |
177 | in |
178 | locationTree' (root, lim, []) |
179 | end |
180 | |
181 | fun locationTreeWithUser (root, lim, usr) = |
182 | let |
183 | val db = getDb () |
184 | |
185 | val mkLocationRow' = |
186 | fn (mine :: rest) => (not (C.isNull mine), mkLocationRow rest) |
187 | | row => Init.rowError ("location'", row) |
188 | |
189 | fun locationTree' (root, lim, acc) = |
190 | let |
191 | fun folder (row, acc) = |
192 | let |
193 | val loc = mkLocationRow' row |
194 | in |
195 | case lim of |
196 | SOME 0 => Util.ITEM loc :: acc |
197 | | _ => |
198 | let |
199 | val dec = case lim of |
200 | SOME n => SOME (n-1) |
201 | | NONE => NONE |
202 | in |
203 | Util.ITEM loc :: Util.BEGIN :: locationTree' (SOME (#id (#2 loc)), dec, Util.END :: acc) |
204 | end |
205 | end |
206 | in |
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) |
210 | ORDER BY name`) |
211 | end |
212 | in |
213 | locationTree' (root, lim, []) |
214 | end |
215 | |
216 | fun locationTreeWithCounts (root, lim) = |
217 | let |
218 | val count = countResidents () |
219 | fun numResidents id = |
220 | case NM.find (count, id) of |
221 | NONE => 0 |
222 | | SOME n => n |
223 | |
224 | val db = getDb () |
225 | |
226 | fun locationTree' (root, lim, acc) = |
227 | let |
228 | fun folder (row, acc) = |
229 | let |
230 | val loc = mkLocationRow row |
231 | in |
232 | case lim of |
233 | SOME 0 => Util.ITEM (numResidents (#id loc), loc) :: acc |
234 | | _ => |
235 | let |
236 | val dec = case lim of |
237 | SOME n => SOME (n-1) |
238 | | NONE => NONE |
239 | in |
240 | Util.ITEM (numResidents (#id loc), loc) :: Util.BEGIN :: locationTree' (SOME (#id loc), dec, Util.END :: acc) |
241 | end |
242 | end |
243 | in |
244 | C.fold db folder acc ($`SELECT id, parent, name |
245 | FROM Location |
246 | WHERE parent ^(intOptToSqlCompare root) |
247 | ORDER BY name`) |
248 | end |
249 | in |
250 | locationTree' (root, lim, []) |
251 | end |
252 | |
253 | |
254 | (* Checking who lives where *) |
255 | |
256 | type lives = {usr : int, loc : int} |
257 | |
258 | fun livesIn (usr, loc) = |
259 | let |
260 | val c = getDb () |
261 | in |
262 | (case C.oneOrNoRows c ($`SELECT COUNT( * ) |
263 | FROM Lives |
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 |
267 | | _ => false) |
268 | end |
269 | |
270 | |
271 | (* Managing who lives where *) |
272 | |
273 | fun addToLocation (lives : lives) = |
274 | let |
275 | val usr = #usr lives |
276 | val loc = #loc lives |
277 | in |
278 | if livesIn (usr, loc) then |
279 | () |
280 | else |
281 | ignore (C.dml (getDb ()) ($`INSERT INTO Lives (loc, usr) |
282 | VALUES (^(C.intToSql loc), ^(C.intToSql usr))`)) |
283 | end |
284 | |
285 | fun removeFromLocation (lives : lives) = |
286 | let |
287 | val usr = #usr lives |
288 | val loc = #loc lives |
289 | in |
290 | ignore (C.dml (getDb ()) ($`DELETE FROM Lives |
291 | WHERE loc = ^(C.intToSql loc) |
292 | AND usr = ^(C.intToSql usr)`)) |
293 | end |
294 | |
295 | fun residentsOneLevel loc = |
c5764f98 |
296 | C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares FROM Lives, WebUser |
51520441 |
297 | WHERE loc = ^(C.intToSql loc) |
298 | AND usr = id |
299 | ORDER BY name`) |
300 | |
301 | fun alreadyExists (parent, name) = |
302 | case C.oneRow (getDb ()) ($`SELECT COUNT( * ) FROM Location |
303 | WHERE parent ^(intOptToSqlCompare parent) |
304 | AND name = ^(C.stringToSql name)`) of |
305 | [n] => not (C.isNull n) andalso C.intFromSql n <> 0 |
306 | | r => Init.rowError ("Location.alreadyExists", r) |
307 | |
308 | fun userLocations usr = |
309 | C.map (getDb ()) mkLocationRow ($`SELECT id, parent, name FROM Location JOIN Lives ON loc = id |
310 | WHERE usr = ^(C.intToSql usr) |
311 | ORDER BY name`) |
312 | |
313 | fun subLocations par = |
314 | C.map (getDb ()) mkLocationRow ($`SELECT id, parent, name FROM Location |
315 | WHERE parent ^(intOptToSqlCompare par) |
316 | ORDER BY name`) |
317 | |
c5764f98 |
318 | end |