| 1 | structure Money :> MONEY = |
| 2 | struct |
| 3 | |
| 4 | open Util Sql Init |
| 5 | |
| 6 | |
| 7 | (* Managing transactions *) |
| 8 | |
| 9 | type transaction = {id :int, descr : string, amount : real, d : string, stamp : C.timestamp} |
| 10 | |
| 11 | fun mkTransactionRow [id, descr, amount, d, stamp] = |
| 12 | {id = C.intFromSql id, descr = C.stringFromSql descr, amount = C.realFromSql amount, |
| 13 | d = C.stringFromSql d, stamp = C.timestampFromSql stamp} |
| 14 | | mkTransactionRow row = Init.rowError ("transaction", row) |
| 15 | |
| 16 | fun addTransaction (descr, amount, d) = |
| 17 | let |
| 18 | val db = getDb () |
| 19 | val id = nextSeq (db, "TransactionSeq") |
| 20 | in |
| 21 | C.dml db ($`INSERT INTO Transaction (id, descr, amount, d, stamp) |
| 22 | VALUES (^(C.intToSql id), ^(C.stringToSql descr), ^(C.realToSql amount), ^(C.stringToSql d), CURRENT_TIMESTAMP)`); |
| 23 | id |
| 24 | end |
| 25 | |
| 26 | fun lookupTransaction id = |
| 27 | let |
| 28 | val c = getDb () |
| 29 | in |
| 30 | (case C.oneOrNoRows c ($`SELECT id, descr, amount, d, stamp FROM Transaction WHERE id = ^(C.intToSql id)`) of |
| 31 | NONE => raise Fail "Transaction not found" |
| 32 | | SOME r => mkTransactionRow r) |
| 33 | end |
| 34 | |
| 35 | fun modTransaction (trans : transaction) = |
| 36 | let |
| 37 | val db = getDb () |
| 38 | in |
| 39 | ignore (C.dml db ($`UPDATE TRANSACTION |
| 40 | SET descr = ^(C.stringToSql (#descr trans)), amount = ^(C.realToSql (#amount trans)), |
| 41 | d = ^(C.stringToSql (#d trans)), stamp = CURRENT_TIMESTAMP |
| 42 | WHERE id = ^(C.intToSql (#id trans))`)) |
| 43 | end |
| 44 | |
| 45 | fun deleteTransaction id = |
| 46 | ignore (C.dml (getDb ()) ($`DELETE FROM Transaction WHERE id = ^(C.intToSql id)`)) |
| 47 | |
| 48 | fun listTransactions () = |
| 49 | C.map (getDb ()) mkTransactionRow ($`SELECT id, descr, amount, d, stamp FROM Transaction |
| 50 | ORDER BY d DESC`) |
| 51 | |
| 52 | fun listTransactionsLimit lim = |
| 53 | C.map (getDb ()) mkTransactionRow ($`SELECT id, descr, amount, d, stamp FROM Transaction |
| 54 | ORDER BY d DESC |
| 55 | LIMIT ^(C.intToSql lim)`) |
| 56 | |
| 57 | fun listUserTransactions usr = |
| 58 | let |
| 59 | val mkRow = |
| 60 | fn (amount :: row) => (C.realFromSql amount, mkTransactionRow row) |
| 61 | | _ => raise Fail "Bad charge+transaction row" |
| 62 | in |
| 63 | C.map (getDb ()) mkRow ($`SELECT C.amount, T.id, T.descr, T.amount, T.d, T.stamp FROM Transaction T, Charge C |
| 64 | WHERE id = trn |
| 65 | AND usr = ^(C.intToSql usr) |
| 66 | ORDER BY T.d DESC`) |
| 67 | end |
| 68 | |
| 69 | fun listUserTransactionsLimit (usr, lim) = |
| 70 | let |
| 71 | val mkRow = |
| 72 | fn (amount :: row) => (C.realFromSql amount, mkTransactionRow row) |
| 73 | | _ => raise Fail "Bad charge+transaction row" |
| 74 | in |
| 75 | C.map (getDb ()) mkRow ($`SELECT C.amount, T.id, T.descr, T.amount, T.d, T.stamp FROM Transaction T, Charge C |
| 76 | WHERE id = trn |
| 77 | AND usr = ^(C.intToSql usr) |
| 78 | ORDER BY T.d DESC |
| 79 | LIMIT ^(C.intToSql lim)`) |
| 80 | end |
| 81 | |
| 82 | val mkUserRow' = |
| 83 | fn (trn :: rest) => |
| 84 | (if C.isNull trn then false else true, |
| 85 | mkUserRow rest) |
| 86 | | row => Init.rowError ("listUsers", row) |
| 87 | |
| 88 | fun listUsers trn = |
| 89 | C.map (getDb ()) mkUserRow' ($`SELECT trn, id, name, rname, bal, joined, app, shares, paypal, checkout |
| 90 | FROM WebUser LEFT OUTER JOIN Charge ON usr = id AND trn = ^(C.intToSql trn) |
| 91 | ORDER BY name`) |
| 92 | |
| 93 | |
| 94 | (* Managing charges *) |
| 95 | |
| 96 | type charge = {trn : int, usr : int, amount : real} |
| 97 | |
| 98 | fun mkChargeRow [trn, usr, amount] = |
| 99 | {trn = C.intFromSql trn, usr = C.intFromSql usr, amount = C.realFromSql amount} |
| 100 | | mkChargeRow row = Init.rowError ("charge", row) |
| 101 | |
| 102 | fun addCharge {trn, usr, amount} = |
| 103 | ignore (C.dml (getDb ()) ($`INSERT INTO Charge (trn, usr, amount) |
| 104 | VALUES (^(C.intToSql trn), ^(C.intToSql usr), ^(C.realToSql amount))`)) |
| 105 | |
| 106 | fun listCharges trn = |
| 107 | C.map (getDb ()) mkChargeRow ($`SELECT trn, usr, amount FROM Charge |
| 108 | WHERE trn = ^(C.intToSql trn)`) |
| 109 | |
| 110 | val mkChargeRow' = |
| 111 | fn (name :: rest) => (C.stringFromSql name, mkChargeRow rest) |
| 112 | | row => Init.rowError ("name+charge", row) |
| 113 | |
| 114 | fun listChargesWithNames trn = |
| 115 | C.map (getDb ()) mkChargeRow' ($`SELECT name, trn, usr, amount FROM Charge, WebUser |
| 116 | WHERE trn = ^(C.intToSql trn) |
| 117 | AND usr = id |
| 118 | ORDER BY name`) |
| 119 | |
| 120 | |
| 121 | (* Macro-operations *) |
| 122 | |
| 123 | fun clearCharges trn = |
| 124 | let |
| 125 | val db = getDb () |
| 126 | |
| 127 | fun clearCharge [bal, amount] = |
| 128 | ignore (C.dml db ($`UPDATE Balance |
| 129 | SET amount = amount - ^(C.stringFromSql amount) |
| 130 | WHERE id = ^(C.stringFromSql bal)`)) |
| 131 | | clearCharge row = Init.rowError ("clearCharge", row) |
| 132 | in |
| 133 | C.app db clearCharge ($`SELECT bal, SUM(amount) FROM Charge, WebUser |
| 134 | WHERE trn = ^(C.intToSql trn) |
| 135 | AND usr = id |
| 136 | GROUP BY bal`); |
| 137 | ignore (C.dml db ($`DELETE FROM Charge WHERE trn = ^(C.intToSql trn)`)) |
| 138 | end |
| 139 | |
| 140 | fun applyCharges trn = |
| 141 | let |
| 142 | val db = getDb () |
| 143 | |
| 144 | fun applyCharge [bal, amount] = |
| 145 | ignore (C.dml db ($`UPDATE Balance |
| 146 | SET amount = amount + ^(C.stringFromSql amount) |
| 147 | WHERE id = ^(C.stringFromSql bal)`)) |
| 148 | | applyCharge row = Init.rowError ("applyCharge", row) |
| 149 | in |
| 150 | C.app db applyCharge ($`SELECT bal, SUM(amount) FROM Charge, WebUser |
| 151 | WHERE trn = ^(C.intToSql trn) |
| 152 | AND usr = id |
| 153 | GROUP BY bal`) |
| 154 | end |
| 155 | |
| 156 | fun addEvenCharges (trn, usrs) = |
| 157 | let |
| 158 | val tran = lookupTransaction trn |
| 159 | val nUsrs = length usrs |
| 160 | |
| 161 | val split = #amount tran / (real nUsrs) |
| 162 | |
| 163 | val db = getDb () |
| 164 | |
| 165 | fun addCharge usr = |
| 166 | ignore (C.dml db ($`INSERT INTO Charge (trn, usr, amount) |
| 167 | VALUES (^(C.intToSql trn), ^(C.intToSql usr), ^(C.realToSql split))`)) |
| 168 | in |
| 169 | app addCharge usrs; |
| 170 | applyCharges trn |
| 171 | end |
| 172 | |
| 173 | (* Automated hosting charges *) |
| 174 | |
| 175 | type hosting = {trn : int, cutoff : int, cost : real, usage : string} |
| 176 | |
| 177 | structure StringKey = struct |
| 178 | type ord_key = string |
| 179 | val compare = String.compare |
| 180 | end |
| 181 | |
| 182 | structure SM = BinaryMapFn(StringKey) |
| 183 | |
| 184 | fun addHostingCharges {trn, cutoff, cost, usage} = |
| 185 | let |
| 186 | val tran = lookupTransaction trn |
| 187 | |
| 188 | val paying = |
| 189 | case Group.groupNameToId "paying" of |
| 190 | NONE => raise Fail "No 'paying' group" |
| 191 | | SOME id => id |
| 192 | |
| 193 | val nvs = String.tokens Char.isSpace usage |
| 194 | |
| 195 | fun walkNvs (nvs, umap, amount) = |
| 196 | case nvs of |
| 197 | name :: bw :: rest => |
| 198 | let |
| 199 | val bw = Web.stoi bw |
| 200 | in |
| 201 | if bw > cutoff then |
| 202 | let |
| 203 | val extra = cost * (real (bw - cutoff) / 1000000.0) |
| 204 | in |
| 205 | walkNvs (rest, |
| 206 | SM.insert (umap, name, extra), |
| 207 | amount + extra) |
| 208 | end |
| 209 | else |
| 210 | walkNvs (rest, umap, amount) |
| 211 | end |
| 212 | | _ => (umap, amount) |
| 213 | |
| 214 | val (umap, amount) = walkNvs (nvs, SM.empty, #amount tran) |
| 215 | |
| 216 | val db = getDb () |
| 217 | |
| 218 | val shares = |
| 219 | case C.oneRow db ($`SELECT SUM(shares) |
| 220 | FROM WebUser JOIN Membership ON usr = WebUser.id AND grp = ^(C.intToSql paying)`) of |
| 221 | [n] => C.intFromSql n |
| 222 | | row => Init.rowError ("Bad addHostingCharges share count result", row) |
| 223 | |
| 224 | val even = amount / real shares |
| 225 | |
| 226 | fun doUser ([uid, uname, shares], umap) = |
| 227 | let |
| 228 | val uid = C.intFromSql uid |
| 229 | val uname = C.stringFromSql uname |
| 230 | val shares = C.intFromSql shares |
| 231 | |
| 232 | val (charge, umap) = |
| 233 | case SM.find (umap, uname) of |
| 234 | NONE => (even * real shares, umap) |
| 235 | | SOME extra => (even * real shares - extra, #1 (SM.remove (umap, uname))) |
| 236 | in |
| 237 | addCharge {trn = trn, usr = uid, amount = charge}; |
| 238 | umap |
| 239 | end |
| 240 | |
| 241 | val _ = if SM.numItems (C.fold db doUser umap |
| 242 | ($`SELECT id, name, shares |
| 243 | FROM WebUser JOIN Membership ON usr = WebUser.id AND grp = ^(C.intToSql paying)`)) |
| 244 | = 0 then |
| 245 | applyCharges trn |
| 246 | else |
| 247 | raise Fail "Usage description contains an unknown username" |
| 248 | |
| 249 | val usageFile = TextIO.openOut (Init.scratchDir ^ "/usage/" ^ Int.toString trn) |
| 250 | in |
| 251 | TextIO.output (usageFile, usage); |
| 252 | TextIO.closeOut usageFile |
| 253 | end |
| 254 | |
| 255 | fun equalizeBalances () = |
| 256 | ignore (C.dml (getDb ()) ($`UPDATE Balance SET amount = (SELECT SUM(amount) FROM Charge JOIN WebUser ON usr = WebUser.id WHERE bal = Balance.id)`)) |
| 257 | |
| 258 | fun lookupHostingUsage trn = |
| 259 | let |
| 260 | val usageFile = TextIO.openIn (Init.scratchDir ^ "/usage/" ^ Int.toString trn) |
| 261 | |
| 262 | fun loop acc = |
| 263 | case TextIO.inputLine usageFile of |
| 264 | NONE => String.concat (List.rev acc) |
| 265 | | SOME line => loop (line :: acc) |
| 266 | in |
| 267 | SOME (loop []) |
| 268 | before TextIO.closeIn usageFile |
| 269 | end handle _ => NONE |
| 270 | |
| 271 | fun costBase amt = |
| 272 | case C.oneRow (getDb ()) ($`SELECT ^(C.realToSql amt) / SUM(shares) FROM WebUserPaying`) of |
| 273 | [share] => C.realFromSql share |
| 274 | | row => Init.rowError ("Bad costBase result", row) |
| 275 | |
| 276 | val monthlyCost = 900.0 |
| 277 | val graceMonths = 1 |
| 278 | |
| 279 | val baseDues = 5.0 |
| 280 | |
| 281 | fun delinquentPledgers () = |
| 282 | let |
| 283 | fun makeRow [id, name, shares, amount] = {id = C.intFromSql id, name = C.stringFromSql name, |
| 284 | shares = C.intFromSql shares, balance = C.realFromSql amount} |
| 285 | | makeRow row = Init.rowError ("Bad delinquentPledgers", row) |
| 286 | in |
| 287 | C.map (getDb ()) makeRow ($`SELECT WebUserPaying.id, WebUserPaying.name, shares, amount |
| 288 | FROM WebUserPaying JOIN Balance ON Balance.id = bal |
| 289 | WHERE amount < shares * ^(C.realToSql baseDues) * ^(C.intToSql graceMonths) |
| 290 | AND shares > 1 |
| 291 | ORDER BY name`) |
| 292 | end |
| 293 | |
| 294 | fun resetPledges ids = |
| 295 | ignore (C.dml (getDb ()) ($`UPDATE WebUser SET shares = 1 WHERE id IN (^(String.concatWith ", " (List.map C.intToSql ids)))`)) |
| 296 | |
| 297 | fun freezeworthyPledgers () = |
| 298 | let |
| 299 | val baseDues = 5.0 |
| 300 | |
| 301 | fun makeRow [id, name, amount, j] = {id = C.intFromSql id, name = C.stringFromSql name, |
| 302 | balance = C.realFromSql amount, joinedThisMonth = C.boolFromSql j} |
| 303 | | makeRow row = Init.rowError ("Bad freezeworthyPledgers", row) |
| 304 | in |
| 305 | C.map (getDb ()) makeRow ($`SELECT WebUserPaying.id, WebUserPaying.name, amount, CURRENT_TIMESTAMP - joined < INTERVAL '1 month' |
| 306 | FROM WebUserPaying JOIN Balance ON Balance.id = bal |
| 307 | WHERE amount >= ^(C.realToSql baseDues) * ^(C.intToSql graceMonths) |
| 308 | AND amount < ^(C.realToSql baseDues) * ^(C.intToSql (graceMonths + 1)) |
| 309 | ORDER BY name`) |
| 310 | end |
| 311 | |
| 312 | fun bootworthyPledgers () = |
| 313 | let |
| 314 | val baseDues = 5.0 |
| 315 | |
| 316 | fun makeRow [id, name, amount, j] = {id = C.intFromSql id, name = C.stringFromSql name, |
| 317 | balance = C.realFromSql amount, joinedThisMonth = C.boolFromSql j} |
| 318 | | makeRow row = Init.rowError ("Bad bootworthyPledgers", row) |
| 319 | in |
| 320 | C.map (getDb ()) makeRow ($`SELECT WebUserPaying.id, WebUserPaying.name, amount, CURRENT_TIMESTAMP - joined < INTERVAL '1 month' |
| 321 | FROM WebUserPaying JOIN Balance ON Balance.id = bal |
| 322 | WHERE amount < ^(C.realToSql baseDues) * ^(C.intToSql graceMonths) |
| 323 | ORDER BY name`) |
| 324 | end |
| 325 | |
| 326 | fun billDues {descr, base, date} = |
| 327 | let |
| 328 | val db = getDb () |
| 329 | val paying = |
| 330 | case Group.groupNameToId "paying" of |
| 331 | NONE => raise Fail "No 'paying' group" |
| 332 | | SOME id => id |
| 333 | |
| 334 | val shares = |
| 335 | case C.oneRow db ($`SELECT SUM(shares) |
| 336 | FROM WebUser JOIN Membership ON usr = WebUser.id AND grp = ^(C.intToSql paying)`) of |
| 337 | [n] => C.intFromSql n |
| 338 | | row => Init.rowError ("Bad addHostingCharges share count result", row) |
| 339 | |
| 340 | val total = real shares * base |
| 341 | |
| 342 | val give = addTransaction (descr, ~total, date) |
| 343 | |
| 344 | fun doUser [uid, shares] = |
| 345 | let |
| 346 | val uid = C.intFromSql uid |
| 347 | val shares = C.intFromSql shares |
| 348 | in |
| 349 | addCharge {trn = give, usr = uid, amount = ~(base * real shares)} |
| 350 | end |
| 351 | | doUser r = Init.rowError ("Bad billDues/doUser row", r) |
| 352 | |
| 353 | val receive = addTransaction (descr, total, date) |
| 354 | |
| 355 | val hcoop = valOf (Init.userNameToId "hcoop") |
| 356 | in |
| 357 | C.app db doUser ($`SELECT id, shares |
| 358 | FROM WebUser JOIN Membership ON usr = WebUser.id AND grp = ^(C.intToSql paying)`); |
| 359 | applyCharges give; |
| 360 | |
| 361 | addCharge {trn = receive, usr = hcoop, amount = total}; |
| 362 | applyCharges receive |
| 363 | end |
| 364 | |
| 365 | end |