location.sml

   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