| 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 |
| 138 | C.fold db folder NM.empty ($`SELECT loc, id, name, rname, bal, joined, app, shares, paypal, checkout |
| 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 DESC`) |
| 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 DESC`) |
| 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 DESC`) |
| 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 = |
| 296 | C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout |
| 297 | FROM Lives, WebUser |
| 298 | WHERE loc = ^(C.intToSql loc) |
| 299 | AND usr = id |
| 300 | ORDER BY name`) |
| 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 | |
| 319 | end |