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 | ||
e84acecc | 361 | end |