| 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 = 7.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 | fun makeRow [id, name, amount, j] = {id = C.intFromSql id, name = C.stringFromSql name, |
| 300 | balance = C.realFromSql amount, joinedThisMonth = C.boolFromSql j} |
| 301 | | makeRow row = Init.rowError ("Bad freezeworthyPledgers", row) |
| 302 | in |
| 303 | C.map (getDb ()) makeRow ($`SELECT WebUserPaying.id, WebUserPaying.name, amount, CURRENT_TIMESTAMP - joined < INTERVAL '1 month' |
| 304 | FROM WebUserPaying JOIN Balance ON Balance.id = bal |
| 305 | WHERE amount >= ^(C.realToSql baseDues) * ^(C.intToSql graceMonths) |
| 306 | AND amount < ^(C.realToSql baseDues) * ^(C.intToSql (graceMonths + 1)) |
| 307 | ORDER BY name`) |
| 308 | end |
| 309 | |
| 310 | fun bootworthyPledgers () = |
| 311 | let |
| 312 | fun makeRow [id, name, amount, j] = {id = C.intFromSql id, name = C.stringFromSql name, |
| 313 | balance = C.realFromSql amount, joinedThisMonth = C.boolFromSql j} |
| 314 | | makeRow row = Init.rowError ("Bad bootworthyPledgers", row) |
| 315 | in |
| 316 | C.map (getDb ()) makeRow ($`SELECT WebUserPaying.id, WebUserPaying.name, amount, CURRENT_TIMESTAMP - joined < INTERVAL '1 month' |
| 317 | FROM WebUserPaying JOIN Balance ON Balance.id = bal |
| 318 | WHERE amount < ^(C.realToSql baseDues) * ^(C.intToSql graceMonths) |
| 319 | ORDER BY name`) |
| 320 | end |
| 321 | |
| 322 | fun billDues {descr, base, date} = |
| 323 | let |
| 324 | val db = getDb () |
| 325 | val paying = |
| 326 | case Group.groupNameToId "paying" of |
| 327 | NONE => raise Fail "No 'paying' group" |
| 328 | | SOME id => id |
| 329 | |
| 330 | val shares = |
| 331 | case C.oneRow db ($`SELECT SUM(shares) |
| 332 | FROM WebUser JOIN Membership ON usr = WebUser.id AND grp = ^(C.intToSql paying)`) of |
| 333 | [n] => C.intFromSql n |
| 334 | | row => Init.rowError ("Bad addHostingCharges share count result", row) |
| 335 | |
| 336 | val total = real shares * base |
| 337 | |
| 338 | val give = addTransaction (descr, ~total, date) |
| 339 | |
| 340 | fun doUser [uid, shares] = |
| 341 | let |
| 342 | val uid = C.intFromSql uid |
| 343 | val shares = C.intFromSql shares |
| 344 | in |
| 345 | addCharge {trn = give, usr = uid, amount = ~(base * real shares)} |
| 346 | end |
| 347 | | doUser r = Init.rowError ("Bad billDues/doUser row", r) |
| 348 | |
| 349 | val receive = addTransaction (descr, total, date) |
| 350 | |
| 351 | val hcoop = valOf (Init.userNameToId "hcoop") |
| 352 | in |
| 353 | C.app db doUser ($`SELECT id, shares |
| 354 | FROM WebUser JOIN Membership ON usr = WebUser.id AND grp = ^(C.intToSql paying)`); |
| 355 | applyCharges give; |
| 356 | |
| 357 | addCharge {trn = receive, usr = hcoop, amount = total}; |
| 358 | applyCharges receive |
| 359 | end |
| 360 | |
| 361 | (* Stripe *) |
| 362 | |
| 363 | type stripePayment = {charge_id : string, webuser_id : int, card_name : string, paid_on : string, gross_cents : int, fee_cents : int, net : real} |
| 364 | |
| 365 | fun mkStripeRow [charge_id, webuser_id, name, paid_on, gross, fee] = |
| 366 | {charge_id = C.stringFromSql charge_id, webuser_id = C.intFromSql webuser_id, |
| 367 | card_name = C.stringFromSql name, paid_on = C.stringFromSql paid_on, |
| 368 | gross_cents = C.intFromSql gross, fee_cents = C.intFromSql fee, net = real (C.intFromSql gross - C.intFromSql fee) / 100.0 } |
| 369 | | mkStripeRow row = Init.rowError ("stripe_payment", row) |
| 370 | |
| 371 | fun listUserPendingStripePayments uid = |
| 372 | C.map (getDb ()) mkStripeRow ($`SELECT charge_id, webuser_id, card_name, paid_on, gross, fee FROM stripe_payment |
| 373 | WHERE webuser_id = ^(C.intToSql uid) |
| 374 | AND charge_id NOT IN (SELECT stripe_charge_id FROM stripe_handled) |
| 375 | ORDER BY paid_on DESC`) |
| 376 | |
| 377 | fun listAllPendingStripePayments _ = |
| 378 | C.map (getDb ()) mkStripeRow ($`SELECT charge_id, webuser_id, card_name, paid_on, gross, fee FROM stripe_payment |
| 379 | WHERE charge_id NOT IN (SELECT stripe_charge_id FROM stripe_handled) |
| 380 | ORDER BY paid_on DESC`) |
| 381 | |
| 382 | fun lookupStripePayment id = |
| 383 | let |
| 384 | val c = getDb () |
| 385 | in |
| 386 | (case C.oneOrNoRows c ($`SELECT charge_id, webuser_id, card_name, paid_on, gross, fee FROM stripe_payment WHERE charge_id = ^(C.stringToSql id)`) of |
| 387 | NONE => raise Fail "Stripe Payment Not Found" |
| 388 | | SOME r => mkStripeRow r) |
| 389 | end |
| 390 | |
| 391 | (* Not Used *) |
| 392 | val stripeNotify : stripePayment -> bool = |
| 393 | fn pmt => |
| 394 | let |
| 395 | val user = Init.lookupUser (#webuser_id pmt) |
| 396 | val mail = Mail.mopen () |
| 397 | in |
| 398 | Mail.mwrite (mail, "From: Hcoop Support System <support"); |
| 399 | Mail.mwrite (mail, emailSuffix); |
| 400 | Mail.mwrite (mail, ">\nTo: payment"); |
| 401 | Mail.mwrite (mail, emailSuffix); |
| 402 | Mail.mwrite (mail, "\n"); |
| 403 | Mail.mwrite (mail, "Subject: Stripe Payment Received"); |
| 404 | Mail.mwrite (mail, "\n\n"); |
| 405 | |
| 406 | Mail.mwrite (mail, "A member has paid us via Stripe. Visit the money page to process the payment."); |
| 407 | Mail.mwrite (mail, "Member: "); |
| 408 | Mail.mwrite (mail, #name user); |
| 409 | Mail.mwrite (mail, "\n"); |
| 410 | Mail.mwrite (mail, "Amount (after fees): "); |
| 411 | Mail.mwrite (mail, Real.toString (#net pmt)); |
| 412 | Mail.mwrite (mail, "\n\n"); |
| 413 | |
| 414 | OS.Process.isSuccess (Mail.mclose mail) |
| 415 | end |
| 416 | |
| 417 | val applyStripePayment : stripePayment -> int = |
| 418 | fn pmt => |
| 419 | let |
| 420 | val _ = Group.requireGroupName "money"; |
| 421 | val amount = #net pmt; |
| 422 | val txid = addTransaction ("Stripe", amount, #paid_on pmt) |
| 423 | in |
| 424 | addCharge {trn = txid, usr = #webuser_id pmt, amount = amount}; |
| 425 | applyCharges txid; |
| 426 | C.dml (getDb ()) ($`INSERT INTO stripe_processed (stripe_charge_id, transaction_id) |
| 427 | VALUES (^(C.stringToSql (#charge_id pmt)), ^(C.intToSql txid))`); |
| 428 | txid |
| 429 | end |
| 430 | end |
| 431 | |