Commit | Line | Data |
---|---|---|
208e2cbc AC |
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} | |
ee587f7f | 14 | | mkTransactionRow row = Init.rowError ("transaction", row) |
208e2cbc AC |
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) | |
ee587f7f AC |
22 | VALUES (^(C.intToSql id), ^(C.stringToSql descr), ^(C.realToSql amount), ^(C.stringToSql d), CURRENT_TIMESTAMP)`); |
23 | id | |
208e2cbc AC |
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) | |
ee587f7f | 86 | | row => Init.rowError ("listUsers", row) |
208e2cbc AC |
87 | |
88 | fun listUsers trn = | |
d5f8418b | 89 | C.map (getDb ()) mkUserRow' ($`SELECT trn, id, name, rname, bal, joined, app, shares, paypal, checkout |
208e2cbc AC |
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} | |
ee587f7f | 100 | | mkChargeRow row = Init.rowError ("charge", row) |
208e2cbc AC |
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) | |
ee587f7f | 112 | | row => Init.rowError ("name+charge", row) |
208e2cbc AC |
113 | |
114 | fun listChargesWithNames trn = | |
d1d096bb | 115 | C.map (getDb ()) mkChargeRow' ($`SELECT name, trn, usr, amount FROM Charge, WebUser |
208e2cbc AC |
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 | |
ee587f7f AC |
129 | SET amount = amount - ^(C.stringFromSql amount) |
130 | WHERE id = ^(C.stringFromSql bal)`)) | |
131 | | clearCharge row = Init.rowError ("clearCharge", row) | |
208e2cbc AC |
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 | ||
f49e1088 | 140 | fun applyCharges trn = |
208e2cbc | 141 | let |
f49e1088 AC |
142 | val db = getDb () |
143 | ||
208e2cbc AC |
144 | fun applyCharge [bal, amount] = |
145 | ignore (C.dml db ($`UPDATE Balance | |
ee587f7f AC |
146 | SET amount = amount + ^(C.stringFromSql amount) |
147 | WHERE id = ^(C.stringFromSql bal)`)) | |
148 | | applyCharge row = Init.rowError ("applyCharge", row) | |
208e2cbc AC |
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; | |
f49e1088 | 170 | applyCharges trn |
208e2cbc AC |
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), | |
2d795343 | 207 | amount + extra) |
208e2cbc AC |
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 | ||
b675b4c5 AC |
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) | |
208e2cbc | 223 | |
b675b4c5 AC |
224 | val even = amount / real shares |
225 | ||
226 | fun doUser ([uid, uname, shares], umap) = | |
208e2cbc | 227 | let |
b675b4c5 AC |
228 | val uid = C.intFromSql uid |
229 | val uname = C.stringFromSql uname | |
230 | val shares = C.intFromSql shares | |
231 | ||
208e2cbc | 232 | val (charge, umap) = |
b675b4c5 AC |
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))) | |
208e2cbc | 236 | in |
b675b4c5 | 237 | addCharge {trn = trn, usr = uid, amount = charge}; |
208e2cbc AC |
238 | umap |
239 | end | |
e84acecc | 240 | |
b675b4c5 AC |
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 | |
e84acecc AC |
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) | |
208e2cbc | 250 | in |
e84acecc AC |
251 | TextIO.output (usageFile, usage); |
252 | TextIO.closeOut usageFile | |
208e2cbc | 253 | end |
2d795343 AC |
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 | ||
e84acecc AC |
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 | ||
aaa50197 AC |
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 | ||
1b566e48 AC |
276 | val monthlyCost = 900.0 |
277 | val graceMonths = 1 | |
278 | ||
8bc5f9f9 | 279 | val baseDues = 7.0 |
5c705bcb | 280 | |
1b566e48 AC |
281 | fun delinquentPledgers () = |
282 | let | |
1b566e48 AC |
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 | |
5c705bcb | 289 | WHERE amount < shares * ^(C.realToSql baseDues) * ^(C.intToSql graceMonths) |
1b566e48 AC |
290 | AND shares > 1 |
291 | ORDER BY name`) | |
292 | end | |
293 | ||
294 | fun resetPledges ids = | |
49e613ae | 295 | ignore (C.dml (getDb ()) ($`UPDATE WebUser SET shares = 1 WHERE id IN (^(String.concatWith ", " (List.map C.intToSql ids)))`)) |
1b566e48 | 296 | |
eafe3d52 AC |
297 | fun freezeworthyPledgers () = |
298 | let | |
27e65914 AC |
299 | fun makeRow [id, name, amount, j] = {id = C.intFromSql id, name = C.stringFromSql name, |
300 | balance = C.realFromSql amount, joinedThisMonth = C.boolFromSql j} | |
eafe3d52 AC |
301 | | makeRow row = Init.rowError ("Bad freezeworthyPledgers", row) |
302 | in | |
27e65914 | 303 | C.map (getDb ()) makeRow ($`SELECT WebUserPaying.id, WebUserPaying.name, amount, CURRENT_TIMESTAMP - joined < INTERVAL '1 month' |
eafe3d52 | 304 | FROM WebUserPaying JOIN Balance ON Balance.id = bal |
5c705bcb AC |
305 | WHERE amount >= ^(C.realToSql baseDues) * ^(C.intToSql graceMonths) |
306 | AND amount < ^(C.realToSql baseDues) * ^(C.intToSql (graceMonths + 1)) | |
eafe3d52 AC |
307 | ORDER BY name`) |
308 | end | |
309 | ||
310 | fun bootworthyPledgers () = | |
311 | let | |
950a4fad AC |
312 | fun makeRow [id, name, amount, j] = {id = C.intFromSql id, name = C.stringFromSql name, |
313 | balance = C.realFromSql amount, joinedThisMonth = C.boolFromSql j} | |
eafe3d52 AC |
314 | | makeRow row = Init.rowError ("Bad bootworthyPledgers", row) |
315 | in | |
950a4fad | 316 | C.map (getDb ()) makeRow ($`SELECT WebUserPaying.id, WebUserPaying.name, amount, CURRENT_TIMESTAMP - joined < INTERVAL '1 month' |
eafe3d52 | 317 | FROM WebUserPaying JOIN Balance ON Balance.id = bal |
5c705bcb | 318 | WHERE amount < ^(C.realToSql baseDues) * ^(C.intToSql graceMonths) |
eafe3d52 AC |
319 | ORDER BY name`) |
320 | end | |
321 | ||
5c705bcb AC |
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 | ||
f8b39e09 CE |
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_processed) | |
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_processed) | |
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 | |
e84acecc | 430 | end |
f8b39e09 | 431 |