Commit | Line | Data |
---|---|---|
b340786b AC |
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 | |
e38fe5b0 | 105 | C.fold db folder NM.empty ($`SELECT loc, usr FROM Lives JOIN WebUserActive ON usr = id`) |
b340786b AC |
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 | |
d5f8418b | 138 | C.fold db folder NM.empty ($`SELECT loc, id, name, rname, bal, joined, app, shares, paypal, checkout |
e38fe5b0 | 139 | FROM Lives JOIN WebUserActive ON usr = id`) |
b340786b AC |
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) | |
63ffda04 | 175 | ORDER BY name DESC`) |
b340786b AC |
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) | |
63ffda04 | 210 | ORDER BY name DESC`) |
b340786b AC |
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) | |
63ffda04 | 247 | ORDER BY name DESC`) |
b340786b AC |
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 = | |
d5f8418b | 296 | C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout |
e38fe5b0 | 297 | FROM Lives, WebUserActive |
d5f8418b AC |
298 | WHERE loc = ^(C.intToSql loc) |
299 | AND usr = id | |
300 | ORDER BY name`) | |
b340786b AC |
301 | |
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) | |
308 | ||
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) | |
312 | ORDER BY name`) | |
313 | ||
314 | fun subLocations par = | |
315 | C.map (getDb ()) mkLocationRow ($`SELECT id, parent, name FROM Location | |
316 | WHERE parent ^(intOptToSqlCompare par) | |
317 | ORDER BY name`) | |
318 | ||
f180168a | 319 | end |